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
);
491 /* Assuming V points to an array of S objects, make sure that it contains at
492 least M objects, updating V and S as necessary. */
494 #define GROW_VECT(v, s, m) \
495 if ((s) < (m)) (v) = (char *) grow_vect (v, &(s), m, sizeof *(v));
497 /* Assuming VECT points to an array of *SIZE objects of size
498 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
499 updating *SIZE as necessary and returning the (new) array. */
502 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
504 if (*size
< min_size
)
507 if (*size
< min_size
)
509 vect
= xrealloc (vect
, *size
* element_size
);
514 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
515 suffix of FIELD_NAME beginning "___". */
518 field_name_match (const char *field_name
, const char *target
)
520 int len
= strlen (target
);
523 (strncmp (field_name
, target
, len
) == 0
524 && (field_name
[len
] == '\0'
525 || (startswith (field_name
+ len
, "___")
526 && strcmp (field_name
+ strlen (field_name
) - 6,
531 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
532 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
533 and return its index. This function also handles fields whose name
534 have ___ suffixes because the compiler sometimes alters their name
535 by adding such a suffix to represent fields with certain constraints.
536 If the field could not be found, return a negative number if
537 MAYBE_MISSING is set. Otherwise raise an error. */
540 ada_get_field_index (const struct type
*type
, const char *field_name
,
544 struct type
*struct_type
= check_typedef ((struct type
*) type
);
546 for (fieldno
= 0; fieldno
< struct_type
->num_fields (); fieldno
++)
547 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
551 error (_("Unable to find field %s in struct %s. Aborting"),
552 field_name
, struct_type
->name ());
557 /* The length of the prefix of NAME prior to any "___" suffix. */
560 ada_name_prefix_len (const char *name
)
566 const char *p
= strstr (name
, "___");
569 return strlen (name
);
575 /* Return non-zero if SUFFIX is a suffix of STR.
576 Return zero if STR is null. */
579 is_suffix (const char *str
, const char *suffix
)
586 len2
= strlen (suffix
);
587 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
590 /* The contents of value VAL, treated as a value of type TYPE. The
591 result is an lval in memory if VAL is. */
593 static struct value
*
594 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
596 type
= ada_check_typedef (type
);
597 if (value_type (val
) == type
)
601 struct value
*result
;
603 /* Make sure that the object size is not unreasonable before
604 trying to allocate some memory for it. */
605 ada_ensure_varsize_limit (type
);
608 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
609 result
= allocate_value_lazy (type
);
612 result
= allocate_value (type
);
613 value_contents_copy_raw (result
, 0, val
, 0, TYPE_LENGTH (type
));
615 set_value_component_location (result
, val
);
616 set_value_bitsize (result
, value_bitsize (val
));
617 set_value_bitpos (result
, value_bitpos (val
));
618 if (VALUE_LVAL (result
) == lval_memory
)
619 set_value_address (result
, value_address (val
));
624 static const gdb_byte
*
625 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
630 return valaddr
+ offset
;
634 cond_offset_target (CORE_ADDR address
, long offset
)
639 return address
+ offset
;
642 /* Issue a warning (as for the definition of warning in utils.c, but
643 with exactly one argument rather than ...), unless the limit on the
644 number of warnings has passed during the evaluation of the current
647 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
648 provided by "complaint". */
649 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
652 lim_warning (const char *format
, ...)
656 va_start (args
, format
);
657 warnings_issued
+= 1;
658 if (warnings_issued
<= warning_limit
)
659 vwarning (format
, args
);
664 /* Issue an error if the size of an object of type T is unreasonable,
665 i.e. if it would be a bad idea to allocate a value of this type in
669 ada_ensure_varsize_limit (const struct type
*type
)
671 if (TYPE_LENGTH (type
) > varsize_limit
)
672 error (_("object size is larger than varsize-limit"));
675 /* Maximum value of a SIZE-byte signed integer type. */
677 max_of_size (int size
)
679 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
681 return top_bit
| (top_bit
- 1);
684 /* Minimum value of a SIZE-byte signed integer type. */
686 min_of_size (int size
)
688 return -max_of_size (size
) - 1;
691 /* Maximum value of a SIZE-byte unsigned integer type. */
693 umax_of_size (int size
)
695 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
697 return top_bit
| (top_bit
- 1);
700 /* Maximum value of integral type T, as a signed quantity. */
702 max_of_type (struct type
*t
)
704 if (TYPE_UNSIGNED (t
))
705 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
707 return max_of_size (TYPE_LENGTH (t
));
710 /* Minimum value of integral type T, as a signed quantity. */
712 min_of_type (struct type
*t
)
714 if (TYPE_UNSIGNED (t
))
717 return min_of_size (TYPE_LENGTH (t
));
720 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
722 ada_discrete_type_high_bound (struct type
*type
)
724 type
= resolve_dynamic_type (type
, {}, 0);
725 switch (type
->code ())
727 case TYPE_CODE_RANGE
:
728 return TYPE_HIGH_BOUND (type
);
730 return TYPE_FIELD_ENUMVAL (type
, type
->num_fields () - 1);
735 return max_of_type (type
);
737 error (_("Unexpected type in ada_discrete_type_high_bound."));
741 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
743 ada_discrete_type_low_bound (struct type
*type
)
745 type
= resolve_dynamic_type (type
, {}, 0);
746 switch (type
->code ())
748 case TYPE_CODE_RANGE
:
749 return TYPE_LOW_BOUND (type
);
751 return TYPE_FIELD_ENUMVAL (type
, 0);
756 return min_of_type (type
);
758 error (_("Unexpected type in ada_discrete_type_low_bound."));
762 /* The identity on non-range types. For range types, the underlying
763 non-range scalar type. */
766 get_base_type (struct type
*type
)
768 while (type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
)
770 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
772 type
= TYPE_TARGET_TYPE (type
);
777 /* Return a decoded version of the given VALUE. This means returning
778 a value whose type is obtained by applying all the GNAT-specific
779 encodings, making the resulting type a static but standard description
780 of the initial type. */
783 ada_get_decoded_value (struct value
*value
)
785 struct type
*type
= ada_check_typedef (value_type (value
));
787 if (ada_is_array_descriptor_type (type
)
788 || (ada_is_constrained_packed_array_type (type
)
789 && type
->code () != TYPE_CODE_PTR
))
791 if (type
->code () == TYPE_CODE_TYPEDEF
) /* array access type. */
792 value
= ada_coerce_to_simple_array_ptr (value
);
794 value
= ada_coerce_to_simple_array (value
);
797 value
= ada_to_fixed_value (value
);
802 /* Same as ada_get_decoded_value, but with the given TYPE.
803 Because there is no associated actual value for this type,
804 the resulting type might be a best-effort approximation in
805 the case of dynamic types. */
808 ada_get_decoded_type (struct type
*type
)
810 type
= to_static_fixed_type (type
);
811 if (ada_is_constrained_packed_array_type (type
))
812 type
= ada_coerce_to_simple_array_type (type
);
818 /* Language Selection */
820 /* If the main program is in Ada, return language_ada, otherwise return LANG
821 (the main program is in Ada iif the adainit symbol is found). */
824 ada_update_initial_language (enum language lang
)
826 if (lookup_minimal_symbol ("adainit", NULL
, NULL
).minsym
!= NULL
)
832 /* If the main procedure is written in Ada, then return its name.
833 The result is good until the next call. Return NULL if the main
834 procedure doesn't appear to be in Ada. */
839 struct bound_minimal_symbol msym
;
840 static gdb::unique_xmalloc_ptr
<char> main_program_name
;
842 /* For Ada, the name of the main procedure is stored in a specific
843 string constant, generated by the binder. Look for that symbol,
844 extract its address, and then read that string. If we didn't find
845 that string, then most probably the main procedure is not written
847 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
849 if (msym
.minsym
!= NULL
)
851 CORE_ADDR main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
852 if (main_program_name_addr
== 0)
853 error (_("Invalid address for Ada main program name."));
855 main_program_name
= target_read_string (main_program_name_addr
, 1024);
856 return main_program_name
.get ();
859 /* The main procedure doesn't seem to be in Ada. */
865 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
868 const struct ada_opname_map ada_opname_table
[] = {
869 {"Oadd", "\"+\"", BINOP_ADD
},
870 {"Osubtract", "\"-\"", BINOP_SUB
},
871 {"Omultiply", "\"*\"", BINOP_MUL
},
872 {"Odivide", "\"/\"", BINOP_DIV
},
873 {"Omod", "\"mod\"", BINOP_MOD
},
874 {"Orem", "\"rem\"", BINOP_REM
},
875 {"Oexpon", "\"**\"", BINOP_EXP
},
876 {"Olt", "\"<\"", BINOP_LESS
},
877 {"Ole", "\"<=\"", BINOP_LEQ
},
878 {"Ogt", "\">\"", BINOP_GTR
},
879 {"Oge", "\">=\"", BINOP_GEQ
},
880 {"Oeq", "\"=\"", BINOP_EQUAL
},
881 {"One", "\"/=\"", BINOP_NOTEQUAL
},
882 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
883 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
884 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
885 {"Oconcat", "\"&\"", BINOP_CONCAT
},
886 {"Oabs", "\"abs\"", UNOP_ABS
},
887 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
888 {"Oadd", "\"+\"", UNOP_PLUS
},
889 {"Osubtract", "\"-\"", UNOP_NEG
},
893 /* The "encoded" form of DECODED, according to GNAT conventions. The
894 result is valid until the next call to ada_encode. If
895 THROW_ERRORS, throw an error if invalid operator name is found.
896 Otherwise, return NULL in that case. */
899 ada_encode_1 (const char *decoded
, bool throw_errors
)
901 static char *encoding_buffer
= NULL
;
902 static size_t encoding_buffer_size
= 0;
909 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
910 2 * strlen (decoded
) + 10);
913 for (p
= decoded
; *p
!= '\0'; p
+= 1)
917 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
922 const struct ada_opname_map
*mapping
;
924 for (mapping
= ada_opname_table
;
925 mapping
->encoded
!= NULL
926 && !startswith (p
, mapping
->decoded
); mapping
+= 1)
928 if (mapping
->encoded
== NULL
)
931 error (_("invalid Ada operator name: %s"), p
);
935 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
936 k
+= strlen (mapping
->encoded
);
941 encoding_buffer
[k
] = *p
;
946 encoding_buffer
[k
] = '\0';
947 return encoding_buffer
;
950 /* The "encoded" form of DECODED, according to GNAT conventions.
951 The result is valid until the next call to ada_encode. */
954 ada_encode (const char *decoded
)
956 return ada_encode_1 (decoded
, true);
959 /* Return NAME folded to lower case, or, if surrounded by single
960 quotes, unfolded, but with the quotes stripped away. Result good
964 ada_fold_name (gdb::string_view name
)
966 static char *fold_buffer
= NULL
;
967 static size_t fold_buffer_size
= 0;
969 int len
= name
.size ();
970 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
974 strncpy (fold_buffer
, name
.data () + 1, len
- 2);
975 fold_buffer
[len
- 2] = '\000';
981 for (i
= 0; i
<= len
; i
+= 1)
982 fold_buffer
[i
] = tolower (name
[i
]);
988 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
991 is_lower_alphanum (const char c
)
993 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
996 /* ENCODED is the linkage name of a symbol and LEN contains its length.
997 This function saves in LEN the length of that same symbol name but
998 without either of these suffixes:
1004 These are suffixes introduced by the compiler for entities such as
1005 nested subprogram for instance, in order to avoid name clashes.
1006 They do not serve any purpose for the debugger. */
1009 ada_remove_trailing_digits (const char *encoded
, int *len
)
1011 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1015 while (i
> 0 && isdigit (encoded
[i
]))
1017 if (i
>= 0 && encoded
[i
] == '.')
1019 else if (i
>= 0 && encoded
[i
] == '$')
1021 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
1023 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
1028 /* Remove the suffix introduced by the compiler for protected object
1032 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1034 /* Remove trailing N. */
1036 /* Protected entry subprograms are broken into two
1037 separate subprograms: The first one is unprotected, and has
1038 a 'N' suffix; the second is the protected version, and has
1039 the 'P' suffix. The second calls the first one after handling
1040 the protection. Since the P subprograms are internally generated,
1041 we leave these names undecoded, giving the user a clue that this
1042 entity is internal. */
1045 && encoded
[*len
- 1] == 'N'
1046 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1050 /* If ENCODED follows the GNAT entity encoding conventions, then return
1051 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1052 replaced by ENCODED. */
1055 ada_decode (const char *encoded
)
1061 std::string decoded
;
1063 /* With function descriptors on PPC64, the value of a symbol named
1064 ".FN", if it exists, is the entry point of the function "FN". */
1065 if (encoded
[0] == '.')
1068 /* The name of the Ada main procedure starts with "_ada_".
1069 This prefix is not part of the decoded name, so skip this part
1070 if we see this prefix. */
1071 if (startswith (encoded
, "_ada_"))
1074 /* If the name starts with '_', then it is not a properly encoded
1075 name, so do not attempt to decode it. Similarly, if the name
1076 starts with '<', the name should not be decoded. */
1077 if (encoded
[0] == '_' || encoded
[0] == '<')
1080 len0
= strlen (encoded
);
1082 ada_remove_trailing_digits (encoded
, &len0
);
1083 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1085 /* Remove the ___X.* suffix if present. Do not forget to verify that
1086 the suffix is located before the current "end" of ENCODED. We want
1087 to avoid re-matching parts of ENCODED that have previously been
1088 marked as discarded (by decrementing LEN0). */
1089 p
= strstr (encoded
, "___");
1090 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1098 /* Remove any trailing TKB suffix. It tells us that this symbol
1099 is for the body of a task, but that information does not actually
1100 appear in the decoded name. */
1102 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1105 /* Remove any trailing TB suffix. The TB suffix is slightly different
1106 from the TKB suffix because it is used for non-anonymous task
1109 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1112 /* Remove trailing "B" suffixes. */
1113 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1115 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1118 /* Make decoded big enough for possible expansion by operator name. */
1120 decoded
.resize (2 * len0
+ 1, 'X');
1122 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1124 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1127 while ((i
>= 0 && isdigit (encoded
[i
]))
1128 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1130 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1132 else if (encoded
[i
] == '$')
1136 /* The first few characters that are not alphabetic are not part
1137 of any encoding we use, so we can copy them over verbatim. */
1139 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1140 decoded
[j
] = encoded
[i
];
1145 /* Is this a symbol function? */
1146 if (at_start_name
&& encoded
[i
] == 'O')
1150 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1152 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1153 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1155 && !isalnum (encoded
[i
+ op_len
]))
1157 strcpy (&decoded
.front() + j
, ada_opname_table
[k
].decoded
);
1160 j
+= strlen (ada_opname_table
[k
].decoded
);
1164 if (ada_opname_table
[k
].encoded
!= NULL
)
1169 /* Replace "TK__" with "__", which will eventually be translated
1170 into "." (just below). */
1172 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1175 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1176 be translated into "." (just below). These are internal names
1177 generated for anonymous blocks inside which our symbol is nested. */
1179 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1180 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1181 && isdigit (encoded
[i
+4]))
1185 while (k
< len0
&& isdigit (encoded
[k
]))
1186 k
++; /* Skip any extra digit. */
1188 /* Double-check that the "__B_{DIGITS}+" sequence we found
1189 is indeed followed by "__". */
1190 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1194 /* Remove _E{DIGITS}+[sb] */
1196 /* Just as for protected object subprograms, there are 2 categories
1197 of subprograms created by the compiler for each entry. The first
1198 one implements the actual entry code, and has a suffix following
1199 the convention above; the second one implements the barrier and
1200 uses the same convention as above, except that the 'E' is replaced
1203 Just as above, we do not decode the name of barrier functions
1204 to give the user a clue that the code he is debugging has been
1205 internally generated. */
1207 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1208 && isdigit (encoded
[i
+2]))
1212 while (k
< len0
&& isdigit (encoded
[k
]))
1216 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1219 /* Just as an extra precaution, make sure that if this
1220 suffix is followed by anything else, it is a '_'.
1221 Otherwise, we matched this sequence by accident. */
1223 || (k
< len0
&& encoded
[k
] == '_'))
1228 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1229 the GNAT front-end in protected object subprograms. */
1232 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1234 /* Backtrack a bit up until we reach either the begining of
1235 the encoded name, or "__". Make sure that we only find
1236 digits or lowercase characters. */
1237 const char *ptr
= encoded
+ i
- 1;
1239 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1242 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1246 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1248 /* This is a X[bn]* sequence not separated from the previous
1249 part of the name with a non-alpha-numeric character (in other
1250 words, immediately following an alpha-numeric character), then
1251 verify that it is placed at the end of the encoded name. If
1252 not, then the encoding is not valid and we should abort the
1253 decoding. Otherwise, just skip it, it is used in body-nested
1257 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1261 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1263 /* Replace '__' by '.'. */
1271 /* It's a character part of the decoded name, so just copy it
1273 decoded
[j
] = encoded
[i
];
1280 /* Decoded names should never contain any uppercase character.
1281 Double-check this, and abort the decoding if we find one. */
1283 for (i
= 0; i
< decoded
.length(); ++i
)
1284 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1290 if (encoded
[0] == '<')
1293 decoded
= '<' + std::string(encoded
) + '>';
1298 /* Table for keeping permanent unique copies of decoded names. Once
1299 allocated, names in this table are never released. While this is a
1300 storage leak, it should not be significant unless there are massive
1301 changes in the set of decoded names in successive versions of a
1302 symbol table loaded during a single session. */
1303 static struct htab
*decoded_names_store
;
1305 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1306 in the language-specific part of GSYMBOL, if it has not been
1307 previously computed. Tries to save the decoded name in the same
1308 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1309 in any case, the decoded symbol has a lifetime at least that of
1311 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1312 const, but nevertheless modified to a semantically equivalent form
1313 when a decoded name is cached in it. */
1316 ada_decode_symbol (const struct general_symbol_info
*arg
)
1318 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1319 const char **resultp
=
1320 &gsymbol
->language_specific
.demangled_name
;
1322 if (!gsymbol
->ada_mangled
)
1324 std::string decoded
= ada_decode (gsymbol
->linkage_name ());
1325 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1327 gsymbol
->ada_mangled
= 1;
1329 if (obstack
!= NULL
)
1330 *resultp
= obstack_strdup (obstack
, decoded
.c_str ());
1333 /* Sometimes, we can't find a corresponding objfile, in
1334 which case, we put the result on the heap. Since we only
1335 decode when needed, we hope this usually does not cause a
1336 significant memory leak (FIXME). */
1338 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1339 decoded
.c_str (), INSERT
);
1342 *slot
= xstrdup (decoded
.c_str ());
1351 ada_la_decode (const char *encoded
, int options
)
1353 return xstrdup (ada_decode (encoded
).c_str ());
1360 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1361 generated by the GNAT compiler to describe the index type used
1362 for each dimension of an array, check whether it follows the latest
1363 known encoding. If not, fix it up to conform to the latest encoding.
1364 Otherwise, do nothing. This function also does nothing if
1365 INDEX_DESC_TYPE is NULL.
1367 The GNAT encoding used to describe the array index type evolved a bit.
1368 Initially, the information would be provided through the name of each
1369 field of the structure type only, while the type of these fields was
1370 described as unspecified and irrelevant. The debugger was then expected
1371 to perform a global type lookup using the name of that field in order
1372 to get access to the full index type description. Because these global
1373 lookups can be very expensive, the encoding was later enhanced to make
1374 the global lookup unnecessary by defining the field type as being
1375 the full index type description.
1377 The purpose of this routine is to allow us to support older versions
1378 of the compiler by detecting the use of the older encoding, and by
1379 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1380 we essentially replace each field's meaningless type by the associated
1384 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1388 if (index_desc_type
== NULL
)
1390 gdb_assert (index_desc_type
->num_fields () > 0);
1392 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1393 to check one field only, no need to check them all). If not, return
1396 If our INDEX_DESC_TYPE was generated using the older encoding,
1397 the field type should be a meaningless integer type whose name
1398 is not equal to the field name. */
1399 if (index_desc_type
->field (0).type ()->name () != NULL
1400 && strcmp (index_desc_type
->field (0).type ()->name (),
1401 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1404 /* Fixup each field of INDEX_DESC_TYPE. */
1405 for (i
= 0; i
< index_desc_type
->num_fields (); i
++)
1407 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1408 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1411 index_desc_type
->field (i
).set_type (raw_type
);
1415 /* The desc_* routines return primitive portions of array descriptors
1418 /* The descriptor or array type, if any, indicated by TYPE; removes
1419 level of indirection, if needed. */
1421 static struct type
*
1422 desc_base_type (struct type
*type
)
1426 type
= ada_check_typedef (type
);
1427 if (type
->code () == TYPE_CODE_TYPEDEF
)
1428 type
= ada_typedef_target_type (type
);
1431 && (type
->code () == TYPE_CODE_PTR
1432 || type
->code () == TYPE_CODE_REF
))
1433 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1438 /* True iff TYPE indicates a "thin" array pointer type. */
1441 is_thin_pntr (struct type
*type
)
1444 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1445 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1448 /* The descriptor type for thin pointer type TYPE. */
1450 static struct type
*
1451 thin_descriptor_type (struct type
*type
)
1453 struct type
*base_type
= desc_base_type (type
);
1455 if (base_type
== NULL
)
1457 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1461 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1463 if (alt_type
== NULL
)
1470 /* A pointer to the array data for thin-pointer value VAL. */
1472 static struct value
*
1473 thin_data_pntr (struct value
*val
)
1475 struct type
*type
= ada_check_typedef (value_type (val
));
1476 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1478 data_type
= lookup_pointer_type (data_type
);
1480 if (type
->code () == TYPE_CODE_PTR
)
1481 return value_cast (data_type
, value_copy (val
));
1483 return value_from_longest (data_type
, value_address (val
));
1486 /* True iff TYPE indicates a "thick" array pointer type. */
1489 is_thick_pntr (struct type
*type
)
1491 type
= desc_base_type (type
);
1492 return (type
!= NULL
&& type
->code () == TYPE_CODE_STRUCT
1493 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1496 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1497 pointer to one, the type of its bounds data; otherwise, NULL. */
1499 static struct type
*
1500 desc_bounds_type (struct type
*type
)
1504 type
= desc_base_type (type
);
1508 else if (is_thin_pntr (type
))
1510 type
= thin_descriptor_type (type
);
1513 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1515 return ada_check_typedef (r
);
1517 else if (type
->code () == TYPE_CODE_STRUCT
)
1519 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1521 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1526 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1527 one, a pointer to its bounds data. Otherwise NULL. */
1529 static struct value
*
1530 desc_bounds (struct value
*arr
)
1532 struct type
*type
= ada_check_typedef (value_type (arr
));
1534 if (is_thin_pntr (type
))
1536 struct type
*bounds_type
=
1537 desc_bounds_type (thin_descriptor_type (type
));
1540 if (bounds_type
== NULL
)
1541 error (_("Bad GNAT array descriptor"));
1543 /* NOTE: The following calculation is not really kosher, but
1544 since desc_type is an XVE-encoded type (and shouldn't be),
1545 the correct calculation is a real pain. FIXME (and fix GCC). */
1546 if (type
->code () == TYPE_CODE_PTR
)
1547 addr
= value_as_long (arr
);
1549 addr
= value_address (arr
);
1552 value_from_longest (lookup_pointer_type (bounds_type
),
1553 addr
- TYPE_LENGTH (bounds_type
));
1556 else if (is_thick_pntr (type
))
1558 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1559 _("Bad GNAT array descriptor"));
1560 struct type
*p_bounds_type
= value_type (p_bounds
);
1563 && p_bounds_type
->code () == TYPE_CODE_PTR
)
1565 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1567 if (TYPE_STUB (target_type
))
1568 p_bounds
= value_cast (lookup_pointer_type
1569 (ada_check_typedef (target_type
)),
1573 error (_("Bad GNAT array descriptor"));
1581 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1582 position of the field containing the address of the bounds data. */
1585 fat_pntr_bounds_bitpos (struct type
*type
)
1587 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1590 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1591 size of the field containing the address of the bounds data. */
1594 fat_pntr_bounds_bitsize (struct type
*type
)
1596 type
= desc_base_type (type
);
1598 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1599 return TYPE_FIELD_BITSIZE (type
, 1);
1601 return 8 * TYPE_LENGTH (ada_check_typedef (type
->field (1).type ()));
1604 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1605 pointer to one, the type of its array data (a array-with-no-bounds type);
1606 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1609 static struct type
*
1610 desc_data_target_type (struct type
*type
)
1612 type
= desc_base_type (type
);
1614 /* NOTE: The following is bogus; see comment in desc_bounds. */
1615 if (is_thin_pntr (type
))
1616 return desc_base_type (thin_descriptor_type (type
)->field (1).type ());
1617 else if (is_thick_pntr (type
))
1619 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1622 && ada_check_typedef (data_type
)->code () == TYPE_CODE_PTR
)
1623 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1629 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1632 static struct value
*
1633 desc_data (struct value
*arr
)
1635 struct type
*type
= value_type (arr
);
1637 if (is_thin_pntr (type
))
1638 return thin_data_pntr (arr
);
1639 else if (is_thick_pntr (type
))
1640 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1641 _("Bad GNAT array descriptor"));
1647 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1648 position of the field containing the address of the data. */
1651 fat_pntr_data_bitpos (struct type
*type
)
1653 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1656 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1657 size of the field containing the address of the data. */
1660 fat_pntr_data_bitsize (struct type
*type
)
1662 type
= desc_base_type (type
);
1664 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1665 return TYPE_FIELD_BITSIZE (type
, 0);
1667 return TARGET_CHAR_BIT
* TYPE_LENGTH (type
->field (0).type ());
1670 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1671 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1672 bound, if WHICH is 1. The first bound is I=1. */
1674 static struct value
*
1675 desc_one_bound (struct value
*bounds
, int i
, int which
)
1677 char bound_name
[20];
1678 xsnprintf (bound_name
, sizeof (bound_name
), "%cB%d",
1679 which
? 'U' : 'L', i
- 1);
1680 return value_struct_elt (&bounds
, NULL
, bound_name
, NULL
,
1681 _("Bad GNAT array descriptor bounds"));
1684 /* If BOUNDS is an array-bounds structure type, return the bit position
1685 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1686 bound, if WHICH is 1. The first bound is I=1. */
1689 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1691 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1694 /* If BOUNDS is an array-bounds structure type, return the bit field size
1695 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1696 bound, if WHICH is 1. The first bound is I=1. */
1699 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1701 type
= desc_base_type (type
);
1703 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1704 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1706 return 8 * TYPE_LENGTH (type
->field (2 * i
+ which
- 2).type ());
1709 /* If TYPE is the type of an array-bounds structure, the type of its
1710 Ith bound (numbering from 1). Otherwise, NULL. */
1712 static struct type
*
1713 desc_index_type (struct type
*type
, int i
)
1715 type
= desc_base_type (type
);
1717 if (type
->code () == TYPE_CODE_STRUCT
)
1719 char bound_name
[20];
1720 xsnprintf (bound_name
, sizeof (bound_name
), "LB%d", i
- 1);
1721 return lookup_struct_elt_type (type
, bound_name
, 1);
1727 /* The number of index positions in the array-bounds type TYPE.
1728 Return 0 if TYPE is NULL. */
1731 desc_arity (struct type
*type
)
1733 type
= desc_base_type (type
);
1736 return type
->num_fields () / 2;
1740 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1741 an array descriptor type (representing an unconstrained array
1745 ada_is_direct_array_type (struct type
*type
)
1749 type
= ada_check_typedef (type
);
1750 return (type
->code () == TYPE_CODE_ARRAY
1751 || ada_is_array_descriptor_type (type
));
1754 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1758 ada_is_array_type (struct type
*type
)
1761 && (type
->code () == TYPE_CODE_PTR
1762 || type
->code () == TYPE_CODE_REF
))
1763 type
= TYPE_TARGET_TYPE (type
);
1764 return ada_is_direct_array_type (type
);
1767 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1770 ada_is_simple_array_type (struct type
*type
)
1774 type
= ada_check_typedef (type
);
1775 return (type
->code () == TYPE_CODE_ARRAY
1776 || (type
->code () == TYPE_CODE_PTR
1777 && (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ()
1778 == TYPE_CODE_ARRAY
)));
1781 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1784 ada_is_array_descriptor_type (struct type
*type
)
1786 struct type
*data_type
= desc_data_target_type (type
);
1790 type
= ada_check_typedef (type
);
1791 return (data_type
!= NULL
1792 && data_type
->code () == TYPE_CODE_ARRAY
1793 && desc_arity (desc_bounds_type (type
)) > 0);
1796 /* Non-zero iff type is a partially mal-formed GNAT array
1797 descriptor. FIXME: This is to compensate for some problems with
1798 debugging output from GNAT. Re-examine periodically to see if it
1802 ada_is_bogus_array_descriptor (struct type
*type
)
1806 && type
->code () == TYPE_CODE_STRUCT
1807 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1808 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1809 && !ada_is_array_descriptor_type (type
);
1813 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1814 (fat pointer) returns the type of the array data described---specifically,
1815 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1816 in from the descriptor; otherwise, they are left unspecified. If
1817 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1818 returns NULL. The result is simply the type of ARR if ARR is not
1821 static struct type
*
1822 ada_type_of_array (struct value
*arr
, int bounds
)
1824 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1825 return decode_constrained_packed_array_type (value_type (arr
));
1827 if (!ada_is_array_descriptor_type (value_type (arr
)))
1828 return value_type (arr
);
1832 struct type
*array_type
=
1833 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1835 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1836 TYPE_FIELD_BITSIZE (array_type
, 0) =
1837 decode_packed_array_bitsize (value_type (arr
));
1843 struct type
*elt_type
;
1845 struct value
*descriptor
;
1847 elt_type
= ada_array_element_type (value_type (arr
), -1);
1848 arity
= ada_array_arity (value_type (arr
));
1850 if (elt_type
== NULL
|| arity
== 0)
1851 return ada_check_typedef (value_type (arr
));
1853 descriptor
= desc_bounds (arr
);
1854 if (value_as_long (descriptor
) == 0)
1858 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1859 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1860 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1861 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1864 create_static_range_type (range_type
, value_type (low
),
1865 longest_to_int (value_as_long (low
)),
1866 longest_to_int (value_as_long (high
)));
1867 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1869 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1871 /* We need to store the element packed bitsize, as well as
1872 recompute the array size, because it was previously
1873 computed based on the unpacked element size. */
1874 LONGEST lo
= value_as_long (low
);
1875 LONGEST hi
= value_as_long (high
);
1877 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1878 decode_packed_array_bitsize (value_type (arr
));
1879 /* If the array has no element, then the size is already
1880 zero, and does not need to be recomputed. */
1884 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
1886 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
1891 return lookup_pointer_type (elt_type
);
1895 /* If ARR does not represent an array, returns ARR unchanged.
1896 Otherwise, returns either a standard GDB array with bounds set
1897 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1898 GDB array. Returns NULL if ARR is a null fat pointer. */
1901 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1903 if (ada_is_array_descriptor_type (value_type (arr
)))
1905 struct type
*arrType
= ada_type_of_array (arr
, 1);
1907 if (arrType
== NULL
)
1909 return value_cast (arrType
, value_copy (desc_data (arr
)));
1911 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1912 return decode_constrained_packed_array (arr
);
1917 /* If ARR does not represent an array, returns ARR unchanged.
1918 Otherwise, returns a standard GDB array describing ARR (which may
1919 be ARR itself if it already is in the proper form). */
1922 ada_coerce_to_simple_array (struct value
*arr
)
1924 if (ada_is_array_descriptor_type (value_type (arr
)))
1926 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1929 error (_("Bounds unavailable for null array pointer."));
1930 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
1931 return value_ind (arrVal
);
1933 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1934 return decode_constrained_packed_array (arr
);
1939 /* If TYPE represents a GNAT array type, return it translated to an
1940 ordinary GDB array type (possibly with BITSIZE fields indicating
1941 packing). For other types, is the identity. */
1944 ada_coerce_to_simple_array_type (struct type
*type
)
1946 if (ada_is_constrained_packed_array_type (type
))
1947 return decode_constrained_packed_array_type (type
);
1949 if (ada_is_array_descriptor_type (type
))
1950 return ada_check_typedef (desc_data_target_type (type
));
1955 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1958 ada_is_packed_array_type (struct type
*type
)
1962 type
= desc_base_type (type
);
1963 type
= ada_check_typedef (type
);
1965 ada_type_name (type
) != NULL
1966 && strstr (ada_type_name (type
), "___XP") != NULL
;
1969 /* Non-zero iff TYPE represents a standard GNAT constrained
1970 packed-array type. */
1973 ada_is_constrained_packed_array_type (struct type
*type
)
1975 return ada_is_packed_array_type (type
)
1976 && !ada_is_array_descriptor_type (type
);
1979 /* Non-zero iff TYPE represents an array descriptor for a
1980 unconstrained packed-array type. */
1983 ada_is_unconstrained_packed_array_type (struct type
*type
)
1985 return ada_is_packed_array_type (type
)
1986 && ada_is_array_descriptor_type (type
);
1989 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
1990 return the size of its elements in bits. */
1993 decode_packed_array_bitsize (struct type
*type
)
1995 const char *raw_name
;
1999 /* Access to arrays implemented as fat pointers are encoded as a typedef
2000 of the fat pointer type. We need the name of the fat pointer type
2001 to do the decoding, so strip the typedef layer. */
2002 if (type
->code () == TYPE_CODE_TYPEDEF
)
2003 type
= ada_typedef_target_type (type
);
2005 raw_name
= ada_type_name (ada_check_typedef (type
));
2007 raw_name
= ada_type_name (desc_base_type (type
));
2012 tail
= strstr (raw_name
, "___XP");
2013 gdb_assert (tail
!= NULL
);
2015 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2018 (_("could not understand bit size information on packed array"));
2025 /* Given that TYPE is a standard GDB array type with all bounds filled
2026 in, and that the element size of its ultimate scalar constituents
2027 (that is, either its elements, or, if it is an array of arrays, its
2028 elements' elements, etc.) is *ELT_BITS, return an identical type,
2029 but with the bit sizes of its elements (and those of any
2030 constituent arrays) recorded in the BITSIZE components of its
2031 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2034 Note that, for arrays whose index type has an XA encoding where
2035 a bound references a record discriminant, getting that discriminant,
2036 and therefore the actual value of that bound, is not possible
2037 because none of the given parameters gives us access to the record.
2038 This function assumes that it is OK in the context where it is being
2039 used to return an array whose bounds are still dynamic and where
2040 the length is arbitrary. */
2042 static struct type
*
2043 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2045 struct type
*new_elt_type
;
2046 struct type
*new_type
;
2047 struct type
*index_type_desc
;
2048 struct type
*index_type
;
2049 LONGEST low_bound
, high_bound
;
2051 type
= ada_check_typedef (type
);
2052 if (type
->code () != TYPE_CODE_ARRAY
)
2055 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2056 if (index_type_desc
)
2057 index_type
= to_fixed_range_type (index_type_desc
->field (0).type (),
2060 index_type
= type
->index_type ();
2062 new_type
= alloc_type_copy (type
);
2064 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2066 create_array_type (new_type
, new_elt_type
, index_type
);
2067 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2068 new_type
->set_name (ada_type_name (type
));
2070 if ((check_typedef (index_type
)->code () == TYPE_CODE_RANGE
2071 && is_dynamic_type (check_typedef (index_type
)))
2072 || get_discrete_bounds (index_type
, &low_bound
, &high_bound
) < 0)
2073 low_bound
= high_bound
= 0;
2074 if (high_bound
< low_bound
)
2075 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2078 *elt_bits
*= (high_bound
- low_bound
+ 1);
2079 TYPE_LENGTH (new_type
) =
2080 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2083 TYPE_FIXED_INSTANCE (new_type
) = 1;
2087 /* The array type encoded by TYPE, where
2088 ada_is_constrained_packed_array_type (TYPE). */
2090 static struct type
*
2091 decode_constrained_packed_array_type (struct type
*type
)
2093 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2096 struct type
*shadow_type
;
2100 raw_name
= ada_type_name (desc_base_type (type
));
2105 name
= (char *) alloca (strlen (raw_name
) + 1);
2106 tail
= strstr (raw_name
, "___XP");
2107 type
= desc_base_type (type
);
2109 memcpy (name
, raw_name
, tail
- raw_name
);
2110 name
[tail
- raw_name
] = '\000';
2112 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2114 if (shadow_type
== NULL
)
2116 lim_warning (_("could not find bounds information on packed array"));
2119 shadow_type
= check_typedef (shadow_type
);
2121 if (shadow_type
->code () != TYPE_CODE_ARRAY
)
2123 lim_warning (_("could not understand bounds "
2124 "information on packed array"));
2128 bits
= decode_packed_array_bitsize (type
);
2129 return constrained_packed_array_type (shadow_type
, &bits
);
2132 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2133 array, returns a simple array that denotes that array. Its type is a
2134 standard GDB array type except that the BITSIZEs of the array
2135 target types are set to the number of bits in each element, and the
2136 type length is set appropriately. */
2138 static struct value
*
2139 decode_constrained_packed_array (struct value
*arr
)
2143 /* If our value is a pointer, then dereference it. Likewise if
2144 the value is a reference. Make sure that this operation does not
2145 cause the target type to be fixed, as this would indirectly cause
2146 this array to be decoded. The rest of the routine assumes that
2147 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2148 and "value_ind" routines to perform the dereferencing, as opposed
2149 to using "ada_coerce_ref" or "ada_value_ind". */
2150 arr
= coerce_ref (arr
);
2151 if (ada_check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2152 arr
= value_ind (arr
);
2154 type
= decode_constrained_packed_array_type (value_type (arr
));
2157 error (_("can't unpack array"));
2161 if (type_byte_order (value_type (arr
)) == BFD_ENDIAN_BIG
2162 && ada_is_modular_type (value_type (arr
)))
2164 /* This is a (right-justified) modular type representing a packed
2165 array with no wrapper. In order to interpret the value through
2166 the (left-justified) packed array type we just built, we must
2167 first left-justify it. */
2168 int bit_size
, bit_pos
;
2171 mod
= ada_modulus (value_type (arr
)) - 1;
2178 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2179 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2180 bit_pos
/ HOST_CHAR_BIT
,
2181 bit_pos
% HOST_CHAR_BIT
,
2186 return coerce_unspec_val_to_type (arr
, type
);
2190 /* The value of the element of packed array ARR at the ARITY indices
2191 given in IND. ARR must be a simple array. */
2193 static struct value
*
2194 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2197 int bits
, elt_off
, bit_off
;
2198 long elt_total_bit_offset
;
2199 struct type
*elt_type
;
2203 elt_total_bit_offset
= 0;
2204 elt_type
= ada_check_typedef (value_type (arr
));
2205 for (i
= 0; i
< arity
; i
+= 1)
2207 if (elt_type
->code () != TYPE_CODE_ARRAY
2208 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2210 (_("attempt to do packed indexing of "
2211 "something other than a packed array"));
2214 struct type
*range_type
= elt_type
->index_type ();
2215 LONGEST lowerbound
, upperbound
;
2218 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2220 lim_warning (_("don't know bounds of array"));
2221 lowerbound
= upperbound
= 0;
2224 idx
= pos_atr (ind
[i
]);
2225 if (idx
< lowerbound
|| idx
> upperbound
)
2226 lim_warning (_("packed array index %ld out of bounds"),
2228 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2229 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2230 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2233 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2234 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2236 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2241 /* Non-zero iff TYPE includes negative integer values. */
2244 has_negatives (struct type
*type
)
2246 switch (type
->code ())
2251 return !TYPE_UNSIGNED (type
);
2252 case TYPE_CODE_RANGE
:
2253 return TYPE_LOW_BOUND (type
) - TYPE_RANGE_DATA (type
)->bias
< 0;
2257 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2258 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2259 the unpacked buffer.
2261 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2262 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2264 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2267 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2269 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2272 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2273 gdb_byte
*unpacked
, int unpacked_len
,
2274 int is_big_endian
, int is_signed_type
,
2277 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2278 int src_idx
; /* Index into the source area */
2279 int src_bytes_left
; /* Number of source bytes left to process. */
2280 int srcBitsLeft
; /* Number of source bits left to move */
2281 int unusedLS
; /* Number of bits in next significant
2282 byte of source that are unused */
2284 int unpacked_idx
; /* Index into the unpacked buffer */
2285 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2287 unsigned long accum
; /* Staging area for bits being transferred */
2288 int accumSize
; /* Number of meaningful bits in accum */
2291 /* Transmit bytes from least to most significant; delta is the direction
2292 the indices move. */
2293 int delta
= is_big_endian
? -1 : 1;
2295 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2297 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2298 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2299 bit_size
, unpacked_len
);
2301 srcBitsLeft
= bit_size
;
2302 src_bytes_left
= src_len
;
2303 unpacked_bytes_left
= unpacked_len
;
2308 src_idx
= src_len
- 1;
2310 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2314 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2320 unpacked_idx
= unpacked_len
- 1;
2324 /* Non-scalar values must be aligned at a byte boundary... */
2326 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2327 /* ... And are placed at the beginning (most-significant) bytes
2329 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2330 unpacked_bytes_left
= unpacked_idx
+ 1;
2335 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2337 src_idx
= unpacked_idx
= 0;
2338 unusedLS
= bit_offset
;
2341 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2346 while (src_bytes_left
> 0)
2348 /* Mask for removing bits of the next source byte that are not
2349 part of the value. */
2350 unsigned int unusedMSMask
=
2351 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2353 /* Sign-extend bits for this byte. */
2354 unsigned int signMask
= sign
& ~unusedMSMask
;
2357 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2358 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2359 if (accumSize
>= HOST_CHAR_BIT
)
2361 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2362 accumSize
-= HOST_CHAR_BIT
;
2363 accum
>>= HOST_CHAR_BIT
;
2364 unpacked_bytes_left
-= 1;
2365 unpacked_idx
+= delta
;
2367 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2369 src_bytes_left
-= 1;
2372 while (unpacked_bytes_left
> 0)
2374 accum
|= sign
<< accumSize
;
2375 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2376 accumSize
-= HOST_CHAR_BIT
;
2379 accum
>>= HOST_CHAR_BIT
;
2380 unpacked_bytes_left
-= 1;
2381 unpacked_idx
+= delta
;
2385 /* Create a new value of type TYPE from the contents of OBJ starting
2386 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2387 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2388 assigning through the result will set the field fetched from.
2389 VALADDR is ignored unless OBJ is NULL, in which case,
2390 VALADDR+OFFSET must address the start of storage containing the
2391 packed value. The value returned in this case is never an lval.
2392 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2395 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2396 long offset
, int bit_offset
, int bit_size
,
2400 const gdb_byte
*src
; /* First byte containing data to unpack */
2402 const int is_scalar
= is_scalar_type (type
);
2403 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2404 gdb::byte_vector staging
;
2406 type
= ada_check_typedef (type
);
2409 src
= valaddr
+ offset
;
2411 src
= value_contents (obj
) + offset
;
2413 if (is_dynamic_type (type
))
2415 /* The length of TYPE might by dynamic, so we need to resolve
2416 TYPE in order to know its actual size, which we then use
2417 to create the contents buffer of the value we return.
2418 The difficulty is that the data containing our object is
2419 packed, and therefore maybe not at a byte boundary. So, what
2420 we do, is unpack the data into a byte-aligned buffer, and then
2421 use that buffer as our object's value for resolving the type. */
2422 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2423 staging
.resize (staging_len
);
2425 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2426 staging
.data (), staging
.size (),
2427 is_big_endian
, has_negatives (type
),
2429 type
= resolve_dynamic_type (type
, staging
, 0);
2430 if (TYPE_LENGTH (type
) < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2432 /* This happens when the length of the object is dynamic,
2433 and is actually smaller than the space reserved for it.
2434 For instance, in an array of variant records, the bit_size
2435 we're given is the array stride, which is constant and
2436 normally equal to the maximum size of its element.
2437 But, in reality, each element only actually spans a portion
2439 bit_size
= TYPE_LENGTH (type
) * HOST_CHAR_BIT
;
2445 v
= allocate_value (type
);
2446 src
= valaddr
+ offset
;
2448 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2450 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2453 v
= value_at (type
, value_address (obj
) + offset
);
2454 buf
= (gdb_byte
*) alloca (src_len
);
2455 read_memory (value_address (v
), buf
, src_len
);
2460 v
= allocate_value (type
);
2461 src
= value_contents (obj
) + offset
;
2466 long new_offset
= offset
;
2468 set_value_component_location (v
, obj
);
2469 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2470 set_value_bitsize (v
, bit_size
);
2471 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2474 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2476 set_value_offset (v
, new_offset
);
2478 /* Also set the parent value. This is needed when trying to
2479 assign a new value (in inferior memory). */
2480 set_value_parent (v
, obj
);
2483 set_value_bitsize (v
, bit_size
);
2484 unpacked
= value_contents_writeable (v
);
2488 memset (unpacked
, 0, TYPE_LENGTH (type
));
2492 if (staging
.size () == TYPE_LENGTH (type
))
2494 /* Small short-cut: If we've unpacked the data into a buffer
2495 of the same size as TYPE's length, then we can reuse that,
2496 instead of doing the unpacking again. */
2497 memcpy (unpacked
, staging
.data (), staging
.size ());
2500 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2501 unpacked
, TYPE_LENGTH (type
),
2502 is_big_endian
, has_negatives (type
), is_scalar
);
2507 /* Store the contents of FROMVAL into the location of TOVAL.
2508 Return a new value with the location of TOVAL and contents of
2509 FROMVAL. Handles assignment into packed fields that have
2510 floating-point or non-scalar types. */
2512 static struct value
*
2513 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2515 struct type
*type
= value_type (toval
);
2516 int bits
= value_bitsize (toval
);
2518 toval
= ada_coerce_ref (toval
);
2519 fromval
= ada_coerce_ref (fromval
);
2521 if (ada_is_direct_array_type (value_type (toval
)))
2522 toval
= ada_coerce_to_simple_array (toval
);
2523 if (ada_is_direct_array_type (value_type (fromval
)))
2524 fromval
= ada_coerce_to_simple_array (fromval
);
2526 if (!deprecated_value_modifiable (toval
))
2527 error (_("Left operand of assignment is not a modifiable lvalue."));
2529 if (VALUE_LVAL (toval
) == lval_memory
2531 && (type
->code () == TYPE_CODE_FLT
2532 || type
->code () == TYPE_CODE_STRUCT
))
2534 int len
= (value_bitpos (toval
)
2535 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2537 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2539 CORE_ADDR to_addr
= value_address (toval
);
2541 if (type
->code () == TYPE_CODE_FLT
)
2542 fromval
= value_cast (type
, fromval
);
2544 read_memory (to_addr
, buffer
, len
);
2545 from_size
= value_bitsize (fromval
);
2547 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2549 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2550 ULONGEST from_offset
= 0;
2551 if (is_big_endian
&& is_scalar_type (value_type (fromval
)))
2552 from_offset
= from_size
- bits
;
2553 copy_bitwise (buffer
, value_bitpos (toval
),
2554 value_contents (fromval
), from_offset
,
2555 bits
, is_big_endian
);
2556 write_memory_with_notification (to_addr
, buffer
, len
);
2558 val
= value_copy (toval
);
2559 memcpy (value_contents_raw (val
), value_contents (fromval
),
2560 TYPE_LENGTH (type
));
2561 deprecated_set_value_type (val
, type
);
2566 return value_assign (toval
, fromval
);
2570 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2571 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2572 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2573 COMPONENT, and not the inferior's memory. The current contents
2574 of COMPONENT are ignored.
2576 Although not part of the initial design, this function also works
2577 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2578 had a null address, and COMPONENT had an address which is equal to
2579 its offset inside CONTAINER. */
2582 value_assign_to_component (struct value
*container
, struct value
*component
,
2585 LONGEST offset_in_container
=
2586 (LONGEST
) (value_address (component
) - value_address (container
));
2587 int bit_offset_in_container
=
2588 value_bitpos (component
) - value_bitpos (container
);
2591 val
= value_cast (value_type (component
), val
);
2593 if (value_bitsize (component
) == 0)
2594 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2596 bits
= value_bitsize (component
);
2598 if (type_byte_order (value_type (container
)) == BFD_ENDIAN_BIG
)
2602 if (is_scalar_type (check_typedef (value_type (component
))))
2604 = TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
;
2607 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2608 value_bitpos (container
) + bit_offset_in_container
,
2609 value_contents (val
), src_offset
, bits
, 1);
2612 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2613 value_bitpos (container
) + bit_offset_in_container
,
2614 value_contents (val
), 0, bits
, 0);
2617 /* Determine if TYPE is an access to an unconstrained array. */
2620 ada_is_access_to_unconstrained_array (struct type
*type
)
2622 return (type
->code () == TYPE_CODE_TYPEDEF
2623 && is_thick_pntr (ada_typedef_target_type (type
)));
2626 /* The value of the element of array ARR at the ARITY indices given in IND.
2627 ARR may be either a simple array, GNAT array descriptor, or pointer
2631 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2635 struct type
*elt_type
;
2637 elt
= ada_coerce_to_simple_array (arr
);
2639 elt_type
= ada_check_typedef (value_type (elt
));
2640 if (elt_type
->code () == TYPE_CODE_ARRAY
2641 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2642 return value_subscript_packed (elt
, arity
, ind
);
2644 for (k
= 0; k
< arity
; k
+= 1)
2646 struct type
*saved_elt_type
= TYPE_TARGET_TYPE (elt_type
);
2648 if (elt_type
->code () != TYPE_CODE_ARRAY
)
2649 error (_("too many subscripts (%d expected)"), k
);
2651 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2653 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
2654 && value_type (elt
)->code () != TYPE_CODE_TYPEDEF
)
2656 /* The element is a typedef to an unconstrained array,
2657 except that the value_subscript call stripped the
2658 typedef layer. The typedef layer is GNAT's way to
2659 specify that the element is, at the source level, an
2660 access to the unconstrained array, rather than the
2661 unconstrained array. So, we need to restore that
2662 typedef layer, which we can do by forcing the element's
2663 type back to its original type. Otherwise, the returned
2664 value is going to be printed as the array, rather
2665 than as an access. Another symptom of the same issue
2666 would be that an expression trying to dereference the
2667 element would also be improperly rejected. */
2668 deprecated_set_value_type (elt
, saved_elt_type
);
2671 elt_type
= ada_check_typedef (value_type (elt
));
2677 /* Assuming ARR is a pointer to a GDB array, the value of the element
2678 of *ARR at the ARITY indices given in IND.
2679 Does not read the entire array into memory.
2681 Note: Unlike what one would expect, this function is used instead of
2682 ada_value_subscript for basically all non-packed array types. The reason
2683 for this is that a side effect of doing our own pointer arithmetics instead
2684 of relying on value_subscript is that there is no implicit typedef peeling.
2685 This is important for arrays of array accesses, where it allows us to
2686 preserve the fact that the array's element is an array access, where the
2687 access part os encoded in a typedef layer. */
2689 static struct value
*
2690 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2693 struct value
*array_ind
= ada_value_ind (arr
);
2695 = check_typedef (value_enclosing_type (array_ind
));
2697 if (type
->code () == TYPE_CODE_ARRAY
2698 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
2699 return value_subscript_packed (array_ind
, arity
, ind
);
2701 for (k
= 0; k
< arity
; k
+= 1)
2705 if (type
->code () != TYPE_CODE_ARRAY
)
2706 error (_("too many subscripts (%d expected)"), k
);
2707 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2709 get_discrete_bounds (type
->index_type (), &lwb
, &upb
);
2710 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2711 type
= TYPE_TARGET_TYPE (type
);
2714 return value_ind (arr
);
2717 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2718 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2719 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2720 this array is LOW, as per Ada rules. */
2721 static struct value
*
2722 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2725 struct type
*type0
= ada_check_typedef (type
);
2726 struct type
*base_index_type
= TYPE_TARGET_TYPE (type0
->index_type ());
2727 struct type
*index_type
2728 = create_static_range_type (NULL
, base_index_type
, low
, high
);
2729 struct type
*slice_type
= create_array_type_with_stride
2730 (NULL
, TYPE_TARGET_TYPE (type0
), index_type
,
2731 type0
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2732 TYPE_FIELD_BITSIZE (type0
, 0));
2733 int base_low
= ada_discrete_type_low_bound (type0
->index_type ());
2734 LONGEST base_low_pos
, low_pos
;
2737 if (!discrete_position (base_index_type
, low
, &low_pos
)
2738 || !discrete_position (base_index_type
, base_low
, &base_low_pos
))
2740 warning (_("unable to get positions in slice, use bounds instead"));
2742 base_low_pos
= base_low
;
2745 base
= value_as_address (array_ptr
)
2746 + ((low_pos
- base_low_pos
)
2747 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0
)));
2748 return value_at_lazy (slice_type
, base
);
2752 static struct value
*
2753 ada_value_slice (struct value
*array
, int low
, int high
)
2755 struct type
*type
= ada_check_typedef (value_type (array
));
2756 struct type
*base_index_type
= TYPE_TARGET_TYPE (type
->index_type ());
2757 struct type
*index_type
2758 = create_static_range_type (NULL
, type
->index_type (), low
, high
);
2759 struct type
*slice_type
= create_array_type_with_stride
2760 (NULL
, TYPE_TARGET_TYPE (type
), index_type
,
2761 type
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2762 TYPE_FIELD_BITSIZE (type
, 0));
2763 LONGEST low_pos
, high_pos
;
2765 if (!discrete_position (base_index_type
, low
, &low_pos
)
2766 || !discrete_position (base_index_type
, high
, &high_pos
))
2768 warning (_("unable to get positions in slice, use bounds instead"));
2773 return value_cast (slice_type
,
2774 value_slice (array
, low
, high_pos
- low_pos
+ 1));
2777 /* If type is a record type in the form of a standard GNAT array
2778 descriptor, returns the number of dimensions for type. If arr is a
2779 simple array, returns the number of "array of"s that prefix its
2780 type designation. Otherwise, returns 0. */
2783 ada_array_arity (struct type
*type
)
2790 type
= desc_base_type (type
);
2793 if (type
->code () == TYPE_CODE_STRUCT
)
2794 return desc_arity (desc_bounds_type (type
));
2796 while (type
->code () == TYPE_CODE_ARRAY
)
2799 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2805 /* If TYPE is a record type in the form of a standard GNAT array
2806 descriptor or a simple array type, returns the element type for
2807 TYPE after indexing by NINDICES indices, or by all indices if
2808 NINDICES is -1. Otherwise, returns NULL. */
2811 ada_array_element_type (struct type
*type
, int nindices
)
2813 type
= desc_base_type (type
);
2815 if (type
->code () == TYPE_CODE_STRUCT
)
2818 struct type
*p_array_type
;
2820 p_array_type
= desc_data_target_type (type
);
2822 k
= ada_array_arity (type
);
2826 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2827 if (nindices
>= 0 && k
> nindices
)
2829 while (k
> 0 && p_array_type
!= NULL
)
2831 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2834 return p_array_type
;
2836 else if (type
->code () == TYPE_CODE_ARRAY
)
2838 while (nindices
!= 0 && type
->code () == TYPE_CODE_ARRAY
)
2840 type
= TYPE_TARGET_TYPE (type
);
2849 /* The type of nth index in arrays of given type (n numbering from 1).
2850 Does not examine memory. Throws an error if N is invalid or TYPE
2851 is not an array type. NAME is the name of the Ada attribute being
2852 evaluated ('range, 'first, 'last, or 'length); it is used in building
2853 the error message. */
2855 static struct type
*
2856 ada_index_type (struct type
*type
, int n
, const char *name
)
2858 struct type
*result_type
;
2860 type
= desc_base_type (type
);
2862 if (n
< 0 || n
> ada_array_arity (type
))
2863 error (_("invalid dimension number to '%s"), name
);
2865 if (ada_is_simple_array_type (type
))
2869 for (i
= 1; i
< n
; i
+= 1)
2870 type
= TYPE_TARGET_TYPE (type
);
2871 result_type
= TYPE_TARGET_TYPE (type
->index_type ());
2872 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2873 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2874 perhaps stabsread.c would make more sense. */
2875 if (result_type
&& result_type
->code () == TYPE_CODE_UNDEF
)
2880 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2881 if (result_type
== NULL
)
2882 error (_("attempt to take bound of something that is not an array"));
2888 /* Given that arr is an array type, returns the lower bound of the
2889 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2890 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2891 array-descriptor type. It works for other arrays with bounds supplied
2892 by run-time quantities other than discriminants. */
2895 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
2897 struct type
*type
, *index_type_desc
, *index_type
;
2900 gdb_assert (which
== 0 || which
== 1);
2902 if (ada_is_constrained_packed_array_type (arr_type
))
2903 arr_type
= decode_constrained_packed_array_type (arr_type
);
2905 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2906 return (LONGEST
) - which
;
2908 if (arr_type
->code () == TYPE_CODE_PTR
)
2909 type
= TYPE_TARGET_TYPE (arr_type
);
2913 if (TYPE_FIXED_INSTANCE (type
))
2915 /* The array has already been fixed, so we do not need to
2916 check the parallel ___XA type again. That encoding has
2917 already been applied, so ignore it now. */
2918 index_type_desc
= NULL
;
2922 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2923 ada_fixup_array_indexes_type (index_type_desc
);
2926 if (index_type_desc
!= NULL
)
2927 index_type
= to_fixed_range_type (index_type_desc
->field (n
- 1).type (),
2931 struct type
*elt_type
= check_typedef (type
);
2933 for (i
= 1; i
< n
; i
++)
2934 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
2936 index_type
= elt_type
->index_type ();
2940 (LONGEST
) (which
== 0
2941 ? ada_discrete_type_low_bound (index_type
)
2942 : ada_discrete_type_high_bound (index_type
));
2945 /* Given that arr is an array value, returns the lower bound of the
2946 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2947 WHICH is 1. This routine will also work for arrays with bounds
2948 supplied by run-time quantities other than discriminants. */
2951 ada_array_bound (struct value
*arr
, int n
, int which
)
2953 struct type
*arr_type
;
2955 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2956 arr
= value_ind (arr
);
2957 arr_type
= value_enclosing_type (arr
);
2959 if (ada_is_constrained_packed_array_type (arr_type
))
2960 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
2961 else if (ada_is_simple_array_type (arr_type
))
2962 return ada_array_bound_from_type (arr_type
, n
, which
);
2964 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
2967 /* Given that arr is an array value, returns the length of the
2968 nth index. This routine will also work for arrays with bounds
2969 supplied by run-time quantities other than discriminants.
2970 Does not work for arrays indexed by enumeration types with representation
2971 clauses at the moment. */
2974 ada_array_length (struct value
*arr
, int n
)
2976 struct type
*arr_type
, *index_type
;
2979 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2980 arr
= value_ind (arr
);
2981 arr_type
= value_enclosing_type (arr
);
2983 if (ada_is_constrained_packed_array_type (arr_type
))
2984 return ada_array_length (decode_constrained_packed_array (arr
), n
);
2986 if (ada_is_simple_array_type (arr_type
))
2988 low
= ada_array_bound_from_type (arr_type
, n
, 0);
2989 high
= ada_array_bound_from_type (arr_type
, n
, 1);
2993 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
2994 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
2997 arr_type
= check_typedef (arr_type
);
2998 index_type
= ada_index_type (arr_type
, n
, "length");
2999 if (index_type
!= NULL
)
3001 struct type
*base_type
;
3002 if (index_type
->code () == TYPE_CODE_RANGE
)
3003 base_type
= TYPE_TARGET_TYPE (index_type
);
3005 base_type
= index_type
;
3007 low
= pos_atr (value_from_longest (base_type
, low
));
3008 high
= pos_atr (value_from_longest (base_type
, high
));
3010 return high
- low
+ 1;
3013 /* An array whose type is that of ARR_TYPE (an array type), with
3014 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3015 less than LOW, then LOW-1 is used. */
3017 static struct value
*
3018 empty_array (struct type
*arr_type
, int low
, int high
)
3020 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3021 struct type
*index_type
3022 = create_static_range_type
3023 (NULL
, TYPE_TARGET_TYPE (arr_type0
->index_type ()), low
,
3024 high
< low
? low
- 1 : high
);
3025 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3027 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3031 /* Name resolution */
3033 /* The "decoded" name for the user-definable Ada operator corresponding
3037 ada_decoded_op_name (enum exp_opcode op
)
3041 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3043 if (ada_opname_table
[i
].op
== op
)
3044 return ada_opname_table
[i
].decoded
;
3046 error (_("Could not find operator name for opcode"));
3049 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3050 in a listing of choices during disambiguation (see sort_choices, below).
3051 The idea is that overloadings of a subprogram name from the
3052 same package should sort in their source order. We settle for ordering
3053 such symbols by their trailing number (__N or $N). */
3056 encoded_ordered_before (const char *N0
, const char *N1
)
3060 else if (N0
== NULL
)
3066 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3068 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3070 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3071 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3076 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3079 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3081 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3082 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3084 return (strcmp (N0
, N1
) < 0);
3088 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3092 sort_choices (struct block_symbol syms
[], int nsyms
)
3096 for (i
= 1; i
< nsyms
; i
+= 1)
3098 struct block_symbol sym
= syms
[i
];
3101 for (j
= i
- 1; j
>= 0; j
-= 1)
3103 if (encoded_ordered_before (syms
[j
].symbol
->linkage_name (),
3104 sym
.symbol
->linkage_name ()))
3106 syms
[j
+ 1] = syms
[j
];
3112 /* Whether GDB should display formals and return types for functions in the
3113 overloads selection menu. */
3114 static bool print_signatures
= true;
3116 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3117 all but functions, the signature is just the name of the symbol. For
3118 functions, this is the name of the function, the list of types for formals
3119 and the return type (if any). */
3122 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3123 const struct type_print_options
*flags
)
3125 struct type
*type
= SYMBOL_TYPE (sym
);
3127 fprintf_filtered (stream
, "%s", sym
->print_name ());
3128 if (!print_signatures
3130 || type
->code () != TYPE_CODE_FUNC
)
3133 if (type
->num_fields () > 0)
3137 fprintf_filtered (stream
, " (");
3138 for (i
= 0; i
< type
->num_fields (); ++i
)
3141 fprintf_filtered (stream
, "; ");
3142 ada_print_type (type
->field (i
).type (), NULL
, stream
, -1, 0,
3145 fprintf_filtered (stream
, ")");
3147 if (TYPE_TARGET_TYPE (type
) != NULL
3148 && TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_VOID
)
3150 fprintf_filtered (stream
, " return ");
3151 ada_print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, -1, 0, flags
);
3155 /* Read and validate a set of numeric choices from the user in the
3156 range 0 .. N_CHOICES-1. Place the results in increasing
3157 order in CHOICES[0 .. N-1], and return N.
3159 The user types choices as a sequence of numbers on one line
3160 separated by blanks, encoding them as follows:
3162 + A choice of 0 means to cancel the selection, throwing an error.
3163 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3164 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3166 The user is not allowed to choose more than MAX_RESULTS values.
3168 ANNOTATION_SUFFIX, if present, is used to annotate the input
3169 prompts (for use with the -f switch). */
3172 get_selections (int *choices
, int n_choices
, int max_results
,
3173 int is_all_choice
, const char *annotation_suffix
)
3178 int first_choice
= is_all_choice
? 2 : 1;
3180 prompt
= getenv ("PS2");
3184 args
= command_line_input (prompt
, annotation_suffix
);
3187 error_no_arg (_("one or more choice numbers"));
3191 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3192 order, as given in args. Choices are validated. */
3198 args
= skip_spaces (args
);
3199 if (*args
== '\0' && n_chosen
== 0)
3200 error_no_arg (_("one or more choice numbers"));
3201 else if (*args
== '\0')
3204 choice
= strtol (args
, &args2
, 10);
3205 if (args
== args2
|| choice
< 0
3206 || choice
> n_choices
+ first_choice
- 1)
3207 error (_("Argument must be choice number"));
3211 error (_("cancelled"));
3213 if (choice
< first_choice
)
3215 n_chosen
= n_choices
;
3216 for (j
= 0; j
< n_choices
; j
+= 1)
3220 choice
-= first_choice
;
3222 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3226 if (j
< 0 || choice
!= choices
[j
])
3230 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3231 choices
[k
+ 1] = choices
[k
];
3232 choices
[j
+ 1] = choice
;
3237 if (n_chosen
> max_results
)
3238 error (_("Select no more than %d of the above"), max_results
);
3243 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3244 by asking the user (if necessary), returning the number selected,
3245 and setting the first elements of SYMS items. Error if no symbols
3248 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3249 to be re-integrated one of these days. */
3252 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3255 int *chosen
= XALLOCAVEC (int , nsyms
);
3257 int first_choice
= (max_results
== 1) ? 1 : 2;
3258 const char *select_mode
= multiple_symbols_select_mode ();
3260 if (max_results
< 1)
3261 error (_("Request to select 0 symbols!"));
3265 if (select_mode
== multiple_symbols_cancel
)
3267 canceled because the command is ambiguous\n\
3268 See set/show multiple-symbol."));
3270 /* If select_mode is "all", then return all possible symbols.
3271 Only do that if more than one symbol can be selected, of course.
3272 Otherwise, display the menu as usual. */
3273 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3276 printf_filtered (_("[0] cancel\n"));
3277 if (max_results
> 1)
3278 printf_filtered (_("[1] all\n"));
3280 sort_choices (syms
, nsyms
);
3282 for (i
= 0; i
< nsyms
; i
+= 1)
3284 if (syms
[i
].symbol
== NULL
)
3287 if (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_BLOCK
)
3289 struct symtab_and_line sal
=
3290 find_function_start_sal (syms
[i
].symbol
, 1);
3292 printf_filtered ("[%d] ", i
+ first_choice
);
3293 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3294 &type_print_raw_options
);
3295 if (sal
.symtab
== NULL
)
3296 printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3297 metadata_style
.style ().ptr (), nullptr, sal
.line
);
3301 styled_string (file_name_style
.style (),
3302 symtab_to_filename_for_display (sal
.symtab
)),
3309 (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_CONST
3310 && SYMBOL_TYPE (syms
[i
].symbol
) != NULL
3311 && SYMBOL_TYPE (syms
[i
].symbol
)->code () == TYPE_CODE_ENUM
);
3312 struct symtab
*symtab
= NULL
;
3314 if (SYMBOL_OBJFILE_OWNED (syms
[i
].symbol
))
3315 symtab
= symbol_symtab (syms
[i
].symbol
);
3317 if (SYMBOL_LINE (syms
[i
].symbol
) != 0 && symtab
!= NULL
)
3319 printf_filtered ("[%d] ", i
+ first_choice
);
3320 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3321 &type_print_raw_options
);
3322 printf_filtered (_(" at %s:%d\n"),
3323 symtab_to_filename_for_display (symtab
),
3324 SYMBOL_LINE (syms
[i
].symbol
));
3326 else if (is_enumeral
3327 && SYMBOL_TYPE (syms
[i
].symbol
)->name () != NULL
)
3329 printf_filtered (("[%d] "), i
+ first_choice
);
3330 ada_print_type (SYMBOL_TYPE (syms
[i
].symbol
), NULL
,
3331 gdb_stdout
, -1, 0, &type_print_raw_options
);
3332 printf_filtered (_("'(%s) (enumeral)\n"),
3333 syms
[i
].symbol
->print_name ());
3337 printf_filtered ("[%d] ", i
+ first_choice
);
3338 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3339 &type_print_raw_options
);
3342 printf_filtered (is_enumeral
3343 ? _(" in %s (enumeral)\n")
3345 symtab_to_filename_for_display (symtab
));
3347 printf_filtered (is_enumeral
3348 ? _(" (enumeral)\n")
3354 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3357 for (i
= 0; i
< n_chosen
; i
+= 1)
3358 syms
[i
] = syms
[chosen
[i
]];
3363 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3364 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3365 undefined namespace) and converts operators that are
3366 user-defined into appropriate function calls. If CONTEXT_TYPE is
3367 non-null, it provides a preferred result type [at the moment, only
3368 type void has any effect---causing procedures to be preferred over
3369 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3370 return type is preferred. May change (expand) *EXP. */
3373 resolve (expression_up
*expp
, int void_context_p
, int parse_completion
,
3374 innermost_block_tracker
*tracker
)
3376 struct type
*context_type
= NULL
;
3380 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
3382 resolve_subexp (expp
, &pc
, 1, context_type
, parse_completion
, tracker
);
3385 /* Resolve the operator of the subexpression beginning at
3386 position *POS of *EXPP. "Resolving" consists of replacing
3387 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3388 with their resolutions, replacing built-in operators with
3389 function calls to user-defined operators, where appropriate, and,
3390 when DEPROCEDURE_P is non-zero, converting function-valued variables
3391 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3392 are as in ada_resolve, above. */
3394 static struct value
*
3395 resolve_subexp (expression_up
*expp
, int *pos
, int deprocedure_p
,
3396 struct type
*context_type
, int parse_completion
,
3397 innermost_block_tracker
*tracker
)
3401 struct expression
*exp
; /* Convenience: == *expp. */
3402 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3403 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3404 int nargs
; /* Number of operands. */
3411 /* Pass one: resolve operands, saving their types and updating *pos,
3416 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3417 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3422 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3424 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3429 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3434 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
),
3435 parse_completion
, tracker
);
3438 case OP_ATR_MODULUS
:
3448 case TERNOP_IN_RANGE
:
3449 case BINOP_IN_BOUNDS
:
3455 case OP_DISCRETE_RANGE
:
3457 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3466 arg1
= resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3468 resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
, tracker
);
3470 resolve_subexp (expp
, pos
, 1, value_type (arg1
), parse_completion
,
3488 case BINOP_LOGICAL_AND
:
3489 case BINOP_LOGICAL_OR
:
3490 case BINOP_BITWISE_AND
:
3491 case BINOP_BITWISE_IOR
:
3492 case BINOP_BITWISE_XOR
:
3495 case BINOP_NOTEQUAL
:
3502 case BINOP_SUBSCRIPT
:
3510 case UNOP_LOGICAL_NOT
:
3520 case OP_VAR_MSYM_VALUE
:
3527 case OP_INTERNALVAR
:
3537 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3540 case STRUCTOP_STRUCT
:
3541 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3554 error (_("Unexpected operator during name resolution"));
3557 argvec
= XALLOCAVEC (struct value
*, nargs
+ 1);
3558 for (i
= 0; i
< nargs
; i
+= 1)
3559 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
,
3564 /* Pass two: perform any resolution on principal operator. */
3571 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3573 std::vector
<struct block_symbol
> candidates
;
3577 ada_lookup_symbol_list (exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3578 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3581 if (n_candidates
> 1)
3583 /* Types tend to get re-introduced locally, so if there
3584 are any local symbols that are not types, first filter
3587 for (j
= 0; j
< n_candidates
; j
+= 1)
3588 switch (SYMBOL_CLASS (candidates
[j
].symbol
))
3593 case LOC_REGPARM_ADDR
:
3601 if (j
< n_candidates
)
3604 while (j
< n_candidates
)
3606 if (SYMBOL_CLASS (candidates
[j
].symbol
) == LOC_TYPEDEF
)
3608 candidates
[j
] = candidates
[n_candidates
- 1];
3617 if (n_candidates
== 0)
3618 error (_("No definition found for %s"),
3619 exp
->elts
[pc
+ 2].symbol
->print_name ());
3620 else if (n_candidates
== 1)
3622 else if (deprocedure_p
3623 && !is_nonfunction (candidates
.data (), n_candidates
))
3625 i
= ada_resolve_function
3626 (candidates
.data (), n_candidates
, NULL
, 0,
3627 exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3628 context_type
, parse_completion
);
3630 error (_("Could not find a match for %s"),
3631 exp
->elts
[pc
+ 2].symbol
->print_name ());
3635 printf_filtered (_("Multiple matches for %s\n"),
3636 exp
->elts
[pc
+ 2].symbol
->print_name ());
3637 user_select_syms (candidates
.data (), n_candidates
, 1);
3641 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3642 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].symbol
;
3643 tracker
->update (candidates
[i
]);
3647 && (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)->code ()
3650 replace_operator_with_call (expp
, pc
, 0, 4,
3651 exp
->elts
[pc
+ 2].symbol
,
3652 exp
->elts
[pc
+ 1].block
);
3659 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3660 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3662 std::vector
<struct block_symbol
> candidates
;
3666 ada_lookup_symbol_list (exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3667 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3670 if (n_candidates
== 1)
3674 i
= ada_resolve_function
3675 (candidates
.data (), n_candidates
,
3677 exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3678 context_type
, parse_completion
);
3680 error (_("Could not find a match for %s"),
3681 exp
->elts
[pc
+ 5].symbol
->print_name ());
3684 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3685 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].symbol
;
3686 tracker
->update (candidates
[i
]);
3697 case BINOP_BITWISE_AND
:
3698 case BINOP_BITWISE_IOR
:
3699 case BINOP_BITWISE_XOR
:
3701 case BINOP_NOTEQUAL
:
3709 case UNOP_LOGICAL_NOT
:
3711 if (possible_user_operator_p (op
, argvec
))
3713 std::vector
<struct block_symbol
> candidates
;
3717 ada_lookup_symbol_list (ada_decoded_op_name (op
),
3721 i
= ada_resolve_function (candidates
.data (), n_candidates
, argvec
,
3722 nargs
, ada_decoded_op_name (op
), NULL
,
3727 replace_operator_with_call (expp
, pc
, nargs
, 1,
3728 candidates
[i
].symbol
,
3729 candidates
[i
].block
);
3740 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
3741 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS
,
3742 exp
->elts
[pc
+ 1].objfile
,
3743 exp
->elts
[pc
+ 2].msymbol
);
3745 return evaluate_subexp_type (exp
, pos
);
3748 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3749 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3751 /* The term "match" here is rather loose. The match is heuristic and
3755 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3757 ftype
= ada_check_typedef (ftype
);
3758 atype
= ada_check_typedef (atype
);
3760 if (ftype
->code () == TYPE_CODE_REF
)
3761 ftype
= TYPE_TARGET_TYPE (ftype
);
3762 if (atype
->code () == TYPE_CODE_REF
)
3763 atype
= TYPE_TARGET_TYPE (atype
);
3765 switch (ftype
->code ())
3768 return ftype
->code () == atype
->code ();
3770 if (atype
->code () == TYPE_CODE_PTR
)
3771 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3772 TYPE_TARGET_TYPE (atype
), 0);
3775 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3777 case TYPE_CODE_ENUM
:
3778 case TYPE_CODE_RANGE
:
3779 switch (atype
->code ())
3782 case TYPE_CODE_ENUM
:
3783 case TYPE_CODE_RANGE
:
3789 case TYPE_CODE_ARRAY
:
3790 return (atype
->code () == TYPE_CODE_ARRAY
3791 || ada_is_array_descriptor_type (atype
));
3793 case TYPE_CODE_STRUCT
:
3794 if (ada_is_array_descriptor_type (ftype
))
3795 return (atype
->code () == TYPE_CODE_ARRAY
3796 || ada_is_array_descriptor_type (atype
));
3798 return (atype
->code () == TYPE_CODE_STRUCT
3799 && !ada_is_array_descriptor_type (atype
));
3801 case TYPE_CODE_UNION
:
3803 return (atype
->code () == ftype
->code ());
3807 /* Return non-zero if the formals of FUNC "sufficiently match" the
3808 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3809 may also be an enumeral, in which case it is treated as a 0-
3810 argument function. */
3813 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3816 struct type
*func_type
= SYMBOL_TYPE (func
);
3818 if (SYMBOL_CLASS (func
) == LOC_CONST
3819 && func_type
->code () == TYPE_CODE_ENUM
)
3820 return (n_actuals
== 0);
3821 else if (func_type
== NULL
|| func_type
->code () != TYPE_CODE_FUNC
)
3824 if (func_type
->num_fields () != n_actuals
)
3827 for (i
= 0; i
< n_actuals
; i
+= 1)
3829 if (actuals
[i
] == NULL
)
3833 struct type
*ftype
= ada_check_typedef (func_type
->field (i
).type ());
3834 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3836 if (!ada_type_match (ftype
, atype
, 1))
3843 /* False iff function type FUNC_TYPE definitely does not produce a value
3844 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3845 FUNC_TYPE is not a valid function type with a non-null return type
3846 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3849 return_match (struct type
*func_type
, struct type
*context_type
)
3851 struct type
*return_type
;
3853 if (func_type
== NULL
)
3856 if (func_type
->code () == TYPE_CODE_FUNC
)
3857 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3859 return_type
= get_base_type (func_type
);
3860 if (return_type
== NULL
)
3863 context_type
= get_base_type (context_type
);
3865 if (return_type
->code () == TYPE_CODE_ENUM
)
3866 return context_type
== NULL
|| return_type
== context_type
;
3867 else if (context_type
== NULL
)
3868 return return_type
->code () != TYPE_CODE_VOID
;
3870 return return_type
->code () == context_type
->code ();
3874 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3875 function (if any) that matches the types of the NARGS arguments in
3876 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3877 that returns that type, then eliminate matches that don't. If
3878 CONTEXT_TYPE is void and there is at least one match that does not
3879 return void, eliminate all matches that do.
3881 Asks the user if there is more than one match remaining. Returns -1
3882 if there is no such symbol or none is selected. NAME is used
3883 solely for messages. May re-arrange and modify SYMS in
3884 the process; the index returned is for the modified vector. */
3887 ada_resolve_function (struct block_symbol syms
[],
3888 int nsyms
, struct value
**args
, int nargs
,
3889 const char *name
, struct type
*context_type
,
3890 int parse_completion
)
3894 int m
; /* Number of hits */
3897 /* In the first pass of the loop, we only accept functions matching
3898 context_type. If none are found, we add a second pass of the loop
3899 where every function is accepted. */
3900 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3902 for (k
= 0; k
< nsyms
; k
+= 1)
3904 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].symbol
));
3906 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
3907 && (fallback
|| return_match (type
, context_type
)))
3915 /* If we got multiple matches, ask the user which one to use. Don't do this
3916 interactive thing during completion, though, as the purpose of the
3917 completion is providing a list of all possible matches. Prompting the
3918 user to filter it down would be completely unexpected in this case. */
3921 else if (m
> 1 && !parse_completion
)
3923 printf_filtered (_("Multiple matches for %s\n"), name
);
3924 user_select_syms (syms
, m
, 1);
3930 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3931 on the function identified by SYM and BLOCK, and taking NARGS
3932 arguments. Update *EXPP as needed to hold more space. */
3935 replace_operator_with_call (expression_up
*expp
, int pc
, int nargs
,
3936 int oplen
, struct symbol
*sym
,
3937 const struct block
*block
)
3939 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3940 symbol, -oplen for operator being replaced). */
3941 struct expression
*newexp
= (struct expression
*)
3942 xzalloc (sizeof (struct expression
)
3943 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3944 struct expression
*exp
= expp
->get ();
3946 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3947 newexp
->language_defn
= exp
->language_defn
;
3948 newexp
->gdbarch
= exp
->gdbarch
;
3949 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3950 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3951 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3953 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3954 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3956 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3957 newexp
->elts
[pc
+ 4].block
= block
;
3958 newexp
->elts
[pc
+ 5].symbol
= sym
;
3960 expp
->reset (newexp
);
3963 /* Type-class predicates */
3965 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3969 numeric_type_p (struct type
*type
)
3975 switch (type
->code ())
3980 case TYPE_CODE_RANGE
:
3981 return (type
== TYPE_TARGET_TYPE (type
)
3982 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3989 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3992 integer_type_p (struct type
*type
)
3998 switch (type
->code ())
4002 case TYPE_CODE_RANGE
:
4003 return (type
== TYPE_TARGET_TYPE (type
)
4004 || integer_type_p (TYPE_TARGET_TYPE (type
)));
4011 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4014 scalar_type_p (struct type
*type
)
4020 switch (type
->code ())
4023 case TYPE_CODE_RANGE
:
4024 case TYPE_CODE_ENUM
:
4033 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4036 discrete_type_p (struct type
*type
)
4042 switch (type
->code ())
4045 case TYPE_CODE_RANGE
:
4046 case TYPE_CODE_ENUM
:
4047 case TYPE_CODE_BOOL
:
4055 /* Returns non-zero if OP with operands in the vector ARGS could be
4056 a user-defined function. Errs on the side of pre-defined operators
4057 (i.e., result 0). */
4060 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4062 struct type
*type0
=
4063 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
4064 struct type
*type1
=
4065 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4079 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4083 case BINOP_BITWISE_AND
:
4084 case BINOP_BITWISE_IOR
:
4085 case BINOP_BITWISE_XOR
:
4086 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4089 case BINOP_NOTEQUAL
:
4094 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4097 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4100 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4104 case UNOP_LOGICAL_NOT
:
4106 return (!numeric_type_p (type0
));
4115 1. In the following, we assume that a renaming type's name may
4116 have an ___XD suffix. It would be nice if this went away at some
4118 2. We handle both the (old) purely type-based representation of
4119 renamings and the (new) variable-based encoding. At some point,
4120 it is devoutly to be hoped that the former goes away
4121 (FIXME: hilfinger-2007-07-09).
4122 3. Subprogram renamings are not implemented, although the XRS
4123 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4125 /* If SYM encodes a renaming,
4127 <renaming> renames <renamed entity>,
4129 sets *LEN to the length of the renamed entity's name,
4130 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4131 the string describing the subcomponent selected from the renamed
4132 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4133 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4134 are undefined). Otherwise, returns a value indicating the category
4135 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4136 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4137 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4138 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4139 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4140 may be NULL, in which case they are not assigned.
4142 [Currently, however, GCC does not generate subprogram renamings.] */
4144 enum ada_renaming_category
4145 ada_parse_renaming (struct symbol
*sym
,
4146 const char **renamed_entity
, int *len
,
4147 const char **renaming_expr
)
4149 enum ada_renaming_category kind
;
4154 return ADA_NOT_RENAMING
;
4155 switch (SYMBOL_CLASS (sym
))
4158 return ADA_NOT_RENAMING
;
4162 case LOC_OPTIMIZED_OUT
:
4163 info
= strstr (sym
->linkage_name (), "___XR");
4165 return ADA_NOT_RENAMING
;
4169 kind
= ADA_OBJECT_RENAMING
;
4173 kind
= ADA_EXCEPTION_RENAMING
;
4177 kind
= ADA_PACKAGE_RENAMING
;
4181 kind
= ADA_SUBPROGRAM_RENAMING
;
4185 return ADA_NOT_RENAMING
;
4189 if (renamed_entity
!= NULL
)
4190 *renamed_entity
= info
;
4191 suffix
= strstr (info
, "___XE");
4192 if (suffix
== NULL
|| suffix
== info
)
4193 return ADA_NOT_RENAMING
;
4195 *len
= strlen (info
) - strlen (suffix
);
4197 if (renaming_expr
!= NULL
)
4198 *renaming_expr
= suffix
;
4202 /* Compute the value of the given RENAMING_SYM, which is expected to
4203 be a symbol encoding a renaming expression. BLOCK is the block
4204 used to evaluate the renaming. */
4206 static struct value
*
4207 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4208 const struct block
*block
)
4210 const char *sym_name
;
4212 sym_name
= renaming_sym
->linkage_name ();
4213 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4214 return evaluate_expression (expr
.get ());
4218 /* Evaluation: Function Calls */
4220 /* Return an lvalue containing the value VAL. This is the identity on
4221 lvalues, and otherwise has the side-effect of allocating memory
4222 in the inferior where a copy of the value contents is copied. */
4224 static struct value
*
4225 ensure_lval (struct value
*val
)
4227 if (VALUE_LVAL (val
) == not_lval
4228 || VALUE_LVAL (val
) == lval_internalvar
)
4230 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4231 const CORE_ADDR addr
=
4232 value_as_long (value_allocate_space_in_inferior (len
));
4234 VALUE_LVAL (val
) = lval_memory
;
4235 set_value_address (val
, addr
);
4236 write_memory (addr
, value_contents (val
), len
);
4242 /* Given ARG, a value of type (pointer or reference to a)*
4243 structure/union, extract the component named NAME from the ultimate
4244 target structure/union and return it as a value with its
4247 The routine searches for NAME among all members of the structure itself
4248 and (recursively) among all members of any wrapper members
4251 If NO_ERR, then simply return NULL in case of error, rather than
4254 static struct value
*
4255 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
4257 struct type
*t
, *t1
;
4262 t1
= t
= ada_check_typedef (value_type (arg
));
4263 if (t
->code () == TYPE_CODE_REF
)
4265 t1
= TYPE_TARGET_TYPE (t
);
4268 t1
= ada_check_typedef (t1
);
4269 if (t1
->code () == TYPE_CODE_PTR
)
4271 arg
= coerce_ref (arg
);
4276 while (t
->code () == TYPE_CODE_PTR
)
4278 t1
= TYPE_TARGET_TYPE (t
);
4281 t1
= ada_check_typedef (t1
);
4282 if (t1
->code () == TYPE_CODE_PTR
)
4284 arg
= value_ind (arg
);
4291 if (t1
->code () != TYPE_CODE_STRUCT
&& t1
->code () != TYPE_CODE_UNION
)
4295 v
= ada_search_struct_field (name
, arg
, 0, t
);
4298 int bit_offset
, bit_size
, byte_offset
;
4299 struct type
*field_type
;
4302 if (t
->code () == TYPE_CODE_PTR
)
4303 address
= value_address (ada_value_ind (arg
));
4305 address
= value_address (ada_coerce_ref (arg
));
4307 /* Check to see if this is a tagged type. We also need to handle
4308 the case where the type is a reference to a tagged type, but
4309 we have to be careful to exclude pointers to tagged types.
4310 The latter should be shown as usual (as a pointer), whereas
4311 a reference should mostly be transparent to the user. */
4313 if (ada_is_tagged_type (t1
, 0)
4314 || (t1
->code () == TYPE_CODE_REF
4315 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1
), 0)))
4317 /* We first try to find the searched field in the current type.
4318 If not found then let's look in the fixed type. */
4320 if (!find_struct_field (name
, t1
, 0,
4321 &field_type
, &byte_offset
, &bit_offset
,
4330 /* Convert to fixed type in all cases, so that we have proper
4331 offsets to each field in unconstrained record types. */
4332 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
4333 address
, NULL
, check_tag
);
4335 if (find_struct_field (name
, t1
, 0,
4336 &field_type
, &byte_offset
, &bit_offset
,
4341 if (t
->code () == TYPE_CODE_REF
)
4342 arg
= ada_coerce_ref (arg
);
4344 arg
= ada_value_ind (arg
);
4345 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
4346 bit_offset
, bit_size
,
4350 v
= value_at_lazy (field_type
, address
+ byte_offset
);
4354 if (v
!= NULL
|| no_err
)
4357 error (_("There is no member named %s."), name
);
4363 error (_("Attempt to extract a component of "
4364 "a value that is not a record."));
4367 /* Return the value ACTUAL, converted to be an appropriate value for a
4368 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4369 allocating any necessary descriptors (fat pointers), or copies of
4370 values not residing in memory, updating it as needed. */
4373 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4375 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4376 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4377 struct type
*formal_target
=
4378 formal_type
->code () == TYPE_CODE_PTR
4379 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4380 struct type
*actual_target
=
4381 actual_type
->code () == TYPE_CODE_PTR
4382 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4384 if (ada_is_array_descriptor_type (formal_target
)
4385 && actual_target
->code () == TYPE_CODE_ARRAY
)
4386 return make_array_descriptor (formal_type
, actual
);
4387 else if (formal_type
->code () == TYPE_CODE_PTR
4388 || formal_type
->code () == TYPE_CODE_REF
)
4390 struct value
*result
;
4392 if (formal_target
->code () == TYPE_CODE_ARRAY
4393 && ada_is_array_descriptor_type (actual_target
))
4394 result
= desc_data (actual
);
4395 else if (formal_type
->code () != TYPE_CODE_PTR
)
4397 if (VALUE_LVAL (actual
) != lval_memory
)
4401 actual_type
= ada_check_typedef (value_type (actual
));
4402 val
= allocate_value (actual_type
);
4403 memcpy ((char *) value_contents_raw (val
),
4404 (char *) value_contents (actual
),
4405 TYPE_LENGTH (actual_type
));
4406 actual
= ensure_lval (val
);
4408 result
= value_addr (actual
);
4412 return value_cast_pointers (formal_type
, result
, 0);
4414 else if (actual_type
->code () == TYPE_CODE_PTR
)
4415 return ada_value_ind (actual
);
4416 else if (ada_is_aligner_type (formal_type
))
4418 /* We need to turn this parameter into an aligner type
4420 struct value
*aligner
= allocate_value (formal_type
);
4421 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4423 value_assign_to_component (aligner
, component
, actual
);
4430 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4431 type TYPE. This is usually an inefficient no-op except on some targets
4432 (such as AVR) where the representation of a pointer and an address
4436 value_pointer (struct value
*value
, struct type
*type
)
4438 struct gdbarch
*gdbarch
= get_type_arch (type
);
4439 unsigned len
= TYPE_LENGTH (type
);
4440 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4443 addr
= value_address (value
);
4444 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4445 addr
= extract_unsigned_integer (buf
, len
, type_byte_order (type
));
4450 /* Push a descriptor of type TYPE for array value ARR on the stack at
4451 *SP, updating *SP to reflect the new descriptor. Return either
4452 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4453 to-descriptor type rather than a descriptor type), a struct value *
4454 representing a pointer to this descriptor. */
4456 static struct value
*
4457 make_array_descriptor (struct type
*type
, struct value
*arr
)
4459 struct type
*bounds_type
= desc_bounds_type (type
);
4460 struct type
*desc_type
= desc_base_type (type
);
4461 struct value
*descriptor
= allocate_value (desc_type
);
4462 struct value
*bounds
= allocate_value (bounds_type
);
4465 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4468 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4469 ada_array_bound (arr
, i
, 0),
4470 desc_bound_bitpos (bounds_type
, i
, 0),
4471 desc_bound_bitsize (bounds_type
, i
, 0));
4472 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4473 ada_array_bound (arr
, i
, 1),
4474 desc_bound_bitpos (bounds_type
, i
, 1),
4475 desc_bound_bitsize (bounds_type
, i
, 1));
4478 bounds
= ensure_lval (bounds
);
4480 modify_field (value_type (descriptor
),
4481 value_contents_writeable (descriptor
),
4482 value_pointer (ensure_lval (arr
),
4483 desc_type
->field (0).type ()),
4484 fat_pntr_data_bitpos (desc_type
),
4485 fat_pntr_data_bitsize (desc_type
));
4487 modify_field (value_type (descriptor
),
4488 value_contents_writeable (descriptor
),
4489 value_pointer (bounds
,
4490 desc_type
->field (1).type ()),
4491 fat_pntr_bounds_bitpos (desc_type
),
4492 fat_pntr_bounds_bitsize (desc_type
));
4494 descriptor
= ensure_lval (descriptor
);
4496 if (type
->code () == TYPE_CODE_PTR
)
4497 return value_addr (descriptor
);
4502 /* Symbol Cache Module */
4504 /* Performance measurements made as of 2010-01-15 indicate that
4505 this cache does bring some noticeable improvements. Depending
4506 on the type of entity being printed, the cache can make it as much
4507 as an order of magnitude faster than without it.
4509 The descriptive type DWARF extension has significantly reduced
4510 the need for this cache, at least when DWARF is being used. However,
4511 even in this case, some expensive name-based symbol searches are still
4512 sometimes necessary - to find an XVZ variable, mostly. */
4514 /* Initialize the contents of SYM_CACHE. */
4517 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4519 obstack_init (&sym_cache
->cache_space
);
4520 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4523 /* Free the memory used by SYM_CACHE. */
4526 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4528 obstack_free (&sym_cache
->cache_space
, NULL
);
4532 /* Return the symbol cache associated to the given program space PSPACE.
4533 If not allocated for this PSPACE yet, allocate and initialize one. */
4535 static struct ada_symbol_cache
*
4536 ada_get_symbol_cache (struct program_space
*pspace
)
4538 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4540 if (pspace_data
->sym_cache
== NULL
)
4542 pspace_data
->sym_cache
= XCNEW (struct ada_symbol_cache
);
4543 ada_init_symbol_cache (pspace_data
->sym_cache
);
4546 return pspace_data
->sym_cache
;
4549 /* Clear all entries from the symbol cache. */
4552 ada_clear_symbol_cache (void)
4554 struct ada_symbol_cache
*sym_cache
4555 = ada_get_symbol_cache (current_program_space
);
4557 obstack_free (&sym_cache
->cache_space
, NULL
);
4558 ada_init_symbol_cache (sym_cache
);
4561 /* Search our cache for an entry matching NAME and DOMAIN.
4562 Return it if found, or NULL otherwise. */
4564 static struct cache_entry
**
4565 find_entry (const char *name
, domain_enum domain
)
4567 struct ada_symbol_cache
*sym_cache
4568 = ada_get_symbol_cache (current_program_space
);
4569 int h
= msymbol_hash (name
) % HASH_SIZE
;
4570 struct cache_entry
**e
;
4572 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4574 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4580 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4581 Return 1 if found, 0 otherwise.
4583 If an entry was found and SYM is not NULL, set *SYM to the entry's
4584 SYM. Same principle for BLOCK if not NULL. */
4587 lookup_cached_symbol (const char *name
, domain_enum domain
,
4588 struct symbol
**sym
, const struct block
**block
)
4590 struct cache_entry
**e
= find_entry (name
, domain
);
4597 *block
= (*e
)->block
;
4601 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4602 in domain DOMAIN, save this result in our symbol cache. */
4605 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4606 const struct block
*block
)
4608 struct ada_symbol_cache
*sym_cache
4609 = ada_get_symbol_cache (current_program_space
);
4611 struct cache_entry
*e
;
4613 /* Symbols for builtin types don't have a block.
4614 For now don't cache such symbols. */
4615 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4618 /* If the symbol is a local symbol, then do not cache it, as a search
4619 for that symbol depends on the context. To determine whether
4620 the symbol is local or not, we check the block where we found it
4621 against the global and static blocks of its associated symtab. */
4623 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4624 GLOBAL_BLOCK
) != block
4625 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4626 STATIC_BLOCK
) != block
)
4629 h
= msymbol_hash (name
) % HASH_SIZE
;
4630 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4631 e
->next
= sym_cache
->root
[h
];
4632 sym_cache
->root
[h
] = e
;
4633 e
->name
= obstack_strdup (&sym_cache
->cache_space
, name
);
4641 /* Return the symbol name match type that should be used used when
4642 searching for all symbols matching LOOKUP_NAME.
4644 LOOKUP_NAME is expected to be a symbol name after transformation
4647 static symbol_name_match_type
4648 name_match_type_from_name (const char *lookup_name
)
4650 return (strstr (lookup_name
, "__") == NULL
4651 ? symbol_name_match_type::WILD
4652 : symbol_name_match_type::FULL
);
4655 /* Return the result of a standard (literal, C-like) lookup of NAME in
4656 given DOMAIN, visible from lexical block BLOCK. */
4658 static struct symbol
*
4659 standard_lookup (const char *name
, const struct block
*block
,
4662 /* Initialize it just to avoid a GCC false warning. */
4663 struct block_symbol sym
= {};
4665 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4667 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4668 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4673 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4674 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4675 since they contend in overloading in the same way. */
4677 is_nonfunction (struct block_symbol syms
[], int n
)
4681 for (i
= 0; i
< n
; i
+= 1)
4682 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_FUNC
4683 && (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
4684 || SYMBOL_CLASS (syms
[i
].symbol
) != LOC_CONST
))
4690 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4691 struct types. Otherwise, they may not. */
4694 equiv_types (struct type
*type0
, struct type
*type1
)
4698 if (type0
== NULL
|| type1
== NULL
4699 || type0
->code () != type1
->code ())
4701 if ((type0
->code () == TYPE_CODE_STRUCT
4702 || type0
->code () == TYPE_CODE_ENUM
)
4703 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4704 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4710 /* True iff SYM0 represents the same entity as SYM1, or one that is
4711 no more defined than that of SYM1. */
4714 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4718 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4719 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4722 switch (SYMBOL_CLASS (sym0
))
4728 struct type
*type0
= SYMBOL_TYPE (sym0
);
4729 struct type
*type1
= SYMBOL_TYPE (sym1
);
4730 const char *name0
= sym0
->linkage_name ();
4731 const char *name1
= sym1
->linkage_name ();
4732 int len0
= strlen (name0
);
4735 type0
->code () == type1
->code ()
4736 && (equiv_types (type0
, type1
)
4737 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4738 && startswith (name1
+ len0
, "___XV")));
4741 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4742 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4746 const char *name0
= sym0
->linkage_name ();
4747 const char *name1
= sym1
->linkage_name ();
4748 return (strcmp (name0
, name1
) == 0
4749 && SYMBOL_VALUE_ADDRESS (sym0
) == SYMBOL_VALUE_ADDRESS (sym1
));
4757 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4758 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4761 add_defn_to_vec (struct obstack
*obstackp
,
4763 const struct block
*block
)
4766 struct block_symbol
*prevDefns
= defns_collected (obstackp
, 0);
4768 /* Do not try to complete stub types, as the debugger is probably
4769 already scanning all symbols matching a certain name at the
4770 time when this function is called. Trying to replace the stub
4771 type by its associated full type will cause us to restart a scan
4772 which may lead to an infinite recursion. Instead, the client
4773 collecting the matching symbols will end up collecting several
4774 matches, with at least one of them complete. It can then filter
4775 out the stub ones if needed. */
4777 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4779 if (lesseq_defined_than (sym
, prevDefns
[i
].symbol
))
4781 else if (lesseq_defined_than (prevDefns
[i
].symbol
, sym
))
4783 prevDefns
[i
].symbol
= sym
;
4784 prevDefns
[i
].block
= block
;
4790 struct block_symbol info
;
4794 obstack_grow (obstackp
, &info
, sizeof (struct block_symbol
));
4798 /* Number of block_symbol structures currently collected in current vector in
4802 num_defns_collected (struct obstack
*obstackp
)
4804 return obstack_object_size (obstackp
) / sizeof (struct block_symbol
);
4807 /* Vector of block_symbol structures currently collected in current vector in
4808 OBSTACKP. If FINISH, close off the vector and return its final address. */
4810 static struct block_symbol
*
4811 defns_collected (struct obstack
*obstackp
, int finish
)
4814 return (struct block_symbol
*) obstack_finish (obstackp
);
4816 return (struct block_symbol
*) obstack_base (obstackp
);
4819 /* Return a bound minimal symbol matching NAME according to Ada
4820 decoding rules. Returns an invalid symbol if there is no such
4821 minimal symbol. Names prefixed with "standard__" are handled
4822 specially: "standard__" is first stripped off, and only static and
4823 global symbols are searched. */
4825 struct bound_minimal_symbol
4826 ada_lookup_simple_minsym (const char *name
)
4828 struct bound_minimal_symbol result
;
4830 memset (&result
, 0, sizeof (result
));
4832 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4833 lookup_name_info
lookup_name (name
, match_type
);
4835 symbol_name_matcher_ftype
*match_name
4836 = ada_get_symbol_name_matcher (lookup_name
);
4838 for (objfile
*objfile
: current_program_space
->objfiles ())
4840 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4842 if (match_name (msymbol
->linkage_name (), lookup_name
, NULL
)
4843 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4845 result
.minsym
= msymbol
;
4846 result
.objfile
= objfile
;
4855 /* For all subprograms that statically enclose the subprogram of the
4856 selected frame, add symbols matching identifier NAME in DOMAIN
4857 and their blocks to the list of data in OBSTACKP, as for
4858 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4859 with a wildcard prefix. */
4862 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4863 const lookup_name_info
&lookup_name
,
4868 /* True if TYPE is definitely an artificial type supplied to a symbol
4869 for which no debugging information was given in the symbol file. */
4872 is_nondebugging_type (struct type
*type
)
4874 const char *name
= ada_type_name (type
);
4876 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4879 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4880 that are deemed "identical" for practical purposes.
4882 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4883 types and that their number of enumerals is identical (in other
4884 words, type1->num_fields () == type2->num_fields ()). */
4887 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4891 /* The heuristic we use here is fairly conservative. We consider
4892 that 2 enumerate types are identical if they have the same
4893 number of enumerals and that all enumerals have the same
4894 underlying value and name. */
4896 /* All enums in the type should have an identical underlying value. */
4897 for (i
= 0; i
< type1
->num_fields (); i
++)
4898 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4901 /* All enumerals should also have the same name (modulo any numerical
4903 for (i
= 0; i
< type1
->num_fields (); i
++)
4905 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4906 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4907 int len_1
= strlen (name_1
);
4908 int len_2
= strlen (name_2
);
4910 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4911 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4913 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4914 TYPE_FIELD_NAME (type2
, i
),
4922 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4923 that are deemed "identical" for practical purposes. Sometimes,
4924 enumerals are not strictly identical, but their types are so similar
4925 that they can be considered identical.
4927 For instance, consider the following code:
4929 type Color is (Black, Red, Green, Blue, White);
4930 type RGB_Color is new Color range Red .. Blue;
4932 Type RGB_Color is a subrange of an implicit type which is a copy
4933 of type Color. If we call that implicit type RGB_ColorB ("B" is
4934 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4935 As a result, when an expression references any of the enumeral
4936 by name (Eg. "print green"), the expression is technically
4937 ambiguous and the user should be asked to disambiguate. But
4938 doing so would only hinder the user, since it wouldn't matter
4939 what choice he makes, the outcome would always be the same.
4940 So, for practical purposes, we consider them as the same. */
4943 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
4947 /* Before performing a thorough comparison check of each type,
4948 we perform a series of inexpensive checks. We expect that these
4949 checks will quickly fail in the vast majority of cases, and thus
4950 help prevent the unnecessary use of a more expensive comparison.
4951 Said comparison also expects us to make some of these checks
4952 (see ada_identical_enum_types_p). */
4954 /* Quick check: All symbols should have an enum type. */
4955 for (i
= 0; i
< syms
.size (); i
++)
4956 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
)
4959 /* Quick check: They should all have the same value. */
4960 for (i
= 1; i
< syms
.size (); i
++)
4961 if (SYMBOL_VALUE (syms
[i
].symbol
) != SYMBOL_VALUE (syms
[0].symbol
))
4964 /* Quick check: They should all have the same number of enumerals. */
4965 for (i
= 1; i
< syms
.size (); i
++)
4966 if (SYMBOL_TYPE (syms
[i
].symbol
)->num_fields ()
4967 != SYMBOL_TYPE (syms
[0].symbol
)->num_fields ())
4970 /* All the sanity checks passed, so we might have a set of
4971 identical enumeration types. Perform a more complete
4972 comparison of the type of each symbol. */
4973 for (i
= 1; i
< syms
.size (); i
++)
4974 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].symbol
),
4975 SYMBOL_TYPE (syms
[0].symbol
)))
4981 /* Remove any non-debugging symbols in SYMS that definitely
4982 duplicate other symbols in the list (The only case I know of where
4983 this happens is when object files containing stabs-in-ecoff are
4984 linked with files containing ordinary ecoff debugging symbols (or no
4985 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4986 Returns the number of items in the modified list. */
4989 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
4993 /* We should never be called with less than 2 symbols, as there
4994 cannot be any extra symbol in that case. But it's easy to
4995 handle, since we have nothing to do in that case. */
4996 if (syms
->size () < 2)
4997 return syms
->size ();
5000 while (i
< syms
->size ())
5004 /* If two symbols have the same name and one of them is a stub type,
5005 the get rid of the stub. */
5007 if (TYPE_STUB (SYMBOL_TYPE ((*syms
)[i
].symbol
))
5008 && (*syms
)[i
].symbol
->linkage_name () != NULL
)
5010 for (j
= 0; j
< syms
->size (); j
++)
5013 && !TYPE_STUB (SYMBOL_TYPE ((*syms
)[j
].symbol
))
5014 && (*syms
)[j
].symbol
->linkage_name () != NULL
5015 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5016 (*syms
)[j
].symbol
->linkage_name ()) == 0)
5021 /* Two symbols with the same name, same class and same address
5022 should be identical. */
5024 else if ((*syms
)[i
].symbol
->linkage_name () != NULL
5025 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5026 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5028 for (j
= 0; j
< syms
->size (); j
+= 1)
5031 && (*syms
)[j
].symbol
->linkage_name () != NULL
5032 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5033 (*syms
)[j
].symbol
->linkage_name ()) == 0
5034 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5035 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5036 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5037 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5043 syms
->erase (syms
->begin () + i
);
5048 /* If all the remaining symbols are identical enumerals, then
5049 just keep the first one and discard the rest.
5051 Unlike what we did previously, we do not discard any entry
5052 unless they are ALL identical. This is because the symbol
5053 comparison is not a strict comparison, but rather a practical
5054 comparison. If all symbols are considered identical, then
5055 we can just go ahead and use the first one and discard the rest.
5056 But if we cannot reduce the list to a single element, we have
5057 to ask the user to disambiguate anyways. And if we have to
5058 present a multiple-choice menu, it's less confusing if the list
5059 isn't missing some choices that were identical and yet distinct. */
5060 if (symbols_are_identical_enums (*syms
))
5063 return syms
->size ();
5066 /* Given a type that corresponds to a renaming entity, use the type name
5067 to extract the scope (package name or function name, fully qualified,
5068 and following the GNAT encoding convention) where this renaming has been
5072 xget_renaming_scope (struct type
*renaming_type
)
5074 /* The renaming types adhere to the following convention:
5075 <scope>__<rename>___<XR extension>.
5076 So, to extract the scope, we search for the "___XR" extension,
5077 and then backtrack until we find the first "__". */
5079 const char *name
= renaming_type
->name ();
5080 const char *suffix
= strstr (name
, "___XR");
5083 /* Now, backtrack a bit until we find the first "__". Start looking
5084 at suffix - 3, as the <rename> part is at least one character long. */
5086 for (last
= suffix
- 3; last
> name
; last
--)
5087 if (last
[0] == '_' && last
[1] == '_')
5090 /* Make a copy of scope and return it. */
5091 return std::string (name
, last
);
5094 /* Return nonzero if NAME corresponds to a package name. */
5097 is_package_name (const char *name
)
5099 /* Here, We take advantage of the fact that no symbols are generated
5100 for packages, while symbols are generated for each function.
5101 So the condition for NAME represent a package becomes equivalent
5102 to NAME not existing in our list of symbols. There is only one
5103 small complication with library-level functions (see below). */
5105 /* If it is a function that has not been defined at library level,
5106 then we should be able to look it up in the symbols. */
5107 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5110 /* Library-level function names start with "_ada_". See if function
5111 "_ada_" followed by NAME can be found. */
5113 /* Do a quick check that NAME does not contain "__", since library-level
5114 functions names cannot contain "__" in them. */
5115 if (strstr (name
, "__") != NULL
)
5118 std::string fun_name
= string_printf ("_ada_%s", name
);
5120 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5123 /* Return nonzero if SYM corresponds to a renaming entity that is
5124 not visible from FUNCTION_NAME. */
5127 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5129 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5132 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5134 /* If the rename has been defined in a package, then it is visible. */
5135 if (is_package_name (scope
.c_str ()))
5138 /* Check that the rename is in the current function scope by checking
5139 that its name starts with SCOPE. */
5141 /* If the function name starts with "_ada_", it means that it is
5142 a library-level function. Strip this prefix before doing the
5143 comparison, as the encoding for the renaming does not contain
5145 if (startswith (function_name
, "_ada_"))
5148 return !startswith (function_name
, scope
.c_str ());
5151 /* Remove entries from SYMS that corresponds to a renaming entity that
5152 is not visible from the function associated with CURRENT_BLOCK or
5153 that is superfluous due to the presence of more specific renaming
5154 information. Places surviving symbols in the initial entries of
5155 SYMS and returns the number of surviving symbols.
5158 First, in cases where an object renaming is implemented as a
5159 reference variable, GNAT may produce both the actual reference
5160 variable and the renaming encoding. In this case, we discard the
5163 Second, GNAT emits a type following a specified encoding for each renaming
5164 entity. Unfortunately, STABS currently does not support the definition
5165 of types that are local to a given lexical block, so all renamings types
5166 are emitted at library level. As a consequence, if an application
5167 contains two renaming entities using the same name, and a user tries to
5168 print the value of one of these entities, the result of the ada symbol
5169 lookup will also contain the wrong renaming type.
5171 This function partially covers for this limitation by attempting to
5172 remove from the SYMS list renaming symbols that should be visible
5173 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5174 method with the current information available. The implementation
5175 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5177 - When the user tries to print a rename in a function while there
5178 is another rename entity defined in a package: Normally, the
5179 rename in the function has precedence over the rename in the
5180 package, so the latter should be removed from the list. This is
5181 currently not the case.
5183 - This function will incorrectly remove valid renames if
5184 the CURRENT_BLOCK corresponds to a function which symbol name
5185 has been changed by an "Export" pragma. As a consequence,
5186 the user will be unable to print such rename entities. */
5189 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5190 const struct block
*current_block
)
5192 struct symbol
*current_function
;
5193 const char *current_function_name
;
5195 int is_new_style_renaming
;
5197 /* If there is both a renaming foo___XR... encoded as a variable and
5198 a simple variable foo in the same block, discard the latter.
5199 First, zero out such symbols, then compress. */
5200 is_new_style_renaming
= 0;
5201 for (i
= 0; i
< syms
->size (); i
+= 1)
5203 struct symbol
*sym
= (*syms
)[i
].symbol
;
5204 const struct block
*block
= (*syms
)[i
].block
;
5208 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5210 name
= sym
->linkage_name ();
5211 suffix
= strstr (name
, "___XR");
5215 int name_len
= suffix
- name
;
5218 is_new_style_renaming
= 1;
5219 for (j
= 0; j
< syms
->size (); j
+= 1)
5220 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5221 && strncmp (name
, (*syms
)[j
].symbol
->linkage_name (),
5223 && block
== (*syms
)[j
].block
)
5224 (*syms
)[j
].symbol
= NULL
;
5227 if (is_new_style_renaming
)
5231 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5232 if ((*syms
)[j
].symbol
!= NULL
)
5234 (*syms
)[k
] = (*syms
)[j
];
5240 /* Extract the function name associated to CURRENT_BLOCK.
5241 Abort if unable to do so. */
5243 if (current_block
== NULL
)
5244 return syms
->size ();
5246 current_function
= block_linkage_function (current_block
);
5247 if (current_function
== NULL
)
5248 return syms
->size ();
5250 current_function_name
= current_function
->linkage_name ();
5251 if (current_function_name
== NULL
)
5252 return syms
->size ();
5254 /* Check each of the symbols, and remove it from the list if it is
5255 a type corresponding to a renaming that is out of the scope of
5256 the current block. */
5259 while (i
< syms
->size ())
5261 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5262 == ADA_OBJECT_RENAMING
5263 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5264 current_function_name
))
5265 syms
->erase (syms
->begin () + i
);
5270 return syms
->size ();
5273 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5274 whose name and domain match NAME and DOMAIN respectively.
5275 If no match was found, then extend the search to "enclosing"
5276 routines (in other words, if we're inside a nested function,
5277 search the symbols defined inside the enclosing functions).
5278 If WILD_MATCH_P is nonzero, perform the naming matching in
5279 "wild" mode (see function "wild_match" for more info).
5281 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5284 ada_add_local_symbols (struct obstack
*obstackp
,
5285 const lookup_name_info
&lookup_name
,
5286 const struct block
*block
, domain_enum domain
)
5288 int block_depth
= 0;
5290 while (block
!= NULL
)
5293 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5295 /* If we found a non-function match, assume that's the one. */
5296 if (is_nonfunction (defns_collected (obstackp
, 0),
5297 num_defns_collected (obstackp
)))
5300 block
= BLOCK_SUPERBLOCK (block
);
5303 /* If no luck so far, try to find NAME as a local symbol in some lexically
5304 enclosing subprogram. */
5305 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5306 add_symbols_from_enclosing_procs (obstackp
, lookup_name
, domain
);
5309 /* An object of this type is used as the user_data argument when
5310 calling the map_matching_symbols method. */
5314 struct objfile
*objfile
;
5315 struct obstack
*obstackp
;
5316 struct symbol
*arg_sym
;
5320 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
5321 to a list of symbols. DATA is a pointer to a struct match_data *
5322 containing the obstack that collects the symbol list, the file that SYM
5323 must come from, a flag indicating whether a non-argument symbol has
5324 been found in the current block, and the last argument symbol
5325 passed in SYM within the current block (if any). When SYM is null,
5326 marking the end of a block, the argument symbol is added if no
5327 other has been found. */
5330 aux_add_nonlocal_symbols (struct block_symbol
*bsym
,
5331 struct match_data
*data
)
5333 const struct block
*block
= bsym
->block
;
5334 struct symbol
*sym
= bsym
->symbol
;
5338 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5339 add_defn_to_vec (data
->obstackp
,
5340 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5342 data
->found_sym
= 0;
5343 data
->arg_sym
= NULL
;
5347 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5349 else if (SYMBOL_IS_ARGUMENT (sym
))
5350 data
->arg_sym
= sym
;
5353 data
->found_sym
= 1;
5354 add_defn_to_vec (data
->obstackp
,
5355 fixup_symbol_section (sym
, data
->objfile
),
5362 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5363 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5364 symbols to OBSTACKP. Return whether we found such symbols. */
5367 ada_add_block_renamings (struct obstack
*obstackp
,
5368 const struct block
*block
,
5369 const lookup_name_info
&lookup_name
,
5372 struct using_direct
*renaming
;
5373 int defns_mark
= num_defns_collected (obstackp
);
5375 symbol_name_matcher_ftype
*name_match
5376 = ada_get_symbol_name_matcher (lookup_name
);
5378 for (renaming
= block_using (block
);
5380 renaming
= renaming
->next
)
5384 /* Avoid infinite recursions: skip this renaming if we are actually
5385 already traversing it.
5387 Currently, symbol lookup in Ada don't use the namespace machinery from
5388 C++/Fortran support: skip namespace imports that use them. */
5389 if (renaming
->searched
5390 || (renaming
->import_src
!= NULL
5391 && renaming
->import_src
[0] != '\0')
5392 || (renaming
->import_dest
!= NULL
5393 && renaming
->import_dest
[0] != '\0'))
5395 renaming
->searched
= 1;
5397 /* TODO: here, we perform another name-based symbol lookup, which can
5398 pull its own multiple overloads. In theory, we should be able to do
5399 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5400 not a simple name. But in order to do this, we would need to enhance
5401 the DWARF reader to associate a symbol to this renaming, instead of a
5402 name. So, for now, we do something simpler: re-use the C++/Fortran
5403 namespace machinery. */
5404 r_name
= (renaming
->alias
!= NULL
5406 : renaming
->declaration
);
5407 if (name_match (r_name
, lookup_name
, NULL
))
5409 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5410 lookup_name
.match_type ());
5411 ada_add_all_symbols (obstackp
, block
, decl_lookup_name
, domain
,
5414 renaming
->searched
= 0;
5416 return num_defns_collected (obstackp
) != defns_mark
;
5419 /* Implements compare_names, but only applying the comparision using
5420 the given CASING. */
5423 compare_names_with_case (const char *string1
, const char *string2
,
5424 enum case_sensitivity casing
)
5426 while (*string1
!= '\0' && *string2
!= '\0')
5430 if (isspace (*string1
) || isspace (*string2
))
5431 return strcmp_iw_ordered (string1
, string2
);
5433 if (casing
== case_sensitive_off
)
5435 c1
= tolower (*string1
);
5436 c2
= tolower (*string2
);
5453 return strcmp_iw_ordered (string1
, string2
);
5455 if (*string2
== '\0')
5457 if (is_name_suffix (string1
))
5464 if (*string2
== '(')
5465 return strcmp_iw_ordered (string1
, string2
);
5468 if (casing
== case_sensitive_off
)
5469 return tolower (*string1
) - tolower (*string2
);
5471 return *string1
- *string2
;
5476 /* Compare STRING1 to STRING2, with results as for strcmp.
5477 Compatible with strcmp_iw_ordered in that...
5479 strcmp_iw_ordered (STRING1, STRING2) <= 0
5483 compare_names (STRING1, STRING2) <= 0
5485 (they may differ as to what symbols compare equal). */
5488 compare_names (const char *string1
, const char *string2
)
5492 /* Similar to what strcmp_iw_ordered does, we need to perform
5493 a case-insensitive comparison first, and only resort to
5494 a second, case-sensitive, comparison if the first one was
5495 not sufficient to differentiate the two strings. */
5497 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5499 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5504 /* Convenience function to get at the Ada encoded lookup name for
5505 LOOKUP_NAME, as a C string. */
5508 ada_lookup_name (const lookup_name_info
&lookup_name
)
5510 return lookup_name
.ada ().lookup_name ().c_str ();
5513 /* Add to OBSTACKP all non-local symbols whose name and domain match
5514 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5515 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5516 symbols otherwise. */
5519 add_nonlocal_symbols (struct obstack
*obstackp
,
5520 const lookup_name_info
&lookup_name
,
5521 domain_enum domain
, int global
)
5523 struct match_data data
;
5525 memset (&data
, 0, sizeof data
);
5526 data
.obstackp
= obstackp
;
5528 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5530 auto callback
= [&] (struct block_symbol
*bsym
)
5532 return aux_add_nonlocal_symbols (bsym
, &data
);
5535 for (objfile
*objfile
: current_program_space
->objfiles ())
5537 data
.objfile
= objfile
;
5539 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
,
5540 domain
, global
, callback
,
5542 ? NULL
: compare_names
));
5544 for (compunit_symtab
*cu
: objfile
->compunits ())
5546 const struct block
*global_block
5547 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5549 if (ada_add_block_renamings (obstackp
, global_block
, lookup_name
,
5555 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
5557 const char *name
= ada_lookup_name (lookup_name
);
5558 std::string bracket_name
= std::string ("<_ada_") + name
+ '>';
5559 lookup_name_info
name1 (bracket_name
, symbol_name_match_type::FULL
);
5561 for (objfile
*objfile
: current_program_space
->objfiles ())
5563 data
.objfile
= objfile
;
5564 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
,
5565 domain
, global
, callback
,
5571 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5572 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5573 returning the number of matches. Add these to OBSTACKP.
5575 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5576 symbol match within the nest of blocks whose innermost member is BLOCK,
5577 is the one match returned (no other matches in that or
5578 enclosing blocks is returned). If there are any matches in or
5579 surrounding BLOCK, then these alone are returned.
5581 Names prefixed with "standard__" are handled specially:
5582 "standard__" is first stripped off (by the lookup_name
5583 constructor), and only static and global symbols are searched.
5585 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5586 to lookup global symbols. */
5589 ada_add_all_symbols (struct obstack
*obstackp
,
5590 const struct block
*block
,
5591 const lookup_name_info
&lookup_name
,
5594 int *made_global_lookup_p
)
5598 if (made_global_lookup_p
)
5599 *made_global_lookup_p
= 0;
5601 /* Special case: If the user specifies a symbol name inside package
5602 Standard, do a non-wild matching of the symbol name without
5603 the "standard__" prefix. This was primarily introduced in order
5604 to allow the user to specifically access the standard exceptions
5605 using, for instance, Standard.Constraint_Error when Constraint_Error
5606 is ambiguous (due to the user defining its own Constraint_Error
5607 entity inside its program). */
5608 if (lookup_name
.ada ().standard_p ())
5611 /* Check the non-global symbols. If we have ANY match, then we're done. */
5616 ada_add_local_symbols (obstackp
, lookup_name
, block
, domain
);
5619 /* In the !full_search case we're are being called by
5620 iterate_over_symbols, and we don't want to search
5622 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5624 if (num_defns_collected (obstackp
) > 0 || !full_search
)
5628 /* No non-global symbols found. Check our cache to see if we have
5629 already performed this search before. If we have, then return
5632 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5633 domain
, &sym
, &block
))
5636 add_defn_to_vec (obstackp
, sym
, block
);
5640 if (made_global_lookup_p
)
5641 *made_global_lookup_p
= 1;
5643 /* Search symbols from all global blocks. */
5645 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 1);
5647 /* Now add symbols from all per-file blocks if we've gotten no hits
5648 (not strictly correct, but perhaps better than an error). */
5650 if (num_defns_collected (obstackp
) == 0)
5651 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 0);
5654 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5655 is non-zero, enclosing scope and in global scopes, returning the number of
5657 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5658 found and the blocks and symbol tables (if any) in which they were
5661 When full_search is non-zero, any non-function/non-enumeral
5662 symbol match within the nest of blocks whose innermost member is BLOCK,
5663 is the one match returned (no other matches in that or
5664 enclosing blocks is returned). If there are any matches in or
5665 surrounding BLOCK, then these alone are returned.
5667 Names prefixed with "standard__" are handled specially: "standard__"
5668 is first stripped off, and only static and global symbols are searched. */
5671 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5672 const struct block
*block
,
5674 std::vector
<struct block_symbol
> *results
,
5677 int syms_from_global_search
;
5679 auto_obstack obstack
;
5681 ada_add_all_symbols (&obstack
, block
, lookup_name
,
5682 domain
, full_search
, &syms_from_global_search
);
5684 ndefns
= num_defns_collected (&obstack
);
5686 struct block_symbol
*base
= defns_collected (&obstack
, 1);
5687 for (int i
= 0; i
< ndefns
; ++i
)
5688 results
->push_back (base
[i
]);
5690 ndefns
= remove_extra_symbols (results
);
5692 if (ndefns
== 0 && full_search
&& syms_from_global_search
)
5693 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5695 if (ndefns
== 1 && full_search
&& syms_from_global_search
)
5696 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5697 (*results
)[0].symbol
, (*results
)[0].block
);
5699 ndefns
= remove_irrelevant_renamings (results
, block
);
5704 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5705 in global scopes, returning the number of matches, and filling *RESULTS
5706 with (SYM,BLOCK) tuples.
5708 See ada_lookup_symbol_list_worker for further details. */
5711 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5713 std::vector
<struct block_symbol
> *results
)
5715 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5716 lookup_name_info
lookup_name (name
, name_match_type
);
5718 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, results
, 1);
5721 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5722 to 1, but choosing the first symbol found if there are multiple
5725 The result is stored in *INFO, which must be non-NULL.
5726 If no match is found, INFO->SYM is set to NULL. */
5729 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5731 struct block_symbol
*info
)
5733 /* Since we already have an encoded name, wrap it in '<>' to force a
5734 verbatim match. Otherwise, if the name happens to not look like
5735 an encoded name (because it doesn't include a "__"),
5736 ada_lookup_name_info would re-encode/fold it again, and that
5737 would e.g., incorrectly lowercase object renaming names like
5738 "R28b" -> "r28b". */
5739 std::string verbatim
= std::string ("<") + name
+ '>';
5741 gdb_assert (info
!= NULL
);
5742 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
);
5745 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5746 scope and in global scopes, or NULL if none. NAME is folded and
5747 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5748 choosing the first symbol if there are multiple choices. */
5751 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5754 std::vector
<struct block_symbol
> candidates
;
5757 n_candidates
= ada_lookup_symbol_list (name
, block0
, domain
, &candidates
);
5759 if (n_candidates
== 0)
5762 block_symbol info
= candidates
[0];
5763 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5767 static struct block_symbol
5768 ada_lookup_symbol_nonlocal (const struct language_defn
*langdef
,
5770 const struct block
*block
,
5771 const domain_enum domain
)
5773 struct block_symbol sym
;
5775 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
5776 if (sym
.symbol
!= NULL
)
5779 /* If we haven't found a match at this point, try the primitive
5780 types. In other languages, this search is performed before
5781 searching for global symbols in order to short-circuit that
5782 global-symbol search if it happens that the name corresponds
5783 to a primitive type. But we cannot do the same in Ada, because
5784 it is perfectly legitimate for a program to declare a type which
5785 has the same name as a standard type. If looking up a type in
5786 that situation, we have traditionally ignored the primitive type
5787 in favor of user-defined types. This is why, unlike most other
5788 languages, we search the primitive types this late and only after
5789 having searched the global symbols without success. */
5791 if (domain
== VAR_DOMAIN
)
5793 struct gdbarch
*gdbarch
;
5796 gdbarch
= target_gdbarch ();
5798 gdbarch
= block_gdbarch (block
);
5799 sym
.symbol
= language_lookup_primitive_type_as_symbol (langdef
, gdbarch
, name
);
5800 if (sym
.symbol
!= NULL
)
5808 /* True iff STR is a possible encoded suffix of a normal Ada name
5809 that is to be ignored for matching purposes. Suffixes of parallel
5810 names (e.g., XVE) are not included here. Currently, the possible suffixes
5811 are given by any of the regular expressions:
5813 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5814 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5815 TKB [subprogram suffix for task bodies]
5816 _E[0-9]+[bs]$ [protected object entry suffixes]
5817 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5819 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5820 match is performed. This sequence is used to differentiate homonyms,
5821 is an optional part of a valid name suffix. */
5824 is_name_suffix (const char *str
)
5827 const char *matching
;
5828 const int len
= strlen (str
);
5830 /* Skip optional leading __[0-9]+. */
5832 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5835 while (isdigit (str
[0]))
5841 if (str
[0] == '.' || str
[0] == '$')
5844 while (isdigit (matching
[0]))
5846 if (matching
[0] == '\0')
5852 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5855 while (isdigit (matching
[0]))
5857 if (matching
[0] == '\0')
5861 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5863 if (strcmp (str
, "TKB") == 0)
5867 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5868 with a N at the end. Unfortunately, the compiler uses the same
5869 convention for other internal types it creates. So treating
5870 all entity names that end with an "N" as a name suffix causes
5871 some regressions. For instance, consider the case of an enumerated
5872 type. To support the 'Image attribute, it creates an array whose
5874 Having a single character like this as a suffix carrying some
5875 information is a bit risky. Perhaps we should change the encoding
5876 to be something like "_N" instead. In the meantime, do not do
5877 the following check. */
5878 /* Protected Object Subprograms */
5879 if (len
== 1 && str
[0] == 'N')
5884 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5887 while (isdigit (matching
[0]))
5889 if ((matching
[0] == 'b' || matching
[0] == 's')
5890 && matching
[1] == '\0')
5894 /* ??? We should not modify STR directly, as we are doing below. This
5895 is fine in this case, but may become problematic later if we find
5896 that this alternative did not work, and want to try matching
5897 another one from the begining of STR. Since we modified it, we
5898 won't be able to find the begining of the string anymore! */
5902 while (str
[0] != '_' && str
[0] != '\0')
5904 if (str
[0] != 'n' && str
[0] != 'b')
5910 if (str
[0] == '\000')
5915 if (str
[1] != '_' || str
[2] == '\000')
5919 if (strcmp (str
+ 3, "JM") == 0)
5921 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5922 the LJM suffix in favor of the JM one. But we will
5923 still accept LJM as a valid suffix for a reasonable
5924 amount of time, just to allow ourselves to debug programs
5925 compiled using an older version of GNAT. */
5926 if (strcmp (str
+ 3, "LJM") == 0)
5930 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5931 || str
[4] == 'U' || str
[4] == 'P')
5933 if (str
[4] == 'R' && str
[5] != 'T')
5937 if (!isdigit (str
[2]))
5939 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5940 if (!isdigit (str
[k
]) && str
[k
] != '_')
5944 if (str
[0] == '$' && isdigit (str
[1]))
5946 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5947 if (!isdigit (str
[k
]) && str
[k
] != '_')
5954 /* Return non-zero if the string starting at NAME and ending before
5955 NAME_END contains no capital letters. */
5958 is_valid_name_for_wild_match (const char *name0
)
5960 std::string decoded_name
= ada_decode (name0
);
5963 /* If the decoded name starts with an angle bracket, it means that
5964 NAME0 does not follow the GNAT encoding format. It should then
5965 not be allowed as a possible wild match. */
5966 if (decoded_name
[0] == '<')
5969 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5970 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5976 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5977 that could start a simple name. Assumes that *NAMEP points into
5978 the string beginning at NAME0. */
5981 advance_wild_match (const char **namep
, const char *name0
, int target0
)
5983 const char *name
= *namep
;
5993 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
5996 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
6001 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
6002 || name
[2] == target0
))
6010 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
6020 /* Return true iff NAME encodes a name of the form prefix.PATN.
6021 Ignores any informational suffixes of NAME (i.e., for which
6022 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6026 wild_match (const char *name
, const char *patn
)
6029 const char *name0
= name
;
6033 const char *match
= name
;
6037 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
6040 if (*p
== '\0' && is_name_suffix (name
))
6041 return match
== name0
|| is_valid_name_for_wild_match (name0
);
6043 if (name
[-1] == '_')
6046 if (!advance_wild_match (&name
, name0
, *patn
))
6051 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6052 any trailing suffixes that encode debugging information or leading
6053 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6054 information that is ignored). */
6057 full_match (const char *sym_name
, const char *search_name
)
6059 size_t search_name_len
= strlen (search_name
);
6061 if (strncmp (sym_name
, search_name
, search_name_len
) == 0
6062 && is_name_suffix (sym_name
+ search_name_len
))
6065 if (startswith (sym_name
, "_ada_")
6066 && strncmp (sym_name
+ 5, search_name
, search_name_len
) == 0
6067 && is_name_suffix (sym_name
+ search_name_len
+ 5))
6073 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6074 *defn_symbols, updating the list of symbols in OBSTACKP (if
6075 necessary). OBJFILE is the section containing BLOCK. */
6078 ada_add_block_symbols (struct obstack
*obstackp
,
6079 const struct block
*block
,
6080 const lookup_name_info
&lookup_name
,
6081 domain_enum domain
, struct objfile
*objfile
)
6083 struct block_iterator iter
;
6084 /* A matching argument symbol, if any. */
6085 struct symbol
*arg_sym
;
6086 /* Set true when we find a matching non-argument symbol. */
6092 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6094 sym
= block_iter_match_next (lookup_name
, &iter
))
6096 if (symbol_matches_domain (sym
->language (), SYMBOL_DOMAIN (sym
), domain
))
6098 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6100 if (SYMBOL_IS_ARGUMENT (sym
))
6105 add_defn_to_vec (obstackp
,
6106 fixup_symbol_section (sym
, objfile
),
6113 /* Handle renamings. */
6115 if (ada_add_block_renamings (obstackp
, block
, lookup_name
, domain
))
6118 if (!found_sym
&& arg_sym
!= NULL
)
6120 add_defn_to_vec (obstackp
,
6121 fixup_symbol_section (arg_sym
, objfile
),
6125 if (!lookup_name
.ada ().wild_match_p ())
6129 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6130 const char *name
= ada_lookup_name
.c_str ();
6131 size_t name_len
= ada_lookup_name
.size ();
6133 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6135 if (symbol_matches_domain (sym
->language (),
6136 SYMBOL_DOMAIN (sym
), domain
))
6140 cmp
= (int) '_' - (int) sym
->linkage_name ()[0];
6143 cmp
= !startswith (sym
->linkage_name (), "_ada_");
6145 cmp
= strncmp (name
, sym
->linkage_name () + 5,
6150 && is_name_suffix (sym
->linkage_name () + name_len
+ 5))
6152 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6154 if (SYMBOL_IS_ARGUMENT (sym
))
6159 add_defn_to_vec (obstackp
,
6160 fixup_symbol_section (sym
, objfile
),
6168 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6169 They aren't parameters, right? */
6170 if (!found_sym
&& arg_sym
!= NULL
)
6172 add_defn_to_vec (obstackp
,
6173 fixup_symbol_section (arg_sym
, objfile
),
6180 /* Symbol Completion */
6185 ada_lookup_name_info::matches
6186 (const char *sym_name
,
6187 symbol_name_match_type match_type
,
6188 completion_match_result
*comp_match_res
) const
6191 const char *text
= m_encoded_name
.c_str ();
6192 size_t text_len
= m_encoded_name
.size ();
6194 /* First, test against the fully qualified name of the symbol. */
6196 if (strncmp (sym_name
, text
, text_len
) == 0)
6199 std::string decoded_name
= ada_decode (sym_name
);
6200 if (match
&& !m_encoded_p
)
6202 /* One needed check before declaring a positive match is to verify
6203 that iff we are doing a verbatim match, the decoded version
6204 of the symbol name starts with '<'. Otherwise, this symbol name
6205 is not a suitable completion. */
6207 bool has_angle_bracket
= (decoded_name
[0] == '<');
6208 match
= (has_angle_bracket
== m_verbatim_p
);
6211 if (match
&& !m_verbatim_p
)
6213 /* When doing non-verbatim match, another check that needs to
6214 be done is to verify that the potentially matching symbol name
6215 does not include capital letters, because the ada-mode would
6216 not be able to understand these symbol names without the
6217 angle bracket notation. */
6220 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6225 /* Second: Try wild matching... */
6227 if (!match
&& m_wild_match_p
)
6229 /* Since we are doing wild matching, this means that TEXT
6230 may represent an unqualified symbol name. We therefore must
6231 also compare TEXT against the unqualified name of the symbol. */
6232 sym_name
= ada_unqualified_name (decoded_name
.c_str ());
6234 if (strncmp (sym_name
, text
, text_len
) == 0)
6238 /* Finally: If we found a match, prepare the result to return. */
6243 if (comp_match_res
!= NULL
)
6245 std::string
&match_str
= comp_match_res
->match
.storage ();
6248 match_str
= ada_decode (sym_name
);
6252 match_str
= add_angle_brackets (sym_name
);
6254 match_str
= sym_name
;
6258 comp_match_res
->set_match (match_str
.c_str ());
6266 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6267 for tagged types. */
6270 ada_is_dispatch_table_ptr_type (struct type
*type
)
6274 if (type
->code () != TYPE_CODE_PTR
)
6277 name
= TYPE_TARGET_TYPE (type
)->name ();
6281 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6284 /* Return non-zero if TYPE is an interface tag. */
6287 ada_is_interface_tag (struct type
*type
)
6289 const char *name
= type
->name ();
6294 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6297 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6298 to be invisible to users. */
6301 ada_is_ignored_field (struct type
*type
, int field_num
)
6303 if (field_num
< 0 || field_num
> type
->num_fields ())
6306 /* Check the name of that field. */
6308 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6310 /* Anonymous field names should not be printed.
6311 brobecker/2007-02-20: I don't think this can actually happen
6312 but we don't want to print the value of anonymous fields anyway. */
6316 /* Normally, fields whose name start with an underscore ("_")
6317 are fields that have been internally generated by the compiler,
6318 and thus should not be printed. The "_parent" field is special,
6319 however: This is a field internally generated by the compiler
6320 for tagged types, and it contains the components inherited from
6321 the parent type. This field should not be printed as is, but
6322 should not be ignored either. */
6323 if (name
[0] == '_' && !startswith (name
, "_parent"))
6327 /* If this is the dispatch table of a tagged type or an interface tag,
6329 if (ada_is_tagged_type (type
, 1)
6330 && (ada_is_dispatch_table_ptr_type (type
->field (field_num
).type ())
6331 || ada_is_interface_tag (type
->field (field_num
).type ())))
6334 /* Not a special field, so it should not be ignored. */
6338 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6339 pointer or reference type whose ultimate target has a tag field. */
6342 ada_is_tagged_type (struct type
*type
, int refok
)
6344 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6347 /* True iff TYPE represents the type of X'Tag */
6350 ada_is_tag_type (struct type
*type
)
6352 type
= ada_check_typedef (type
);
6354 if (type
== NULL
|| type
->code () != TYPE_CODE_PTR
)
6358 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6360 return (name
!= NULL
6361 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6365 /* The type of the tag on VAL. */
6367 static struct type
*
6368 ada_tag_type (struct value
*val
)
6370 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6373 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6374 retired at Ada 05). */
6377 is_ada95_tag (struct value
*tag
)
6379 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6382 /* The value of the tag on VAL. */
6384 static struct value
*
6385 ada_value_tag (struct value
*val
)
6387 return ada_value_struct_elt (val
, "_tag", 0);
6390 /* The value of the tag on the object of type TYPE whose contents are
6391 saved at VALADDR, if it is non-null, or is at memory address
6394 static struct value
*
6395 value_tag_from_contents_and_address (struct type
*type
,
6396 const gdb_byte
*valaddr
,
6399 int tag_byte_offset
;
6400 struct type
*tag_type
;
6402 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6405 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6407 : valaddr
+ tag_byte_offset
);
6408 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6410 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6415 static struct type
*
6416 type_from_tag (struct value
*tag
)
6418 gdb::unique_xmalloc_ptr
<char> type_name
= ada_tag_name (tag
);
6420 if (type_name
!= NULL
)
6421 return ada_find_any_type (ada_encode (type_name
.get ()));
6425 /* Given a value OBJ of a tagged type, return a value of this
6426 type at the base address of the object. The base address, as
6427 defined in Ada.Tags, it is the address of the primary tag of
6428 the object, and therefore where the field values of its full
6429 view can be fetched. */
6432 ada_tag_value_at_base_address (struct value
*obj
)
6435 LONGEST offset_to_top
= 0;
6436 struct type
*ptr_type
, *obj_type
;
6438 CORE_ADDR base_address
;
6440 obj_type
= value_type (obj
);
6442 /* It is the responsability of the caller to deref pointers. */
6444 if (obj_type
->code () == TYPE_CODE_PTR
|| obj_type
->code () == TYPE_CODE_REF
)
6447 tag
= ada_value_tag (obj
);
6451 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6453 if (is_ada95_tag (tag
))
6456 ptr_type
= language_lookup_primitive_type
6457 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6458 ptr_type
= lookup_pointer_type (ptr_type
);
6459 val
= value_cast (ptr_type
, tag
);
6463 /* It is perfectly possible that an exception be raised while
6464 trying to determine the base address, just like for the tag;
6465 see ada_tag_name for more details. We do not print the error
6466 message for the same reason. */
6470 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6473 catch (const gdb_exception_error
&e
)
6478 /* If offset is null, nothing to do. */
6480 if (offset_to_top
== 0)
6483 /* -1 is a special case in Ada.Tags; however, what should be done
6484 is not quite clear from the documentation. So do nothing for
6487 if (offset_to_top
== -1)
6490 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6491 from the base address. This was however incompatible with
6492 C++ dispatch table: C++ uses a *negative* value to *add*
6493 to the base address. Ada's convention has therefore been
6494 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6495 use the same convention. Here, we support both cases by
6496 checking the sign of OFFSET_TO_TOP. */
6498 if (offset_to_top
> 0)
6499 offset_to_top
= -offset_to_top
;
6501 base_address
= value_address (obj
) + offset_to_top
;
6502 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6504 /* Make sure that we have a proper tag at the new address.
6505 Otherwise, offset_to_top is bogus (which can happen when
6506 the object is not initialized yet). */
6511 obj_type
= type_from_tag (tag
);
6516 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6519 /* Return the "ada__tags__type_specific_data" type. */
6521 static struct type
*
6522 ada_get_tsd_type (struct inferior
*inf
)
6524 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6526 if (data
->tsd_type
== 0)
6527 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6528 return data
->tsd_type
;
6531 /* Return the TSD (type-specific data) associated to the given TAG.
6532 TAG is assumed to be the tag of a tagged-type entity.
6534 May return NULL if we are unable to get the TSD. */
6536 static struct value
*
6537 ada_get_tsd_from_tag (struct value
*tag
)
6542 /* First option: The TSD is simply stored as a field of our TAG.
6543 Only older versions of GNAT would use this format, but we have
6544 to test it first, because there are no visible markers for
6545 the current approach except the absence of that field. */
6547 val
= ada_value_struct_elt (tag
, "tsd", 1);
6551 /* Try the second representation for the dispatch table (in which
6552 there is no explicit 'tsd' field in the referent of the tag pointer,
6553 and instead the tsd pointer is stored just before the dispatch
6556 type
= ada_get_tsd_type (current_inferior());
6559 type
= lookup_pointer_type (lookup_pointer_type (type
));
6560 val
= value_cast (type
, tag
);
6563 return value_ind (value_ptradd (val
, -1));
6566 /* Given the TSD of a tag (type-specific data), return a string
6567 containing the name of the associated type.
6569 May return NULL if we are unable to determine the tag name. */
6571 static gdb::unique_xmalloc_ptr
<char>
6572 ada_tag_name_from_tsd (struct value
*tsd
)
6577 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6580 gdb::unique_xmalloc_ptr
<char> buffer
6581 = target_read_string (value_as_address (val
), INT_MAX
);
6582 if (buffer
== nullptr)
6585 for (p
= buffer
.get (); *p
!= '\0'; ++p
)
6594 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6597 Return NULL if the TAG is not an Ada tag, or if we were unable to
6598 determine the name of that tag. */
6600 gdb::unique_xmalloc_ptr
<char>
6601 ada_tag_name (struct value
*tag
)
6603 gdb::unique_xmalloc_ptr
<char> name
;
6605 if (!ada_is_tag_type (value_type (tag
)))
6608 /* It is perfectly possible that an exception be raised while trying
6609 to determine the TAG's name, even under normal circumstances:
6610 The associated variable may be uninitialized or corrupted, for
6611 instance. We do not let any exception propagate past this point.
6612 instead we return NULL.
6614 We also do not print the error message either (which often is very
6615 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6616 the caller print a more meaningful message if necessary. */
6619 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6622 name
= ada_tag_name_from_tsd (tsd
);
6624 catch (const gdb_exception_error
&e
)
6631 /* The parent type of TYPE, or NULL if none. */
6634 ada_parent_type (struct type
*type
)
6638 type
= ada_check_typedef (type
);
6640 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
6643 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6644 if (ada_is_parent_field (type
, i
))
6646 struct type
*parent_type
= type
->field (i
).type ();
6648 /* If the _parent field is a pointer, then dereference it. */
6649 if (parent_type
->code () == TYPE_CODE_PTR
)
6650 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6651 /* If there is a parallel XVS type, get the actual base type. */
6652 parent_type
= ada_get_base_type (parent_type
);
6654 return ada_check_typedef (parent_type
);
6660 /* True iff field number FIELD_NUM of structure type TYPE contains the
6661 parent-type (inherited) fields of a derived type. Assumes TYPE is
6662 a structure type with at least FIELD_NUM+1 fields. */
6665 ada_is_parent_field (struct type
*type
, int field_num
)
6667 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6669 return (name
!= NULL
6670 && (startswith (name
, "PARENT")
6671 || startswith (name
, "_parent")));
6674 /* True iff field number FIELD_NUM of structure type TYPE is a
6675 transparent wrapper field (which should be silently traversed when doing
6676 field selection and flattened when printing). Assumes TYPE is a
6677 structure type with at least FIELD_NUM+1 fields. Such fields are always
6681 ada_is_wrapper_field (struct type
*type
, int field_num
)
6683 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6685 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6687 /* This happens in functions with "out" or "in out" parameters
6688 which are passed by copy. For such functions, GNAT describes
6689 the function's return type as being a struct where the return
6690 value is in a field called RETVAL, and where the other "out"
6691 or "in out" parameters are fields of that struct. This is not
6696 return (name
!= NULL
6697 && (startswith (name
, "PARENT")
6698 || strcmp (name
, "REP") == 0
6699 || startswith (name
, "_parent")
6700 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6703 /* True iff field number FIELD_NUM of structure or union type TYPE
6704 is a variant wrapper. Assumes TYPE is a structure type with at least
6705 FIELD_NUM+1 fields. */
6708 ada_is_variant_part (struct type
*type
, int field_num
)
6710 /* Only Ada types are eligible. */
6711 if (!ADA_TYPE_P (type
))
6714 struct type
*field_type
= type
->field (field_num
).type ();
6716 return (field_type
->code () == TYPE_CODE_UNION
6717 || (is_dynamic_field (type
, field_num
)
6718 && (TYPE_TARGET_TYPE (field_type
)->code ()
6719 == TYPE_CODE_UNION
)));
6722 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6723 whose discriminants are contained in the record type OUTER_TYPE,
6724 returns the type of the controlling discriminant for the variant.
6725 May return NULL if the type could not be found. */
6728 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6730 const char *name
= ada_variant_discrim_name (var_type
);
6732 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6735 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6736 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6737 represents a 'when others' clause; otherwise 0. */
6740 ada_is_others_clause (struct type
*type
, int field_num
)
6742 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6744 return (name
!= NULL
&& name
[0] == 'O');
6747 /* Assuming that TYPE0 is the type of the variant part of a record,
6748 returns the name of the discriminant controlling the variant.
6749 The value is valid until the next call to ada_variant_discrim_name. */
6752 ada_variant_discrim_name (struct type
*type0
)
6754 static char *result
= NULL
;
6755 static size_t result_len
= 0;
6758 const char *discrim_end
;
6759 const char *discrim_start
;
6761 if (type0
->code () == TYPE_CODE_PTR
)
6762 type
= TYPE_TARGET_TYPE (type0
);
6766 name
= ada_type_name (type
);
6768 if (name
== NULL
|| name
[0] == '\000')
6771 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6774 if (startswith (discrim_end
, "___XVN"))
6777 if (discrim_end
== name
)
6780 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6783 if (discrim_start
== name
+ 1)
6785 if ((discrim_start
> name
+ 3
6786 && startswith (discrim_start
- 3, "___"))
6787 || discrim_start
[-1] == '.')
6791 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6792 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6793 result
[discrim_end
- discrim_start
] = '\0';
6797 /* Scan STR for a subtype-encoded number, beginning at position K.
6798 Put the position of the character just past the number scanned in
6799 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6800 Return 1 if there was a valid number at the given position, and 0
6801 otherwise. A "subtype-encoded" number consists of the absolute value
6802 in decimal, followed by the letter 'm' to indicate a negative number.
6803 Assumes 0m does not occur. */
6806 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6810 if (!isdigit (str
[k
]))
6813 /* Do it the hard way so as not to make any assumption about
6814 the relationship of unsigned long (%lu scan format code) and
6817 while (isdigit (str
[k
]))
6819 RU
= RU
* 10 + (str
[k
] - '0');
6826 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6832 /* NOTE on the above: Technically, C does not say what the results of
6833 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6834 number representable as a LONGEST (although either would probably work
6835 in most implementations). When RU>0, the locution in the then branch
6836 above is always equivalent to the negative of RU. */
6843 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6844 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6845 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6848 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6850 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6864 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6874 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6875 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6877 if (val
>= L
&& val
<= U
)
6889 /* FIXME: Lots of redundancy below. Try to consolidate. */
6891 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6892 ARG_TYPE, extract and return the value of one of its (non-static)
6893 fields. FIELDNO says which field. Differs from value_primitive_field
6894 only in that it can handle packed values of arbitrary type. */
6897 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6898 struct type
*arg_type
)
6902 arg_type
= ada_check_typedef (arg_type
);
6903 type
= arg_type
->field (fieldno
).type ();
6905 /* Handle packed fields. It might be that the field is not packed
6906 relative to its containing structure, but the structure itself is
6907 packed; in this case we must take the bit-field path. */
6908 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
6910 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6911 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6913 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6914 offset
+ bit_pos
/ 8,
6915 bit_pos
% 8, bit_size
, type
);
6918 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6921 /* Find field with name NAME in object of type TYPE. If found,
6922 set the following for each argument that is non-null:
6923 - *FIELD_TYPE_P to the field's type;
6924 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6925 an object of that type;
6926 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6927 - *BIT_SIZE_P to its size in bits if the field is packed, and
6929 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6930 fields up to but not including the desired field, or by the total
6931 number of fields if not found. A NULL value of NAME never
6932 matches; the function just counts visible fields in this case.
6934 Notice that we need to handle when a tagged record hierarchy
6935 has some components with the same name, like in this scenario:
6937 type Top_T is tagged record
6943 type Middle_T is new Top.Top_T with record
6944 N : Character := 'a';
6948 type Bottom_T is new Middle.Middle_T with record
6950 C : Character := '5';
6952 A : Character := 'J';
6955 Let's say we now have a variable declared and initialized as follow:
6957 TC : Top_A := new Bottom_T;
6959 And then we use this variable to call this function
6961 procedure Assign (Obj: in out Top_T; TV : Integer);
6965 Assign (Top_T (B), 12);
6967 Now, we're in the debugger, and we're inside that procedure
6968 then and we want to print the value of obj.c:
6970 Usually, the tagged record or one of the parent type owns the
6971 component to print and there's no issue but in this particular
6972 case, what does it mean to ask for Obj.C? Since the actual
6973 type for object is type Bottom_T, it could mean two things: type
6974 component C from the Middle_T view, but also component C from
6975 Bottom_T. So in that "undefined" case, when the component is
6976 not found in the non-resolved type (which includes all the
6977 components of the parent type), then resolve it and see if we
6978 get better luck once expanded.
6980 In the case of homonyms in the derived tagged type, we don't
6981 guaranty anything, and pick the one that's easiest for us
6984 Returns 1 if found, 0 otherwise. */
6987 find_struct_field (const char *name
, struct type
*type
, int offset
,
6988 struct type
**field_type_p
,
6989 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
6993 int parent_offset
= -1;
6995 type
= ada_check_typedef (type
);
6997 if (field_type_p
!= NULL
)
6998 *field_type_p
= NULL
;
6999 if (byte_offset_p
!= NULL
)
7001 if (bit_offset_p
!= NULL
)
7003 if (bit_size_p
!= NULL
)
7006 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7008 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
7009 int fld_offset
= offset
+ bit_pos
/ 8;
7010 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7012 if (t_field_name
== NULL
)
7015 else if (ada_is_parent_field (type
, i
))
7017 /* This is a field pointing us to the parent type of a tagged
7018 type. As hinted in this function's documentation, we give
7019 preference to fields in the current record first, so what
7020 we do here is just record the index of this field before
7021 we skip it. If it turns out we couldn't find our field
7022 in the current record, then we'll get back to it and search
7023 inside it whether the field might exist in the parent. */
7029 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7031 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7033 if (field_type_p
!= NULL
)
7034 *field_type_p
= type
->field (i
).type ();
7035 if (byte_offset_p
!= NULL
)
7036 *byte_offset_p
= fld_offset
;
7037 if (bit_offset_p
!= NULL
)
7038 *bit_offset_p
= bit_pos
% 8;
7039 if (bit_size_p
!= NULL
)
7040 *bit_size_p
= bit_size
;
7043 else if (ada_is_wrapper_field (type
, i
))
7045 if (find_struct_field (name
, type
->field (i
).type (), fld_offset
,
7046 field_type_p
, byte_offset_p
, bit_offset_p
,
7047 bit_size_p
, index_p
))
7050 else if (ada_is_variant_part (type
, i
))
7052 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7055 struct type
*field_type
7056 = ada_check_typedef (type
->field (i
).type ());
7058 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7060 if (find_struct_field (name
, field_type
->field (j
).type (),
7062 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7063 field_type_p
, byte_offset_p
,
7064 bit_offset_p
, bit_size_p
, index_p
))
7068 else if (index_p
!= NULL
)
7072 /* Field not found so far. If this is a tagged type which
7073 has a parent, try finding that field in the parent now. */
7075 if (parent_offset
!= -1)
7077 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
7078 int fld_offset
= offset
+ bit_pos
/ 8;
7080 if (find_struct_field (name
, type
->field (parent_offset
).type (),
7081 fld_offset
, field_type_p
, byte_offset_p
,
7082 bit_offset_p
, bit_size_p
, index_p
))
7089 /* Number of user-visible fields in record type TYPE. */
7092 num_visible_fields (struct type
*type
)
7097 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7101 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7102 and search in it assuming it has (class) type TYPE.
7103 If found, return value, else return NULL.
7105 Searches recursively through wrapper fields (e.g., '_parent').
7107 In the case of homonyms in the tagged types, please refer to the
7108 long explanation in find_struct_field's function documentation. */
7110 static struct value
*
7111 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7115 int parent_offset
= -1;
7117 type
= ada_check_typedef (type
);
7118 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7120 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7122 if (t_field_name
== NULL
)
7125 else if (ada_is_parent_field (type
, i
))
7127 /* This is a field pointing us to the parent type of a tagged
7128 type. As hinted in this function's documentation, we give
7129 preference to fields in the current record first, so what
7130 we do here is just record the index of this field before
7131 we skip it. If it turns out we couldn't find our field
7132 in the current record, then we'll get back to it and search
7133 inside it whether the field might exist in the parent. */
7139 else if (field_name_match (t_field_name
, name
))
7140 return ada_value_primitive_field (arg
, offset
, i
, type
);
7142 else if (ada_is_wrapper_field (type
, i
))
7144 struct value
*v
= /* Do not let indent join lines here. */
7145 ada_search_struct_field (name
, arg
,
7146 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7147 type
->field (i
).type ());
7153 else if (ada_is_variant_part (type
, i
))
7155 /* PNH: Do we ever get here? See find_struct_field. */
7157 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7158 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7160 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7162 struct value
*v
= ada_search_struct_field
/* Force line
7165 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7166 field_type
->field (j
).type ());
7174 /* Field not found so far. If this is a tagged type which
7175 has a parent, try finding that field in the parent now. */
7177 if (parent_offset
!= -1)
7179 struct value
*v
= ada_search_struct_field (
7180 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7181 type
->field (parent_offset
).type ());
7190 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7191 int, struct type
*);
7194 /* Return field #INDEX in ARG, where the index is that returned by
7195 * find_struct_field through its INDEX_P argument. Adjust the address
7196 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7197 * If found, return value, else return NULL. */
7199 static struct value
*
7200 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7203 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7207 /* Auxiliary function for ada_index_struct_field. Like
7208 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7211 static struct value
*
7212 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7216 type
= ada_check_typedef (type
);
7218 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7220 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7222 else if (ada_is_wrapper_field (type
, i
))
7224 struct value
*v
= /* Do not let indent join lines here. */
7225 ada_index_struct_field_1 (index_p
, arg
,
7226 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7227 type
->field (i
).type ());
7233 else if (ada_is_variant_part (type
, i
))
7235 /* PNH: Do we ever get here? See ada_search_struct_field,
7236 find_struct_field. */
7237 error (_("Cannot assign this kind of variant record"));
7239 else if (*index_p
== 0)
7240 return ada_value_primitive_field (arg
, offset
, i
, type
);
7247 /* Return a string representation of type TYPE. */
7250 type_as_string (struct type
*type
)
7252 string_file tmp_stream
;
7254 type_print (type
, "", &tmp_stream
, -1);
7256 return std::move (tmp_stream
.string ());
7259 /* Given a type TYPE, look up the type of the component of type named NAME.
7260 If DISPP is non-null, add its byte displacement from the beginning of a
7261 structure (pointed to by a value) of type TYPE to *DISPP (does not
7262 work for packed fields).
7264 Matches any field whose name has NAME as a prefix, possibly
7267 TYPE can be either a struct or union. If REFOK, TYPE may also
7268 be a (pointer or reference)+ to a struct or union, and the
7269 ultimate target type will be searched.
7271 Looks recursively into variant clauses and parent types.
7273 In the case of homonyms in the tagged types, please refer to the
7274 long explanation in find_struct_field's function documentation.
7276 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7277 TYPE is not a type of the right kind. */
7279 static struct type
*
7280 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7284 int parent_offset
= -1;
7289 if (refok
&& type
!= NULL
)
7292 type
= ada_check_typedef (type
);
7293 if (type
->code () != TYPE_CODE_PTR
&& type
->code () != TYPE_CODE_REF
)
7295 type
= TYPE_TARGET_TYPE (type
);
7299 || (type
->code () != TYPE_CODE_STRUCT
7300 && type
->code () != TYPE_CODE_UNION
))
7305 error (_("Type %s is not a structure or union type"),
7306 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7309 type
= to_static_fixed_type (type
);
7311 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7313 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7316 if (t_field_name
== NULL
)
7319 else if (ada_is_parent_field (type
, i
))
7321 /* This is a field pointing us to the parent type of a tagged
7322 type. As hinted in this function's documentation, we give
7323 preference to fields in the current record first, so what
7324 we do here is just record the index of this field before
7325 we skip it. If it turns out we couldn't find our field
7326 in the current record, then we'll get back to it and search
7327 inside it whether the field might exist in the parent. */
7333 else if (field_name_match (t_field_name
, name
))
7334 return type
->field (i
).type ();
7336 else if (ada_is_wrapper_field (type
, i
))
7338 t
= ada_lookup_struct_elt_type (type
->field (i
).type (), name
,
7344 else if (ada_is_variant_part (type
, i
))
7347 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7349 for (j
= field_type
->num_fields () - 1; j
>= 0; j
-= 1)
7351 /* FIXME pnh 2008/01/26: We check for a field that is
7352 NOT wrapped in a struct, since the compiler sometimes
7353 generates these for unchecked variant types. Revisit
7354 if the compiler changes this practice. */
7355 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7357 if (v_field_name
!= NULL
7358 && field_name_match (v_field_name
, name
))
7359 t
= field_type
->field (j
).type ();
7361 t
= ada_lookup_struct_elt_type (field_type
->field (j
).type (),
7371 /* Field not found so far. If this is a tagged type which
7372 has a parent, try finding that field in the parent now. */
7374 if (parent_offset
!= -1)
7378 t
= ada_lookup_struct_elt_type (type
->field (parent_offset
).type (),
7387 const char *name_str
= name
!= NULL
? name
: _("<null>");
7389 error (_("Type %s has no component named %s"),
7390 type_as_string (type
).c_str (), name_str
);
7396 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7397 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7398 represents an unchecked union (that is, the variant part of a
7399 record that is named in an Unchecked_Union pragma). */
7402 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7404 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7406 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7410 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7411 within OUTER, determine which variant clause (field number in VAR_TYPE,
7412 numbering from 0) is applicable. Returns -1 if none are. */
7415 ada_which_variant_applies (struct type
*var_type
, struct value
*outer
)
7419 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7420 struct value
*discrim
;
7421 LONGEST discrim_val
;
7423 /* Using plain value_from_contents_and_address here causes problems
7424 because we will end up trying to resolve a type that is currently
7425 being constructed. */
7426 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7427 if (discrim
== NULL
)
7429 discrim_val
= value_as_long (discrim
);
7432 for (i
= 0; i
< var_type
->num_fields (); i
+= 1)
7434 if (ada_is_others_clause (var_type
, i
))
7436 else if (ada_in_variant (discrim_val
, var_type
, i
))
7440 return others_clause
;
7445 /* Dynamic-Sized Records */
7447 /* Strategy: The type ostensibly attached to a value with dynamic size
7448 (i.e., a size that is not statically recorded in the debugging
7449 data) does not accurately reflect the size or layout of the value.
7450 Our strategy is to convert these values to values with accurate,
7451 conventional types that are constructed on the fly. */
7453 /* There is a subtle and tricky problem here. In general, we cannot
7454 determine the size of dynamic records without its data. However,
7455 the 'struct value' data structure, which GDB uses to represent
7456 quantities in the inferior process (the target), requires the size
7457 of the type at the time of its allocation in order to reserve space
7458 for GDB's internal copy of the data. That's why the
7459 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7460 rather than struct value*s.
7462 However, GDB's internal history variables ($1, $2, etc.) are
7463 struct value*s containing internal copies of the data that are not, in
7464 general, the same as the data at their corresponding addresses in
7465 the target. Fortunately, the types we give to these values are all
7466 conventional, fixed-size types (as per the strategy described
7467 above), so that we don't usually have to perform the
7468 'to_fixed_xxx_type' conversions to look at their values.
7469 Unfortunately, there is one exception: if one of the internal
7470 history variables is an array whose elements are unconstrained
7471 records, then we will need to create distinct fixed types for each
7472 element selected. */
7474 /* The upshot of all of this is that many routines take a (type, host
7475 address, target address) triple as arguments to represent a value.
7476 The host address, if non-null, is supposed to contain an internal
7477 copy of the relevant data; otherwise, the program is to consult the
7478 target at the target address. */
7480 /* Assuming that VAL0 represents a pointer value, the result of
7481 dereferencing it. Differs from value_ind in its treatment of
7482 dynamic-sized types. */
7485 ada_value_ind (struct value
*val0
)
7487 struct value
*val
= value_ind (val0
);
7489 if (ada_is_tagged_type (value_type (val
), 0))
7490 val
= ada_tag_value_at_base_address (val
);
7492 return ada_to_fixed_value (val
);
7495 /* The value resulting from dereferencing any "reference to"
7496 qualifiers on VAL0. */
7498 static struct value
*
7499 ada_coerce_ref (struct value
*val0
)
7501 if (value_type (val0
)->code () == TYPE_CODE_REF
)
7503 struct value
*val
= val0
;
7505 val
= coerce_ref (val
);
7507 if (ada_is_tagged_type (value_type (val
), 0))
7508 val
= ada_tag_value_at_base_address (val
);
7510 return ada_to_fixed_value (val
);
7516 /* Return the bit alignment required for field #F of template type TYPE. */
7519 field_alignment (struct type
*type
, int f
)
7521 const char *name
= TYPE_FIELD_NAME (type
, f
);
7525 /* The field name should never be null, unless the debugging information
7526 is somehow malformed. In this case, we assume the field does not
7527 require any alignment. */
7531 len
= strlen (name
);
7533 if (!isdigit (name
[len
- 1]))
7536 if (isdigit (name
[len
- 2]))
7537 align_offset
= len
- 2;
7539 align_offset
= len
- 1;
7541 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7542 return TARGET_CHAR_BIT
;
7544 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7547 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7549 static struct symbol
*
7550 ada_find_any_type_symbol (const char *name
)
7554 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7555 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7558 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7562 /* Find a type named NAME. Ignores ambiguity. This routine will look
7563 solely for types defined by debug info, it will not search the GDB
7566 static struct type
*
7567 ada_find_any_type (const char *name
)
7569 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7572 return SYMBOL_TYPE (sym
);
7577 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7578 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7579 symbol, in which case it is returned. Otherwise, this looks for
7580 symbols whose name is that of NAME_SYM suffixed with "___XR".
7581 Return symbol if found, and NULL otherwise. */
7584 ada_is_renaming_symbol (struct symbol
*name_sym
)
7586 const char *name
= name_sym
->linkage_name ();
7587 return strstr (name
, "___XR") != NULL
;
7590 /* Because of GNAT encoding conventions, several GDB symbols may match a
7591 given type name. If the type denoted by TYPE0 is to be preferred to
7592 that of TYPE1 for purposes of type printing, return non-zero;
7593 otherwise return 0. */
7596 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7600 else if (type0
== NULL
)
7602 else if (type1
->code () == TYPE_CODE_VOID
)
7604 else if (type0
->code () == TYPE_CODE_VOID
)
7606 else if (type1
->name () == NULL
&& type0
->name () != NULL
)
7608 else if (ada_is_constrained_packed_array_type (type0
))
7610 else if (ada_is_array_descriptor_type (type0
)
7611 && !ada_is_array_descriptor_type (type1
))
7615 const char *type0_name
= type0
->name ();
7616 const char *type1_name
= type1
->name ();
7618 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7619 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7625 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7629 ada_type_name (struct type
*type
)
7633 return type
->name ();
7636 /* Search the list of "descriptive" types associated to TYPE for a type
7637 whose name is NAME. */
7639 static struct type
*
7640 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7642 struct type
*result
, *tmp
;
7644 if (ada_ignore_descriptive_types_p
)
7647 /* If there no descriptive-type info, then there is no parallel type
7649 if (!HAVE_GNAT_AUX_INFO (type
))
7652 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7653 while (result
!= NULL
)
7655 const char *result_name
= ada_type_name (result
);
7657 if (result_name
== NULL
)
7659 warning (_("unexpected null name on descriptive type"));
7663 /* If the names match, stop. */
7664 if (strcmp (result_name
, name
) == 0)
7667 /* Otherwise, look at the next item on the list, if any. */
7668 if (HAVE_GNAT_AUX_INFO (result
))
7669 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7673 /* If not found either, try after having resolved the typedef. */
7678 result
= check_typedef (result
);
7679 if (HAVE_GNAT_AUX_INFO (result
))
7680 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7686 /* If we didn't find a match, see whether this is a packed array. With
7687 older compilers, the descriptive type information is either absent or
7688 irrelevant when it comes to packed arrays so the above lookup fails.
7689 Fall back to using a parallel lookup by name in this case. */
7690 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7691 return ada_find_any_type (name
);
7696 /* Find a parallel type to TYPE with the specified NAME, using the
7697 descriptive type taken from the debugging information, if available,
7698 and otherwise using the (slower) name-based method. */
7700 static struct type
*
7701 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7703 struct type
*result
= NULL
;
7705 if (HAVE_GNAT_AUX_INFO (type
))
7706 result
= find_parallel_type_by_descriptive_type (type
, name
);
7708 result
= ada_find_any_type (name
);
7713 /* Same as above, but specify the name of the parallel type by appending
7714 SUFFIX to the name of TYPE. */
7717 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7720 const char *type_name
= ada_type_name (type
);
7723 if (type_name
== NULL
)
7726 len
= strlen (type_name
);
7728 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7730 strcpy (name
, type_name
);
7731 strcpy (name
+ len
, suffix
);
7733 return ada_find_parallel_type_with_name (type
, name
);
7736 /* If TYPE is a variable-size record type, return the corresponding template
7737 type describing its fields. Otherwise, return NULL. */
7739 static struct type
*
7740 dynamic_template_type (struct type
*type
)
7742 type
= ada_check_typedef (type
);
7744 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
7745 || ada_type_name (type
) == NULL
)
7749 int len
= strlen (ada_type_name (type
));
7751 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7754 return ada_find_parallel_type (type
, "___XVE");
7758 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7759 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7762 is_dynamic_field (struct type
*templ_type
, int field_num
)
7764 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7767 && templ_type
->field (field_num
).type ()->code () == TYPE_CODE_PTR
7768 && strstr (name
, "___XVL") != NULL
;
7771 /* The index of the variant field of TYPE, or -1 if TYPE does not
7772 represent a variant record type. */
7775 variant_field_index (struct type
*type
)
7779 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
7782 for (f
= 0; f
< type
->num_fields (); f
+= 1)
7784 if (ada_is_variant_part (type
, f
))
7790 /* A record type with no fields. */
7792 static struct type
*
7793 empty_record (struct type
*templ
)
7795 struct type
*type
= alloc_type_copy (templ
);
7797 type
->set_code (TYPE_CODE_STRUCT
);
7798 INIT_NONE_SPECIFIC (type
);
7799 type
->set_name ("<empty>");
7800 TYPE_LENGTH (type
) = 0;
7804 /* An ordinary record type (with fixed-length fields) that describes
7805 the value of type TYPE at VALADDR or ADDRESS (see comments at
7806 the beginning of this section) VAL according to GNAT conventions.
7807 DVAL0 should describe the (portion of a) record that contains any
7808 necessary discriminants. It should be NULL if value_type (VAL) is
7809 an outer-level type (i.e., as opposed to a branch of a variant.) A
7810 variant field (unless unchecked) is replaced by a particular branch
7813 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7814 length are not statically known are discarded. As a consequence,
7815 VALADDR, ADDRESS and DVAL0 are ignored.
7817 NOTE: Limitations: For now, we assume that dynamic fields and
7818 variants occupy whole numbers of bytes. However, they need not be
7822 ada_template_to_fixed_record_type_1 (struct type
*type
,
7823 const gdb_byte
*valaddr
,
7824 CORE_ADDR address
, struct value
*dval0
,
7825 int keep_dynamic_fields
)
7827 struct value
*mark
= value_mark ();
7830 int nfields
, bit_len
;
7836 /* Compute the number of fields in this record type that are going
7837 to be processed: unless keep_dynamic_fields, this includes only
7838 fields whose position and length are static will be processed. */
7839 if (keep_dynamic_fields
)
7840 nfields
= type
->num_fields ();
7844 while (nfields
< type
->num_fields ()
7845 && !ada_is_variant_part (type
, nfields
)
7846 && !is_dynamic_field (type
, nfields
))
7850 rtype
= alloc_type_copy (type
);
7851 rtype
->set_code (TYPE_CODE_STRUCT
);
7852 INIT_NONE_SPECIFIC (rtype
);
7853 rtype
->set_num_fields (nfields
);
7855 ((struct field
*) TYPE_ZALLOC (rtype
, nfields
* sizeof (struct field
)));
7856 rtype
->set_name (ada_type_name (type
));
7857 TYPE_FIXED_INSTANCE (rtype
) = 1;
7863 for (f
= 0; f
< nfields
; f
+= 1)
7865 off
= align_up (off
, field_alignment (type
, f
))
7866 + TYPE_FIELD_BITPOS (type
, f
);
7867 SET_FIELD_BITPOS (rtype
->field (f
), off
);
7868 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7870 if (ada_is_variant_part (type
, f
))
7875 else if (is_dynamic_field (type
, f
))
7877 const gdb_byte
*field_valaddr
= valaddr
;
7878 CORE_ADDR field_address
= address
;
7879 struct type
*field_type
=
7880 TYPE_TARGET_TYPE (type
->field (f
).type ());
7884 /* rtype's length is computed based on the run-time
7885 value of discriminants. If the discriminants are not
7886 initialized, the type size may be completely bogus and
7887 GDB may fail to allocate a value for it. So check the
7888 size first before creating the value. */
7889 ada_ensure_varsize_limit (rtype
);
7890 /* Using plain value_from_contents_and_address here
7891 causes problems because we will end up trying to
7892 resolve a type that is currently being
7894 dval
= value_from_contents_and_address_unresolved (rtype
,
7897 rtype
= value_type (dval
);
7902 /* If the type referenced by this field is an aligner type, we need
7903 to unwrap that aligner type, because its size might not be set.
7904 Keeping the aligner type would cause us to compute the wrong
7905 size for this field, impacting the offset of the all the fields
7906 that follow this one. */
7907 if (ada_is_aligner_type (field_type
))
7909 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7911 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7912 field_address
= cond_offset_target (field_address
, field_offset
);
7913 field_type
= ada_aligned_type (field_type
);
7916 field_valaddr
= cond_offset_host (field_valaddr
,
7917 off
/ TARGET_CHAR_BIT
);
7918 field_address
= cond_offset_target (field_address
,
7919 off
/ TARGET_CHAR_BIT
);
7921 /* Get the fixed type of the field. Note that, in this case,
7922 we do not want to get the real type out of the tag: if
7923 the current field is the parent part of a tagged record,
7924 we will get the tag of the object. Clearly wrong: the real
7925 type of the parent is not the real type of the child. We
7926 would end up in an infinite loop. */
7927 field_type
= ada_get_base_type (field_type
);
7928 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7929 field_address
, dval
, 0);
7930 /* If the field size is already larger than the maximum
7931 object size, then the record itself will necessarily
7932 be larger than the maximum object size. We need to make
7933 this check now, because the size might be so ridiculously
7934 large (due to an uninitialized variable in the inferior)
7935 that it would cause an overflow when adding it to the
7937 ada_ensure_varsize_limit (field_type
);
7939 rtype
->field (f
).set_type (field_type
);
7940 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7941 /* The multiplication can potentially overflow. But because
7942 the field length has been size-checked just above, and
7943 assuming that the maximum size is a reasonable value,
7944 an overflow should not happen in practice. So rather than
7945 adding overflow recovery code to this already complex code,
7946 we just assume that it's not going to happen. */
7948 TYPE_LENGTH (rtype
->field (f
).type ()) * TARGET_CHAR_BIT
;
7952 /* Note: If this field's type is a typedef, it is important
7953 to preserve the typedef layer.
7955 Otherwise, we might be transforming a typedef to a fat
7956 pointer (encoding a pointer to an unconstrained array),
7957 into a basic fat pointer (encoding an unconstrained
7958 array). As both types are implemented using the same
7959 structure, the typedef is the only clue which allows us
7960 to distinguish between the two options. Stripping it
7961 would prevent us from printing this field appropriately. */
7962 rtype
->field (f
).set_type (type
->field (f
).type ());
7963 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7964 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7966 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7969 struct type
*field_type
= type
->field (f
).type ();
7971 /* We need to be careful of typedefs when computing
7972 the length of our field. If this is a typedef,
7973 get the length of the target type, not the length
7975 if (field_type
->code () == TYPE_CODE_TYPEDEF
)
7976 field_type
= ada_typedef_target_type (field_type
);
7979 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
7982 if (off
+ fld_bit_len
> bit_len
)
7983 bit_len
= off
+ fld_bit_len
;
7985 TYPE_LENGTH (rtype
) =
7986 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7989 /* We handle the variant part, if any, at the end because of certain
7990 odd cases in which it is re-ordered so as NOT to be the last field of
7991 the record. This can happen in the presence of representation
7993 if (variant_field
>= 0)
7995 struct type
*branch_type
;
7997 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8001 /* Using plain value_from_contents_and_address here causes
8002 problems because we will end up trying to resolve a type
8003 that is currently being constructed. */
8004 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8006 rtype
= value_type (dval
);
8012 to_fixed_variant_branch_type
8013 (type
->field (variant_field
).type (),
8014 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8015 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8016 if (branch_type
== NULL
)
8018 for (f
= variant_field
+ 1; f
< rtype
->num_fields (); f
+= 1)
8019 rtype
->field (f
- 1) = rtype
->field (f
);
8020 rtype
->set_num_fields (rtype
->num_fields () - 1);
8024 rtype
->field (variant_field
).set_type (branch_type
);
8025 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8027 TYPE_LENGTH (rtype
->field (variant_field
).type ()) *
8029 if (off
+ fld_bit_len
> bit_len
)
8030 bit_len
= off
+ fld_bit_len
;
8031 TYPE_LENGTH (rtype
) =
8032 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8036 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8037 should contain the alignment of that record, which should be a strictly
8038 positive value. If null or negative, then something is wrong, most
8039 probably in the debug info. In that case, we don't round up the size
8040 of the resulting type. If this record is not part of another structure,
8041 the current RTYPE length might be good enough for our purposes. */
8042 if (TYPE_LENGTH (type
) <= 0)
8045 warning (_("Invalid type size for `%s' detected: %s."),
8046 rtype
->name (), pulongest (TYPE_LENGTH (type
)));
8048 warning (_("Invalid type size for <unnamed> detected: %s."),
8049 pulongest (TYPE_LENGTH (type
)));
8053 TYPE_LENGTH (rtype
) = align_up (TYPE_LENGTH (rtype
),
8054 TYPE_LENGTH (type
));
8057 value_free_to_mark (mark
);
8058 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8059 error (_("record type with dynamic size is larger than varsize-limit"));
8063 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8066 static struct type
*
8067 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8068 CORE_ADDR address
, struct value
*dval0
)
8070 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8074 /* An ordinary record type in which ___XVL-convention fields and
8075 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8076 static approximations, containing all possible fields. Uses
8077 no runtime values. Useless for use in values, but that's OK,
8078 since the results are used only for type determinations. Works on both
8079 structs and unions. Representation note: to save space, we memorize
8080 the result of this function in the TYPE_TARGET_TYPE of the
8083 static struct type
*
8084 template_to_static_fixed_type (struct type
*type0
)
8090 /* No need no do anything if the input type is already fixed. */
8091 if (TYPE_FIXED_INSTANCE (type0
))
8094 /* Likewise if we already have computed the static approximation. */
8095 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8096 return TYPE_TARGET_TYPE (type0
);
8098 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8100 nfields
= type0
->num_fields ();
8102 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8103 recompute all over next time. */
8104 TYPE_TARGET_TYPE (type0
) = type
;
8106 for (f
= 0; f
< nfields
; f
+= 1)
8108 struct type
*field_type
= type0
->field (f
).type ();
8109 struct type
*new_type
;
8111 if (is_dynamic_field (type0
, f
))
8113 field_type
= ada_check_typedef (field_type
);
8114 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8117 new_type
= static_unwrap_type (field_type
);
8119 if (new_type
!= field_type
)
8121 /* Clone TYPE0 only the first time we get a new field type. */
8124 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8125 type
->set_code (type0
->code ());
8126 INIT_NONE_SPECIFIC (type
);
8127 type
->set_num_fields (nfields
);
8131 TYPE_ALLOC (type
, nfields
* sizeof (struct field
)));
8132 memcpy (fields
, type0
->fields (),
8133 sizeof (struct field
) * nfields
);
8134 type
->set_fields (fields
);
8136 type
->set_name (ada_type_name (type0
));
8137 TYPE_FIXED_INSTANCE (type
) = 1;
8138 TYPE_LENGTH (type
) = 0;
8140 type
->field (f
).set_type (new_type
);
8141 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8148 /* Given an object of type TYPE whose contents are at VALADDR and
8149 whose address in memory is ADDRESS, returns a revision of TYPE,
8150 which should be a non-dynamic-sized record, in which the variant
8151 part, if any, is replaced with the appropriate branch. Looks
8152 for discriminant values in DVAL0, which can be NULL if the record
8153 contains the necessary discriminant values. */
8155 static struct type
*
8156 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8157 CORE_ADDR address
, struct value
*dval0
)
8159 struct value
*mark
= value_mark ();
8162 struct type
*branch_type
;
8163 int nfields
= type
->num_fields ();
8164 int variant_field
= variant_field_index (type
);
8166 if (variant_field
== -1)
8171 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8172 type
= value_type (dval
);
8177 rtype
= alloc_type_copy (type
);
8178 rtype
->set_code (TYPE_CODE_STRUCT
);
8179 INIT_NONE_SPECIFIC (rtype
);
8180 rtype
->set_num_fields (nfields
);
8183 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8184 memcpy (fields
, type
->fields (), sizeof (struct field
) * nfields
);
8185 rtype
->set_fields (fields
);
8187 rtype
->set_name (ada_type_name (type
));
8188 TYPE_FIXED_INSTANCE (rtype
) = 1;
8189 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8191 branch_type
= to_fixed_variant_branch_type
8192 (type
->field (variant_field
).type (),
8193 cond_offset_host (valaddr
,
8194 TYPE_FIELD_BITPOS (type
, variant_field
)
8196 cond_offset_target (address
,
8197 TYPE_FIELD_BITPOS (type
, variant_field
)
8198 / TARGET_CHAR_BIT
), dval
);
8199 if (branch_type
== NULL
)
8203 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8204 rtype
->field (f
- 1) = rtype
->field (f
);
8205 rtype
->set_num_fields (rtype
->num_fields () - 1);
8209 rtype
->field (variant_field
).set_type (branch_type
);
8210 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8211 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8212 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8214 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (type
->field (variant_field
).type ());
8216 value_free_to_mark (mark
);
8220 /* An ordinary record type (with fixed-length fields) that describes
8221 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8222 beginning of this section]. Any necessary discriminants' values
8223 should be in DVAL, a record value; it may be NULL if the object
8224 at ADDR itself contains any necessary discriminant values.
8225 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8226 values from the record are needed. Except in the case that DVAL,
8227 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8228 unchecked) is replaced by a particular branch of the variant.
8230 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8231 is questionable and may be removed. It can arise during the
8232 processing of an unconstrained-array-of-record type where all the
8233 variant branches have exactly the same size. This is because in
8234 such cases, the compiler does not bother to use the XVS convention
8235 when encoding the record. I am currently dubious of this
8236 shortcut and suspect the compiler should be altered. FIXME. */
8238 static struct type
*
8239 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8240 CORE_ADDR address
, struct value
*dval
)
8242 struct type
*templ_type
;
8244 if (TYPE_FIXED_INSTANCE (type0
))
8247 templ_type
= dynamic_template_type (type0
);
8249 if (templ_type
!= NULL
)
8250 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8251 else if (variant_field_index (type0
) >= 0)
8253 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8255 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8260 TYPE_FIXED_INSTANCE (type0
) = 1;
8266 /* An ordinary record type (with fixed-length fields) that describes
8267 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8268 union type. Any necessary discriminants' values should be in DVAL,
8269 a record value. That is, this routine selects the appropriate
8270 branch of the union at ADDR according to the discriminant value
8271 indicated in the union's type name. Returns VAR_TYPE0 itself if
8272 it represents a variant subject to a pragma Unchecked_Union. */
8274 static struct type
*
8275 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8276 CORE_ADDR address
, struct value
*dval
)
8279 struct type
*templ_type
;
8280 struct type
*var_type
;
8282 if (var_type0
->code () == TYPE_CODE_PTR
)
8283 var_type
= TYPE_TARGET_TYPE (var_type0
);
8285 var_type
= var_type0
;
8287 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8289 if (templ_type
!= NULL
)
8290 var_type
= templ_type
;
8292 if (is_unchecked_variant (var_type
, value_type (dval
)))
8294 which
= ada_which_variant_applies (var_type
, dval
);
8297 return empty_record (var_type
);
8298 else if (is_dynamic_field (var_type
, which
))
8299 return to_fixed_record_type
8300 (TYPE_TARGET_TYPE (var_type
->field (which
).type ()),
8301 valaddr
, address
, dval
);
8302 else if (variant_field_index (var_type
->field (which
).type ()) >= 0)
8304 to_fixed_record_type
8305 (var_type
->field (which
).type (), valaddr
, address
, dval
);
8307 return var_type
->field (which
).type ();
8310 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8311 ENCODING_TYPE, a type following the GNAT conventions for discrete
8312 type encodings, only carries redundant information. */
8315 ada_is_redundant_range_encoding (struct type
*range_type
,
8316 struct type
*encoding_type
)
8318 const char *bounds_str
;
8322 gdb_assert (range_type
->code () == TYPE_CODE_RANGE
);
8324 if (get_base_type (range_type
)->code ()
8325 != get_base_type (encoding_type
)->code ())
8327 /* The compiler probably used a simple base type to describe
8328 the range type instead of the range's actual base type,
8329 expecting us to get the real base type from the encoding
8330 anyway. In this situation, the encoding cannot be ignored
8335 if (is_dynamic_type (range_type
))
8338 if (encoding_type
->name () == NULL
)
8341 bounds_str
= strstr (encoding_type
->name (), "___XDLU_");
8342 if (bounds_str
== NULL
)
8345 n
= 8; /* Skip "___XDLU_". */
8346 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8348 if (TYPE_LOW_BOUND (range_type
) != lo
)
8351 n
+= 2; /* Skip the "__" separator between the two bounds. */
8352 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8354 if (TYPE_HIGH_BOUND (range_type
) != hi
)
8360 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8361 a type following the GNAT encoding for describing array type
8362 indices, only carries redundant information. */
8365 ada_is_redundant_index_type_desc (struct type
*array_type
,
8366 struct type
*desc_type
)
8368 struct type
*this_layer
= check_typedef (array_type
);
8371 for (i
= 0; i
< desc_type
->num_fields (); i
++)
8373 if (!ada_is_redundant_range_encoding (this_layer
->index_type (),
8374 desc_type
->field (i
).type ()))
8376 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8382 /* Assuming that TYPE0 is an array type describing the type of a value
8383 at ADDR, and that DVAL describes a record containing any
8384 discriminants used in TYPE0, returns a type for the value that
8385 contains no dynamic components (that is, no components whose sizes
8386 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8387 true, gives an error message if the resulting type's size is over
8390 static struct type
*
8391 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8394 struct type
*index_type_desc
;
8395 struct type
*result
;
8396 int constrained_packed_array_p
;
8397 static const char *xa_suffix
= "___XA";
8399 type0
= ada_check_typedef (type0
);
8400 if (TYPE_FIXED_INSTANCE (type0
))
8403 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8404 if (constrained_packed_array_p
)
8405 type0
= decode_constrained_packed_array_type (type0
);
8407 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8409 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8410 encoding suffixed with 'P' may still be generated. If so,
8411 it should be used to find the XA type. */
8413 if (index_type_desc
== NULL
)
8415 const char *type_name
= ada_type_name (type0
);
8417 if (type_name
!= NULL
)
8419 const int len
= strlen (type_name
);
8420 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8422 if (type_name
[len
- 1] == 'P')
8424 strcpy (name
, type_name
);
8425 strcpy (name
+ len
- 1, xa_suffix
);
8426 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8431 ada_fixup_array_indexes_type (index_type_desc
);
8432 if (index_type_desc
!= NULL
8433 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8435 /* Ignore this ___XA parallel type, as it does not bring any
8436 useful information. This allows us to avoid creating fixed
8437 versions of the array's index types, which would be identical
8438 to the original ones. This, in turn, can also help avoid
8439 the creation of fixed versions of the array itself. */
8440 index_type_desc
= NULL
;
8443 if (index_type_desc
== NULL
)
8445 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8447 /* NOTE: elt_type---the fixed version of elt_type0---should never
8448 depend on the contents of the array in properly constructed
8450 /* Create a fixed version of the array element type.
8451 We're not providing the address of an element here,
8452 and thus the actual object value cannot be inspected to do
8453 the conversion. This should not be a problem, since arrays of
8454 unconstrained objects are not allowed. In particular, all
8455 the elements of an array of a tagged type should all be of
8456 the same type specified in the debugging info. No need to
8457 consult the object tag. */
8458 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8460 /* Make sure we always create a new array type when dealing with
8461 packed array types, since we're going to fix-up the array
8462 type length and element bitsize a little further down. */
8463 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8466 result
= create_array_type (alloc_type_copy (type0
),
8467 elt_type
, type0
->index_type ());
8472 struct type
*elt_type0
;
8475 for (i
= index_type_desc
->num_fields (); i
> 0; i
-= 1)
8476 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8478 /* NOTE: result---the fixed version of elt_type0---should never
8479 depend on the contents of the array in properly constructed
8481 /* Create a fixed version of the array element type.
8482 We're not providing the address of an element here,
8483 and thus the actual object value cannot be inspected to do
8484 the conversion. This should not be a problem, since arrays of
8485 unconstrained objects are not allowed. In particular, all
8486 the elements of an array of a tagged type should all be of
8487 the same type specified in the debugging info. No need to
8488 consult the object tag. */
8490 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8493 for (i
= index_type_desc
->num_fields () - 1; i
>= 0; i
-= 1)
8495 struct type
*range_type
=
8496 to_fixed_range_type (index_type_desc
->field (i
).type (), dval
);
8498 result
= create_array_type (alloc_type_copy (elt_type0
),
8499 result
, range_type
);
8500 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8502 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8503 error (_("array type with dynamic size is larger than varsize-limit"));
8506 /* We want to preserve the type name. This can be useful when
8507 trying to get the type name of a value that has already been
8508 printed (for instance, if the user did "print VAR; whatis $". */
8509 result
->set_name (type0
->name ());
8511 if (constrained_packed_array_p
)
8513 /* So far, the resulting type has been created as if the original
8514 type was a regular (non-packed) array type. As a result, the
8515 bitsize of the array elements needs to be set again, and the array
8516 length needs to be recomputed based on that bitsize. */
8517 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8518 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8520 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8521 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8522 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8523 TYPE_LENGTH (result
)++;
8526 TYPE_FIXED_INSTANCE (result
) = 1;
8531 /* A standard type (containing no dynamically sized components)
8532 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8533 DVAL describes a record containing any discriminants used in TYPE0,
8534 and may be NULL if there are none, or if the object of type TYPE at
8535 ADDRESS or in VALADDR contains these discriminants.
8537 If CHECK_TAG is not null, in the case of tagged types, this function
8538 attempts to locate the object's tag and use it to compute the actual
8539 type. However, when ADDRESS is null, we cannot use it to determine the
8540 location of the tag, and therefore compute the tagged type's actual type.
8541 So we return the tagged type without consulting the tag. */
8543 static struct type
*
8544 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8545 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8547 type
= ada_check_typedef (type
);
8549 /* Only un-fixed types need to be handled here. */
8550 if (!HAVE_GNAT_AUX_INFO (type
))
8553 switch (type
->code ())
8557 case TYPE_CODE_STRUCT
:
8559 struct type
*static_type
= to_static_fixed_type (type
);
8560 struct type
*fixed_record_type
=
8561 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8563 /* If STATIC_TYPE is a tagged type and we know the object's address,
8564 then we can determine its tag, and compute the object's actual
8565 type from there. Note that we have to use the fixed record
8566 type (the parent part of the record may have dynamic fields
8567 and the way the location of _tag is expressed may depend on
8570 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8573 value_tag_from_contents_and_address
8577 struct type
*real_type
= type_from_tag (tag
);
8579 value_from_contents_and_address (fixed_record_type
,
8582 fixed_record_type
= value_type (obj
);
8583 if (real_type
!= NULL
)
8584 return to_fixed_record_type
8586 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8589 /* Check to see if there is a parallel ___XVZ variable.
8590 If there is, then it provides the actual size of our type. */
8591 else if (ada_type_name (fixed_record_type
) != NULL
)
8593 const char *name
= ada_type_name (fixed_record_type
);
8595 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8596 bool xvz_found
= false;
8599 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8602 xvz_found
= get_int_var_value (xvz_name
, size
);
8604 catch (const gdb_exception_error
&except
)
8606 /* We found the variable, but somehow failed to read
8607 its value. Rethrow the same error, but with a little
8608 bit more information, to help the user understand
8609 what went wrong (Eg: the variable might have been
8611 throw_error (except
.error
,
8612 _("unable to read value of %s (%s)"),
8613 xvz_name
, except
.what ());
8616 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8618 fixed_record_type
= copy_type (fixed_record_type
);
8619 TYPE_LENGTH (fixed_record_type
) = size
;
8621 /* The FIXED_RECORD_TYPE may have be a stub. We have
8622 observed this when the debugging info is STABS, and
8623 apparently it is something that is hard to fix.
8625 In practice, we don't need the actual type definition
8626 at all, because the presence of the XVZ variable allows us
8627 to assume that there must be a XVS type as well, which we
8628 should be able to use later, when we need the actual type
8631 In the meantime, pretend that the "fixed" type we are
8632 returning is NOT a stub, because this can cause trouble
8633 when using this type to create new types targeting it.
8634 Indeed, the associated creation routines often check
8635 whether the target type is a stub and will try to replace
8636 it, thus using a type with the wrong size. This, in turn,
8637 might cause the new type to have the wrong size too.
8638 Consider the case of an array, for instance, where the size
8639 of the array is computed from the number of elements in
8640 our array multiplied by the size of its element. */
8641 TYPE_STUB (fixed_record_type
) = 0;
8644 return fixed_record_type
;
8646 case TYPE_CODE_ARRAY
:
8647 return to_fixed_array_type (type
, dval
, 1);
8648 case TYPE_CODE_UNION
:
8652 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8656 /* The same as ada_to_fixed_type_1, except that it preserves the type
8657 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8659 The typedef layer needs be preserved in order to differentiate between
8660 arrays and array pointers when both types are implemented using the same
8661 fat pointer. In the array pointer case, the pointer is encoded as
8662 a typedef of the pointer type. For instance, considering:
8664 type String_Access is access String;
8665 S1 : String_Access := null;
8667 To the debugger, S1 is defined as a typedef of type String. But
8668 to the user, it is a pointer. So if the user tries to print S1,
8669 we should not dereference the array, but print the array address
8672 If we didn't preserve the typedef layer, we would lose the fact that
8673 the type is to be presented as a pointer (needs de-reference before
8674 being printed). And we would also use the source-level type name. */
8677 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8678 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8681 struct type
*fixed_type
=
8682 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8684 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8685 then preserve the typedef layer.
8687 Implementation note: We can only check the main-type portion of
8688 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8689 from TYPE now returns a type that has the same instance flags
8690 as TYPE. For instance, if TYPE is a "typedef const", and its
8691 target type is a "struct", then the typedef elimination will return
8692 a "const" version of the target type. See check_typedef for more
8693 details about how the typedef layer elimination is done.
8695 brobecker/2010-11-19: It seems to me that the only case where it is
8696 useful to preserve the typedef layer is when dealing with fat pointers.
8697 Perhaps, we could add a check for that and preserve the typedef layer
8698 only in that situation. But this seems unnecessary so far, probably
8699 because we call check_typedef/ada_check_typedef pretty much everywhere.
8701 if (type
->code () == TYPE_CODE_TYPEDEF
8702 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8703 == TYPE_MAIN_TYPE (fixed_type
)))
8709 /* A standard (static-sized) type corresponding as well as possible to
8710 TYPE0, but based on no runtime data. */
8712 static struct type
*
8713 to_static_fixed_type (struct type
*type0
)
8720 if (TYPE_FIXED_INSTANCE (type0
))
8723 type0
= ada_check_typedef (type0
);
8725 switch (type0
->code ())
8729 case TYPE_CODE_STRUCT
:
8730 type
= dynamic_template_type (type0
);
8732 return template_to_static_fixed_type (type
);
8734 return template_to_static_fixed_type (type0
);
8735 case TYPE_CODE_UNION
:
8736 type
= ada_find_parallel_type (type0
, "___XVU");
8738 return template_to_static_fixed_type (type
);
8740 return template_to_static_fixed_type (type0
);
8744 /* A static approximation of TYPE with all type wrappers removed. */
8746 static struct type
*
8747 static_unwrap_type (struct type
*type
)
8749 if (ada_is_aligner_type (type
))
8751 struct type
*type1
= ada_check_typedef (type
)->field (0).type ();
8752 if (ada_type_name (type1
) == NULL
)
8753 type1
->set_name (ada_type_name (type
));
8755 return static_unwrap_type (type1
);
8759 struct type
*raw_real_type
= ada_get_base_type (type
);
8761 if (raw_real_type
== type
)
8764 return to_static_fixed_type (raw_real_type
);
8768 /* In some cases, incomplete and private types require
8769 cross-references that are not resolved as records (for example,
8771 type FooP is access Foo;
8773 type Foo is array ...;
8774 ). In these cases, since there is no mechanism for producing
8775 cross-references to such types, we instead substitute for FooP a
8776 stub enumeration type that is nowhere resolved, and whose tag is
8777 the name of the actual type. Call these types "non-record stubs". */
8779 /* A type equivalent to TYPE that is not a non-record stub, if one
8780 exists, otherwise TYPE. */
8783 ada_check_typedef (struct type
*type
)
8788 /* If our type is an access to an unconstrained array, which is encoded
8789 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8790 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8791 what allows us to distinguish between fat pointers that represent
8792 array types, and fat pointers that represent array access types
8793 (in both cases, the compiler implements them as fat pointers). */
8794 if (ada_is_access_to_unconstrained_array (type
))
8797 type
= check_typedef (type
);
8798 if (type
== NULL
|| type
->code () != TYPE_CODE_ENUM
8799 || !TYPE_STUB (type
)
8800 || type
->name () == NULL
)
8804 const char *name
= type
->name ();
8805 struct type
*type1
= ada_find_any_type (name
);
8810 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8811 stubs pointing to arrays, as we don't create symbols for array
8812 types, only for the typedef-to-array types). If that's the case,
8813 strip the typedef layer. */
8814 if (type1
->code () == TYPE_CODE_TYPEDEF
)
8815 type1
= ada_check_typedef (type1
);
8821 /* A value representing the data at VALADDR/ADDRESS as described by
8822 type TYPE0, but with a standard (static-sized) type that correctly
8823 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8824 type, then return VAL0 [this feature is simply to avoid redundant
8825 creation of struct values]. */
8827 static struct value
*
8828 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8831 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8833 if (type
== type0
&& val0
!= NULL
)
8836 if (VALUE_LVAL (val0
) != lval_memory
)
8838 /* Our value does not live in memory; it could be a convenience
8839 variable, for instance. Create a not_lval value using val0's
8841 return value_from_contents (type
, value_contents (val0
));
8844 return value_from_contents_and_address (type
, 0, address
);
8847 /* A value representing VAL, but with a standard (static-sized) type
8848 that correctly describes it. Does not necessarily create a new
8852 ada_to_fixed_value (struct value
*val
)
8854 val
= unwrap_value (val
);
8855 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
8862 /* Table mapping attribute numbers to names.
8863 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8865 static const char *attribute_names
[] = {
8883 ada_attribute_name (enum exp_opcode n
)
8885 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8886 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8888 return attribute_names
[0];
8891 /* Evaluate the 'POS attribute applied to ARG. */
8894 pos_atr (struct value
*arg
)
8896 struct value
*val
= coerce_ref (arg
);
8897 struct type
*type
= value_type (val
);
8900 if (!discrete_type_p (type
))
8901 error (_("'POS only defined on discrete types"));
8903 if (!discrete_position (type
, value_as_long (val
), &result
))
8904 error (_("enumeration value is invalid: can't find 'POS"));
8909 static struct value
*
8910 value_pos_atr (struct type
*type
, struct value
*arg
)
8912 return value_from_longest (type
, pos_atr (arg
));
8915 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8917 static struct value
*
8918 val_atr (struct type
*type
, LONGEST val
)
8920 gdb_assert (discrete_type_p (type
));
8921 if (type
->code () == TYPE_CODE_RANGE
)
8922 type
= TYPE_TARGET_TYPE (type
);
8923 if (type
->code () == TYPE_CODE_ENUM
)
8925 if (val
< 0 || val
>= type
->num_fields ())
8926 error (_("argument to 'VAL out of range"));
8927 val
= TYPE_FIELD_ENUMVAL (type
, val
);
8929 return value_from_longest (type
, val
);
8932 static struct value
*
8933 value_val_atr (struct type
*type
, struct value
*arg
)
8935 if (!discrete_type_p (type
))
8936 error (_("'VAL only defined on discrete types"));
8937 if (!integer_type_p (value_type (arg
)))
8938 error (_("'VAL requires integral argument"));
8940 return val_atr (type
, value_as_long (arg
));
8946 /* True if TYPE appears to be an Ada character type.
8947 [At the moment, this is true only for Character and Wide_Character;
8948 It is a heuristic test that could stand improvement]. */
8951 ada_is_character_type (struct type
*type
)
8955 /* If the type code says it's a character, then assume it really is,
8956 and don't check any further. */
8957 if (type
->code () == TYPE_CODE_CHAR
)
8960 /* Otherwise, assume it's a character type iff it is a discrete type
8961 with a known character type name. */
8962 name
= ada_type_name (type
);
8963 return (name
!= NULL
8964 && (type
->code () == TYPE_CODE_INT
8965 || type
->code () == TYPE_CODE_RANGE
)
8966 && (strcmp (name
, "character") == 0
8967 || strcmp (name
, "wide_character") == 0
8968 || strcmp (name
, "wide_wide_character") == 0
8969 || strcmp (name
, "unsigned char") == 0));
8972 /* True if TYPE appears to be an Ada string type. */
8975 ada_is_string_type (struct type
*type
)
8977 type
= ada_check_typedef (type
);
8979 && type
->code () != TYPE_CODE_PTR
8980 && (ada_is_simple_array_type (type
)
8981 || ada_is_array_descriptor_type (type
))
8982 && ada_array_arity (type
) == 1)
8984 struct type
*elttype
= ada_array_element_type (type
, 1);
8986 return ada_is_character_type (elttype
);
8992 /* The compiler sometimes provides a parallel XVS type for a given
8993 PAD type. Normally, it is safe to follow the PAD type directly,
8994 but older versions of the compiler have a bug that causes the offset
8995 of its "F" field to be wrong. Following that field in that case
8996 would lead to incorrect results, but this can be worked around
8997 by ignoring the PAD type and using the associated XVS type instead.
8999 Set to True if the debugger should trust the contents of PAD types.
9000 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9001 static bool trust_pad_over_xvs
= true;
9003 /* True if TYPE is a struct type introduced by the compiler to force the
9004 alignment of a value. Such types have a single field with a
9005 distinctive name. */
9008 ada_is_aligner_type (struct type
*type
)
9010 type
= ada_check_typedef (type
);
9012 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9015 return (type
->code () == TYPE_CODE_STRUCT
9016 && type
->num_fields () == 1
9017 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9020 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9021 the parallel type. */
9024 ada_get_base_type (struct type
*raw_type
)
9026 struct type
*real_type_namer
;
9027 struct type
*raw_real_type
;
9029 if (raw_type
== NULL
|| raw_type
->code () != TYPE_CODE_STRUCT
)
9032 if (ada_is_aligner_type (raw_type
))
9033 /* The encoding specifies that we should always use the aligner type.
9034 So, even if this aligner type has an associated XVS type, we should
9037 According to the compiler gurus, an XVS type parallel to an aligner
9038 type may exist because of a stabs limitation. In stabs, aligner
9039 types are empty because the field has a variable-sized type, and
9040 thus cannot actually be used as an aligner type. As a result,
9041 we need the associated parallel XVS type to decode the type.
9042 Since the policy in the compiler is to not change the internal
9043 representation based on the debugging info format, we sometimes
9044 end up having a redundant XVS type parallel to the aligner type. */
9047 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9048 if (real_type_namer
== NULL
9049 || real_type_namer
->code () != TYPE_CODE_STRUCT
9050 || real_type_namer
->num_fields () != 1)
9053 if (real_type_namer
->field (0).type ()->code () != TYPE_CODE_REF
)
9055 /* This is an older encoding form where the base type needs to be
9056 looked up by name. We prefer the newer encoding because it is
9058 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9059 if (raw_real_type
== NULL
)
9062 return raw_real_type
;
9065 /* The field in our XVS type is a reference to the base type. */
9066 return TYPE_TARGET_TYPE (real_type_namer
->field (0).type ());
9069 /* The type of value designated by TYPE, with all aligners removed. */
9072 ada_aligned_type (struct type
*type
)
9074 if (ada_is_aligner_type (type
))
9075 return ada_aligned_type (type
->field (0).type ());
9077 return ada_get_base_type (type
);
9081 /* The address of the aligned value in an object at address VALADDR
9082 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9085 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9087 if (ada_is_aligner_type (type
))
9088 return ada_aligned_value_addr (type
->field (0).type (),
9090 TYPE_FIELD_BITPOS (type
,
9091 0) / TARGET_CHAR_BIT
);
9098 /* The printed representation of an enumeration literal with encoded
9099 name NAME. The value is good to the next call of ada_enum_name. */
9101 ada_enum_name (const char *name
)
9103 static char *result
;
9104 static size_t result_len
= 0;
9107 /* First, unqualify the enumeration name:
9108 1. Search for the last '.' character. If we find one, then skip
9109 all the preceding characters, the unqualified name starts
9110 right after that dot.
9111 2. Otherwise, we may be debugging on a target where the compiler
9112 translates dots into "__". Search forward for double underscores,
9113 but stop searching when we hit an overloading suffix, which is
9114 of the form "__" followed by digits. */
9116 tmp
= strrchr (name
, '.');
9121 while ((tmp
= strstr (name
, "__")) != NULL
)
9123 if (isdigit (tmp
[2]))
9134 if (name
[1] == 'U' || name
[1] == 'W')
9136 if (sscanf (name
+ 2, "%x", &v
) != 1)
9139 else if (((name
[1] >= '0' && name
[1] <= '9')
9140 || (name
[1] >= 'a' && name
[1] <= 'z'))
9143 GROW_VECT (result
, result_len
, 4);
9144 xsnprintf (result
, result_len
, "'%c'", name
[1]);
9150 GROW_VECT (result
, result_len
, 16);
9151 if (isascii (v
) && isprint (v
))
9152 xsnprintf (result
, result_len
, "'%c'", v
);
9153 else if (name
[1] == 'U')
9154 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9156 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9162 tmp
= strstr (name
, "__");
9164 tmp
= strstr (name
, "$");
9167 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9168 strncpy (result
, name
, tmp
- name
);
9169 result
[tmp
- name
] = '\0';
9177 /* Evaluate the subexpression of EXP starting at *POS as for
9178 evaluate_type, updating *POS to point just past the evaluated
9181 static struct value
*
9182 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9184 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9187 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9190 static struct value
*
9191 unwrap_value (struct value
*val
)
9193 struct type
*type
= ada_check_typedef (value_type (val
));
9195 if (ada_is_aligner_type (type
))
9197 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9198 struct type
*val_type
= ada_check_typedef (value_type (v
));
9200 if (ada_type_name (val_type
) == NULL
)
9201 val_type
->set_name (ada_type_name (type
));
9203 return unwrap_value (v
);
9207 struct type
*raw_real_type
=
9208 ada_check_typedef (ada_get_base_type (type
));
9210 /* If there is no parallel XVS or XVE type, then the value is
9211 already unwrapped. Return it without further modification. */
9212 if ((type
== raw_real_type
)
9213 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9217 coerce_unspec_val_to_type
9218 (val
, ada_to_fixed_type (raw_real_type
, 0,
9219 value_address (val
),
9224 static struct value
*
9225 cast_from_fixed (struct type
*type
, struct value
*arg
)
9227 struct value
*scale
= ada_scaling_factor (value_type (arg
));
9228 arg
= value_cast (value_type (scale
), arg
);
9230 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9231 return value_cast (type
, arg
);
9234 static struct value
*
9235 cast_to_fixed (struct type
*type
, struct value
*arg
)
9237 if (type
== value_type (arg
))
9240 struct value
*scale
= ada_scaling_factor (type
);
9241 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg
)))
9242 arg
= cast_from_fixed (value_type (scale
), arg
);
9244 arg
= value_cast (value_type (scale
), arg
);
9246 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9247 return value_cast (type
, arg
);
9250 /* Given two array types T1 and T2, return nonzero iff both arrays
9251 contain the same number of elements. */
9254 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9256 LONGEST lo1
, hi1
, lo2
, hi2
;
9258 /* Get the array bounds in order to verify that the size of
9259 the two arrays match. */
9260 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9261 || !get_array_bounds (t2
, &lo2
, &hi2
))
9262 error (_("unable to determine array bounds"));
9264 /* To make things easier for size comparison, normalize a bit
9265 the case of empty arrays by making sure that the difference
9266 between upper bound and lower bound is always -1. */
9272 return (hi1
- lo1
== hi2
- lo2
);
9275 /* Assuming that VAL is an array of integrals, and TYPE represents
9276 an array with the same number of elements, but with wider integral
9277 elements, return an array "casted" to TYPE. In practice, this
9278 means that the returned array is built by casting each element
9279 of the original array into TYPE's (wider) element type. */
9281 static struct value
*
9282 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9284 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9289 /* Verify that both val and type are arrays of scalars, and
9290 that the size of val's elements is smaller than the size
9291 of type's element. */
9292 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
9293 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9294 gdb_assert (value_type (val
)->code () == TYPE_CODE_ARRAY
);
9295 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9296 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9297 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9299 if (!get_array_bounds (type
, &lo
, &hi
))
9300 error (_("unable to determine array bounds"));
9302 res
= allocate_value (type
);
9304 /* Promote each array element. */
9305 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9307 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9309 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9310 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9316 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9317 return the converted value. */
9319 static struct value
*
9320 coerce_for_assign (struct type
*type
, struct value
*val
)
9322 struct type
*type2
= value_type (val
);
9327 type2
= ada_check_typedef (type2
);
9328 type
= ada_check_typedef (type
);
9330 if (type2
->code () == TYPE_CODE_PTR
9331 && type
->code () == TYPE_CODE_ARRAY
)
9333 val
= ada_value_ind (val
);
9334 type2
= value_type (val
);
9337 if (type2
->code () == TYPE_CODE_ARRAY
9338 && type
->code () == TYPE_CODE_ARRAY
)
9340 if (!ada_same_array_size_p (type
, type2
))
9341 error (_("cannot assign arrays of different length"));
9343 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9344 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9345 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9346 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9348 /* Allow implicit promotion of the array elements to
9350 return ada_promote_array_of_integrals (type
, val
);
9353 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9354 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9355 error (_("Incompatible types in assignment"));
9356 deprecated_set_value_type (val
, type
);
9361 static struct value
*
9362 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9365 struct type
*type1
, *type2
;
9368 arg1
= coerce_ref (arg1
);
9369 arg2
= coerce_ref (arg2
);
9370 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9371 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9373 if (type1
->code () != TYPE_CODE_INT
9374 || type2
->code () != TYPE_CODE_INT
)
9375 return value_binop (arg1
, arg2
, op
);
9384 return value_binop (arg1
, arg2
, op
);
9387 v2
= value_as_long (arg2
);
9389 error (_("second operand of %s must not be zero."), op_string (op
));
9391 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
9392 return value_binop (arg1
, arg2
, op
);
9394 v1
= value_as_long (arg1
);
9399 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9400 v
+= v
> 0 ? -1 : 1;
9408 /* Should not reach this point. */
9412 val
= allocate_value (type1
);
9413 store_unsigned_integer (value_contents_raw (val
),
9414 TYPE_LENGTH (value_type (val
)),
9415 type_byte_order (type1
), v
);
9420 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9422 if (ada_is_direct_array_type (value_type (arg1
))
9423 || ada_is_direct_array_type (value_type (arg2
)))
9425 struct type
*arg1_type
, *arg2_type
;
9427 /* Automatically dereference any array reference before
9428 we attempt to perform the comparison. */
9429 arg1
= ada_coerce_ref (arg1
);
9430 arg2
= ada_coerce_ref (arg2
);
9432 arg1
= ada_coerce_to_simple_array (arg1
);
9433 arg2
= ada_coerce_to_simple_array (arg2
);
9435 arg1_type
= ada_check_typedef (value_type (arg1
));
9436 arg2_type
= ada_check_typedef (value_type (arg2
));
9438 if (arg1_type
->code () != TYPE_CODE_ARRAY
9439 || arg2_type
->code () != TYPE_CODE_ARRAY
)
9440 error (_("Attempt to compare array with non-array"));
9441 /* FIXME: The following works only for types whose
9442 representations use all bits (no padding or undefined bits)
9443 and do not have user-defined equality. */
9444 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9445 && memcmp (value_contents (arg1
), value_contents (arg2
),
9446 TYPE_LENGTH (arg1_type
)) == 0);
9448 return value_equal (arg1
, arg2
);
9451 /* Total number of component associations in the aggregate starting at
9452 index PC in EXP. Assumes that index PC is the start of an
9456 num_component_specs (struct expression
*exp
, int pc
)
9460 m
= exp
->elts
[pc
+ 1].longconst
;
9463 for (i
= 0; i
< m
; i
+= 1)
9465 switch (exp
->elts
[pc
].opcode
)
9471 n
+= exp
->elts
[pc
+ 1].longconst
;
9474 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9479 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9480 component of LHS (a simple array or a record), updating *POS past
9481 the expression, assuming that LHS is contained in CONTAINER. Does
9482 not modify the inferior's memory, nor does it modify LHS (unless
9483 LHS == CONTAINER). */
9486 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9487 struct expression
*exp
, int *pos
)
9489 struct value
*mark
= value_mark ();
9491 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9493 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
9495 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9496 struct value
*index_val
= value_from_longest (index_type
, index
);
9498 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9502 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9503 elt
= ada_to_fixed_value (elt
);
9506 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9507 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9509 value_assign_to_component (container
, elt
,
9510 ada_evaluate_subexp (NULL
, exp
, pos
,
9513 value_free_to_mark (mark
);
9516 /* Assuming that LHS represents an lvalue having a record or array
9517 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9518 of that aggregate's value to LHS, advancing *POS past the
9519 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9520 lvalue containing LHS (possibly LHS itself). Does not modify
9521 the inferior's memory, nor does it modify the contents of
9522 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9524 static struct value
*
9525 assign_aggregate (struct value
*container
,
9526 struct value
*lhs
, struct expression
*exp
,
9527 int *pos
, enum noside noside
)
9529 struct type
*lhs_type
;
9530 int n
= exp
->elts
[*pos
+1].longconst
;
9531 LONGEST low_index
, high_index
;
9534 int max_indices
, num_indices
;
9538 if (noside
!= EVAL_NORMAL
)
9540 for (i
= 0; i
< n
; i
+= 1)
9541 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9545 container
= ada_coerce_ref (container
);
9546 if (ada_is_direct_array_type (value_type (container
)))
9547 container
= ada_coerce_to_simple_array (container
);
9548 lhs
= ada_coerce_ref (lhs
);
9549 if (!deprecated_value_modifiable (lhs
))
9550 error (_("Left operand of assignment is not a modifiable lvalue."));
9552 lhs_type
= check_typedef (value_type (lhs
));
9553 if (ada_is_direct_array_type (lhs_type
))
9555 lhs
= ada_coerce_to_simple_array (lhs
);
9556 lhs_type
= check_typedef (value_type (lhs
));
9557 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
9558 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
9560 else if (lhs_type
->code () == TYPE_CODE_STRUCT
)
9563 high_index
= num_visible_fields (lhs_type
) - 1;
9566 error (_("Left-hand side must be array or record."));
9568 num_specs
= num_component_specs (exp
, *pos
- 3);
9569 max_indices
= 4 * num_specs
+ 4;
9570 indices
= XALLOCAVEC (LONGEST
, max_indices
);
9571 indices
[0] = indices
[1] = low_index
- 1;
9572 indices
[2] = indices
[3] = high_index
+ 1;
9575 for (i
= 0; i
< n
; i
+= 1)
9577 switch (exp
->elts
[*pos
].opcode
)
9580 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9581 &num_indices
, max_indices
,
9582 low_index
, high_index
);
9585 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9586 &num_indices
, max_indices
,
9587 low_index
, high_index
);
9591 error (_("Misplaced 'others' clause"));
9592 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9593 num_indices
, low_index
, high_index
);
9596 error (_("Internal error: bad aggregate clause"));
9603 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9604 construct at *POS, updating *POS past the construct, given that
9605 the positions are relative to lower bound LOW, where HIGH is the
9606 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9607 updating *NUM_INDICES as needed. CONTAINER is as for
9608 assign_aggregate. */
9610 aggregate_assign_positional (struct value
*container
,
9611 struct value
*lhs
, struct expression
*exp
,
9612 int *pos
, LONGEST
*indices
, int *num_indices
,
9613 int max_indices
, LONGEST low
, LONGEST high
)
9615 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9617 if (ind
- 1 == high
)
9618 warning (_("Extra components in aggregate ignored."));
9621 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
9623 assign_component (container
, lhs
, ind
, exp
, pos
);
9626 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9629 /* Assign into the components of LHS indexed by the OP_CHOICES
9630 construct at *POS, updating *POS past the construct, given that
9631 the allowable indices are LOW..HIGH. Record the indices assigned
9632 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9633 needed. CONTAINER is as for assign_aggregate. */
9635 aggregate_assign_from_choices (struct value
*container
,
9636 struct value
*lhs
, struct expression
*exp
,
9637 int *pos
, LONGEST
*indices
, int *num_indices
,
9638 int max_indices
, LONGEST low
, LONGEST high
)
9641 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9642 int choice_pos
, expr_pc
;
9643 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9645 choice_pos
= *pos
+= 3;
9647 for (j
= 0; j
< n_choices
; j
+= 1)
9648 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9650 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9652 for (j
= 0; j
< n_choices
; j
+= 1)
9654 LONGEST lower
, upper
;
9655 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9657 if (op
== OP_DISCRETE_RANGE
)
9660 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9662 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9667 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9679 name
= &exp
->elts
[choice_pos
+ 2].string
;
9682 name
= exp
->elts
[choice_pos
+ 2].symbol
->natural_name ();
9685 error (_("Invalid record component association."));
9687 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9689 if (! find_struct_field (name
, value_type (lhs
), 0,
9690 NULL
, NULL
, NULL
, NULL
, &ind
))
9691 error (_("Unknown component name: %s."), name
);
9692 lower
= upper
= ind
;
9695 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9696 error (_("Index in component association out of bounds."));
9698 add_component_interval (lower
, upper
, indices
, num_indices
,
9700 while (lower
<= upper
)
9705 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9711 /* Assign the value of the expression in the OP_OTHERS construct in
9712 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9713 have not been previously assigned. The index intervals already assigned
9714 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9715 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9717 aggregate_assign_others (struct value
*container
,
9718 struct value
*lhs
, struct expression
*exp
,
9719 int *pos
, LONGEST
*indices
, int num_indices
,
9720 LONGEST low
, LONGEST high
)
9723 int expr_pc
= *pos
+ 1;
9725 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9729 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9734 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9737 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9740 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9741 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9742 modifying *SIZE as needed. It is an error if *SIZE exceeds
9743 MAX_SIZE. The resulting intervals do not overlap. */
9745 add_component_interval (LONGEST low
, LONGEST high
,
9746 LONGEST
* indices
, int *size
, int max_size
)
9750 for (i
= 0; i
< *size
; i
+= 2) {
9751 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9755 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
9756 if (high
< indices
[kh
])
9758 if (low
< indices
[i
])
9760 indices
[i
+ 1] = indices
[kh
- 1];
9761 if (high
> indices
[i
+ 1])
9762 indices
[i
+ 1] = high
;
9763 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
9764 *size
-= kh
- i
- 2;
9767 else if (high
< indices
[i
])
9771 if (*size
== max_size
)
9772 error (_("Internal error: miscounted aggregate components."));
9774 for (j
= *size
-1; j
>= i
+2; j
-= 1)
9775 indices
[j
] = indices
[j
- 2];
9777 indices
[i
+ 1] = high
;
9780 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9783 static struct value
*
9784 ada_value_cast (struct type
*type
, struct value
*arg2
)
9786 if (type
== ada_check_typedef (value_type (arg2
)))
9789 if (ada_is_gnat_encoded_fixed_point_type (type
))
9790 return cast_to_fixed (type
, arg2
);
9792 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
9793 return cast_from_fixed (type
, arg2
);
9795 return value_cast (type
, arg2
);
9798 /* Evaluating Ada expressions, and printing their result.
9799 ------------------------------------------------------
9804 We usually evaluate an Ada expression in order to print its value.
9805 We also evaluate an expression in order to print its type, which
9806 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9807 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9808 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9809 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9812 Evaluating expressions is a little more complicated for Ada entities
9813 than it is for entities in languages such as C. The main reason for
9814 this is that Ada provides types whose definition might be dynamic.
9815 One example of such types is variant records. Or another example
9816 would be an array whose bounds can only be known at run time.
9818 The following description is a general guide as to what should be
9819 done (and what should NOT be done) in order to evaluate an expression
9820 involving such types, and when. This does not cover how the semantic
9821 information is encoded by GNAT as this is covered separatly. For the
9822 document used as the reference for the GNAT encoding, see exp_dbug.ads
9823 in the GNAT sources.
9825 Ideally, we should embed each part of this description next to its
9826 associated code. Unfortunately, the amount of code is so vast right
9827 now that it's hard to see whether the code handling a particular
9828 situation might be duplicated or not. One day, when the code is
9829 cleaned up, this guide might become redundant with the comments
9830 inserted in the code, and we might want to remove it.
9832 2. ``Fixing'' an Entity, the Simple Case:
9833 -----------------------------------------
9835 When evaluating Ada expressions, the tricky issue is that they may
9836 reference entities whose type contents and size are not statically
9837 known. Consider for instance a variant record:
9839 type Rec (Empty : Boolean := True) is record
9842 when False => Value : Integer;
9845 Yes : Rec := (Empty => False, Value => 1);
9846 No : Rec := (empty => True);
9848 The size and contents of that record depends on the value of the
9849 descriminant (Rec.Empty). At this point, neither the debugging
9850 information nor the associated type structure in GDB are able to
9851 express such dynamic types. So what the debugger does is to create
9852 "fixed" versions of the type that applies to the specific object.
9853 We also informally refer to this operation as "fixing" an object,
9854 which means creating its associated fixed type.
9856 Example: when printing the value of variable "Yes" above, its fixed
9857 type would look like this:
9864 On the other hand, if we printed the value of "No", its fixed type
9871 Things become a little more complicated when trying to fix an entity
9872 with a dynamic type that directly contains another dynamic type,
9873 such as an array of variant records, for instance. There are
9874 two possible cases: Arrays, and records.
9876 3. ``Fixing'' Arrays:
9877 ---------------------
9879 The type structure in GDB describes an array in terms of its bounds,
9880 and the type of its elements. By design, all elements in the array
9881 have the same type and we cannot represent an array of variant elements
9882 using the current type structure in GDB. When fixing an array,
9883 we cannot fix the array element, as we would potentially need one
9884 fixed type per element of the array. As a result, the best we can do
9885 when fixing an array is to produce an array whose bounds and size
9886 are correct (allowing us to read it from memory), but without having
9887 touched its element type. Fixing each element will be done later,
9888 when (if) necessary.
9890 Arrays are a little simpler to handle than records, because the same
9891 amount of memory is allocated for each element of the array, even if
9892 the amount of space actually used by each element differs from element
9893 to element. Consider for instance the following array of type Rec:
9895 type Rec_Array is array (1 .. 2) of Rec;
9897 The actual amount of memory occupied by each element might be different
9898 from element to element, depending on the value of their discriminant.
9899 But the amount of space reserved for each element in the array remains
9900 fixed regardless. So we simply need to compute that size using
9901 the debugging information available, from which we can then determine
9902 the array size (we multiply the number of elements of the array by
9903 the size of each element).
9905 The simplest case is when we have an array of a constrained element
9906 type. For instance, consider the following type declarations:
9908 type Bounded_String (Max_Size : Integer) is
9910 Buffer : String (1 .. Max_Size);
9912 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9914 In this case, the compiler describes the array as an array of
9915 variable-size elements (identified by its XVS suffix) for which
9916 the size can be read in the parallel XVZ variable.
9918 In the case of an array of an unconstrained element type, the compiler
9919 wraps the array element inside a private PAD type. This type should not
9920 be shown to the user, and must be "unwrap"'ed before printing. Note
9921 that we also use the adjective "aligner" in our code to designate
9922 these wrapper types.
9924 In some cases, the size allocated for each element is statically
9925 known. In that case, the PAD type already has the correct size,
9926 and the array element should remain unfixed.
9928 But there are cases when this size is not statically known.
9929 For instance, assuming that "Five" is an integer variable:
9931 type Dynamic is array (1 .. Five) of Integer;
9932 type Wrapper (Has_Length : Boolean := False) is record
9935 when True => Length : Integer;
9939 type Wrapper_Array is array (1 .. 2) of Wrapper;
9941 Hello : Wrapper_Array := (others => (Has_Length => True,
9942 Data => (others => 17),
9946 The debugging info would describe variable Hello as being an
9947 array of a PAD type. The size of that PAD type is not statically
9948 known, but can be determined using a parallel XVZ variable.
9949 In that case, a copy of the PAD type with the correct size should
9950 be used for the fixed array.
9952 3. ``Fixing'' record type objects:
9953 ----------------------------------
9955 Things are slightly different from arrays in the case of dynamic
9956 record types. In this case, in order to compute the associated
9957 fixed type, we need to determine the size and offset of each of
9958 its components. This, in turn, requires us to compute the fixed
9959 type of each of these components.
9961 Consider for instance the example:
9963 type Bounded_String (Max_Size : Natural) is record
9964 Str : String (1 .. Max_Size);
9967 My_String : Bounded_String (Max_Size => 10);
9969 In that case, the position of field "Length" depends on the size
9970 of field Str, which itself depends on the value of the Max_Size
9971 discriminant. In order to fix the type of variable My_String,
9972 we need to fix the type of field Str. Therefore, fixing a variant
9973 record requires us to fix each of its components.
9975 However, if a component does not have a dynamic size, the component
9976 should not be fixed. In particular, fields that use a PAD type
9977 should not fixed. Here is an example where this might happen
9978 (assuming type Rec above):
9980 type Container (Big : Boolean) is record
9984 when True => Another : Integer;
9988 My_Container : Container := (Big => False,
9989 First => (Empty => True),
9992 In that example, the compiler creates a PAD type for component First,
9993 whose size is constant, and then positions the component After just
9994 right after it. The offset of component After is therefore constant
9997 The debugger computes the position of each field based on an algorithm
9998 that uses, among other things, the actual position and size of the field
9999 preceding it. Let's now imagine that the user is trying to print
10000 the value of My_Container. If the type fixing was recursive, we would
10001 end up computing the offset of field After based on the size of the
10002 fixed version of field First. And since in our example First has
10003 only one actual field, the size of the fixed type is actually smaller
10004 than the amount of space allocated to that field, and thus we would
10005 compute the wrong offset of field After.
10007 To make things more complicated, we need to watch out for dynamic
10008 components of variant records (identified by the ___XVL suffix in
10009 the component name). Even if the target type is a PAD type, the size
10010 of that type might not be statically known. So the PAD type needs
10011 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10012 we might end up with the wrong size for our component. This can be
10013 observed with the following type declarations:
10015 type Octal is new Integer range 0 .. 7;
10016 type Octal_Array is array (Positive range <>) of Octal;
10017 pragma Pack (Octal_Array);
10019 type Octal_Buffer (Size : Positive) is record
10020 Buffer : Octal_Array (1 .. Size);
10024 In that case, Buffer is a PAD type whose size is unset and needs
10025 to be computed by fixing the unwrapped type.
10027 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10028 ----------------------------------------------------------
10030 Lastly, when should the sub-elements of an entity that remained unfixed
10031 thus far, be actually fixed?
10033 The answer is: Only when referencing that element. For instance
10034 when selecting one component of a record, this specific component
10035 should be fixed at that point in time. Or when printing the value
10036 of a record, each component should be fixed before its value gets
10037 printed. Similarly for arrays, the element of the array should be
10038 fixed when printing each element of the array, or when extracting
10039 one element out of that array. On the other hand, fixing should
10040 not be performed on the elements when taking a slice of an array!
10042 Note that one of the side effects of miscomputing the offset and
10043 size of each field is that we end up also miscomputing the size
10044 of the containing type. This can have adverse results when computing
10045 the value of an entity. GDB fetches the value of an entity based
10046 on the size of its type, and thus a wrong size causes GDB to fetch
10047 the wrong amount of memory. In the case where the computed size is
10048 too small, GDB fetches too little data to print the value of our
10049 entity. Results in this case are unpredictable, as we usually read
10050 past the buffer containing the data =:-o. */
10052 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10053 for that subexpression cast to TO_TYPE. Advance *POS over the
10057 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
10058 enum noside noside
, struct type
*to_type
)
10062 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
10063 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
10068 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
10070 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10071 return value_zero (to_type
, not_lval
);
10073 val
= evaluate_var_msym_value (noside
,
10074 exp
->elts
[pc
+ 1].objfile
,
10075 exp
->elts
[pc
+ 2].msymbol
);
10078 val
= evaluate_var_value (noside
,
10079 exp
->elts
[pc
+ 1].block
,
10080 exp
->elts
[pc
+ 2].symbol
);
10082 if (noside
== EVAL_SKIP
)
10083 return eval_skip_value (exp
);
10085 val
= ada_value_cast (to_type
, val
);
10087 /* Follow the Ada language semantics that do not allow taking
10088 an address of the result of a cast (view conversion in Ada). */
10089 if (VALUE_LVAL (val
) == lval_memory
)
10091 if (value_lazy (val
))
10092 value_fetch_lazy (val
);
10093 VALUE_LVAL (val
) = not_lval
;
10098 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
10099 if (noside
== EVAL_SKIP
)
10100 return eval_skip_value (exp
);
10101 return ada_value_cast (to_type
, val
);
10104 /* Implement the evaluate_exp routine in the exp_descriptor structure
10105 for the Ada language. */
10107 static struct value
*
10108 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10109 int *pos
, enum noside noside
)
10111 enum exp_opcode op
;
10115 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10118 struct value
**argvec
;
10122 op
= exp
->elts
[pc
].opcode
;
10128 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10130 if (noside
== EVAL_NORMAL
)
10131 arg1
= unwrap_value (arg1
);
10133 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10134 then we need to perform the conversion manually, because
10135 evaluate_subexp_standard doesn't do it. This conversion is
10136 necessary in Ada because the different kinds of float/fixed
10137 types in Ada have different representations.
10139 Similarly, we need to perform the conversion from OP_LONG
10141 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10142 arg1
= ada_value_cast (expect_type
, arg1
);
10148 struct value
*result
;
10151 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10152 /* The result type will have code OP_STRING, bashed there from
10153 OP_ARRAY. Bash it back. */
10154 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10155 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10161 type
= exp
->elts
[pc
+ 1].type
;
10162 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10166 type
= exp
->elts
[pc
+ 1].type
;
10167 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10170 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10171 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10173 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10174 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10176 return ada_value_assign (arg1
, arg1
);
10178 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10179 except if the lhs of our assignment is a convenience variable.
10180 In the case of assigning to a convenience variable, the lhs
10181 should be exactly the result of the evaluation of the rhs. */
10182 type
= value_type (arg1
);
10183 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10185 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10186 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10188 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10192 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10193 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
10194 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10196 (_("Fixed-point values must be assigned to fixed-point variables"));
10198 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10199 return ada_value_assign (arg1
, arg2
);
10202 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10203 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10204 if (noside
== EVAL_SKIP
)
10206 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10207 return (value_from_longest
10208 (value_type (arg1
),
10209 value_as_long (arg1
) + value_as_long (arg2
)));
10210 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10211 return (value_from_longest
10212 (value_type (arg2
),
10213 value_as_long (arg1
) + value_as_long (arg2
)));
10214 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10215 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10216 && value_type (arg1
) != value_type (arg2
))
10217 error (_("Operands of fixed-point addition must have the same type"));
10218 /* Do the addition, and cast the result to the type of the first
10219 argument. We cannot cast the result to a reference type, so if
10220 ARG1 is a reference type, find its underlying type. */
10221 type
= value_type (arg1
);
10222 while (type
->code () == TYPE_CODE_REF
)
10223 type
= TYPE_TARGET_TYPE (type
);
10224 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10225 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10228 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10229 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10230 if (noside
== EVAL_SKIP
)
10232 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10233 return (value_from_longest
10234 (value_type (arg1
),
10235 value_as_long (arg1
) - value_as_long (arg2
)));
10236 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10237 return (value_from_longest
10238 (value_type (arg2
),
10239 value_as_long (arg1
) - value_as_long (arg2
)));
10240 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10241 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10242 && value_type (arg1
) != value_type (arg2
))
10243 error (_("Operands of fixed-point subtraction "
10244 "must have the same type"));
10245 /* Do the substraction, and cast the result to the type of the first
10246 argument. We cannot cast the result to a reference type, so if
10247 ARG1 is a reference type, find its underlying type. */
10248 type
= value_type (arg1
);
10249 while (type
->code () == TYPE_CODE_REF
)
10250 type
= TYPE_TARGET_TYPE (type
);
10251 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10252 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10258 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10259 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10260 if (noside
== EVAL_SKIP
)
10262 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10264 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10265 return value_zero (value_type (arg1
), not_lval
);
10269 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10270 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10271 arg1
= cast_from_fixed (type
, arg1
);
10272 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10273 arg2
= cast_from_fixed (type
, arg2
);
10274 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10275 return ada_value_binop (arg1
, arg2
, op
);
10279 case BINOP_NOTEQUAL
:
10280 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10281 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10282 if (noside
== EVAL_SKIP
)
10284 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10288 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10289 tem
= ada_value_equal (arg1
, arg2
);
10291 if (op
== BINOP_NOTEQUAL
)
10293 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10294 return value_from_longest (type
, (LONGEST
) tem
);
10297 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10298 if (noside
== EVAL_SKIP
)
10300 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10301 return value_cast (value_type (arg1
), value_neg (arg1
));
10304 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10305 return value_neg (arg1
);
10308 case BINOP_LOGICAL_AND
:
10309 case BINOP_LOGICAL_OR
:
10310 case UNOP_LOGICAL_NOT
:
10315 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10316 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10317 return value_cast (type
, val
);
10320 case BINOP_BITWISE_AND
:
10321 case BINOP_BITWISE_IOR
:
10322 case BINOP_BITWISE_XOR
:
10326 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10328 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10330 return value_cast (value_type (arg1
), val
);
10336 if (noside
== EVAL_SKIP
)
10342 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10343 /* Only encountered when an unresolved symbol occurs in a
10344 context other than a function call, in which case, it is
10346 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10347 exp
->elts
[pc
+ 2].symbol
->print_name ());
10349 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10351 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10352 /* Check to see if this is a tagged type. We also need to handle
10353 the case where the type is a reference to a tagged type, but
10354 we have to be careful to exclude pointers to tagged types.
10355 The latter should be shown as usual (as a pointer), whereas
10356 a reference should mostly be transparent to the user. */
10357 if (ada_is_tagged_type (type
, 0)
10358 || (type
->code () == TYPE_CODE_REF
10359 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10361 /* Tagged types are a little special in the fact that the real
10362 type is dynamic and can only be determined by inspecting the
10363 object's tag. This means that we need to get the object's
10364 value first (EVAL_NORMAL) and then extract the actual object
10367 Note that we cannot skip the final step where we extract
10368 the object type from its tag, because the EVAL_NORMAL phase
10369 results in dynamic components being resolved into fixed ones.
10370 This can cause problems when trying to print the type
10371 description of tagged types whose parent has a dynamic size:
10372 We use the type name of the "_parent" component in order
10373 to print the name of the ancestor type in the type description.
10374 If that component had a dynamic size, the resolution into
10375 a fixed type would result in the loss of that type name,
10376 thus preventing us from printing the name of the ancestor
10377 type in the type description. */
10378 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
10380 if (type
->code () != TYPE_CODE_REF
)
10382 struct type
*actual_type
;
10384 actual_type
= type_from_tag (ada_value_tag (arg1
));
10385 if (actual_type
== NULL
)
10386 /* If, for some reason, we were unable to determine
10387 the actual type from the tag, then use the static
10388 approximation that we just computed as a fallback.
10389 This can happen if the debugging information is
10390 incomplete, for instance. */
10391 actual_type
= type
;
10392 return value_zero (actual_type
, not_lval
);
10396 /* In the case of a ref, ada_coerce_ref takes care
10397 of determining the actual type. But the evaluation
10398 should return a ref as it should be valid to ask
10399 for its address; so rebuild a ref after coerce. */
10400 arg1
= ada_coerce_ref (arg1
);
10401 return value_ref (arg1
, TYPE_CODE_REF
);
10405 /* Records and unions for which GNAT encodings have been
10406 generated need to be statically fixed as well.
10407 Otherwise, non-static fixing produces a type where
10408 all dynamic properties are removed, which prevents "ptype"
10409 from being able to completely describe the type.
10410 For instance, a case statement in a variant record would be
10411 replaced by the relevant components based on the actual
10412 value of the discriminants. */
10413 if ((type
->code () == TYPE_CODE_STRUCT
10414 && dynamic_template_type (type
) != NULL
)
10415 || (type
->code () == TYPE_CODE_UNION
10416 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10419 return value_zero (to_static_fixed_type (type
), not_lval
);
10423 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10424 return ada_to_fixed_value (arg1
);
10429 /* Allocate arg vector, including space for the function to be
10430 called in argvec[0] and a terminating NULL. */
10431 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10432 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10434 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10435 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10436 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10437 exp
->elts
[pc
+ 5].symbol
->print_name ());
10440 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10441 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10444 if (noside
== EVAL_SKIP
)
10448 if (ada_is_constrained_packed_array_type
10449 (desc_base_type (value_type (argvec
[0]))))
10450 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10451 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10452 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10453 /* This is a packed array that has already been fixed, and
10454 therefore already coerced to a simple array. Nothing further
10457 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10459 /* Make sure we dereference references so that all the code below
10460 feels like it's really handling the referenced value. Wrapping
10461 types (for alignment) may be there, so make sure we strip them as
10463 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10465 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10466 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10467 argvec
[0] = value_addr (argvec
[0]);
10469 type
= ada_check_typedef (value_type (argvec
[0]));
10471 /* Ada allows us to implicitly dereference arrays when subscripting
10472 them. So, if this is an array typedef (encoding use for array
10473 access types encoded as fat pointers), strip it now. */
10474 if (type
->code () == TYPE_CODE_TYPEDEF
)
10475 type
= ada_typedef_target_type (type
);
10477 if (type
->code () == TYPE_CODE_PTR
)
10479 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10481 case TYPE_CODE_FUNC
:
10482 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10484 case TYPE_CODE_ARRAY
:
10486 case TYPE_CODE_STRUCT
:
10487 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10488 argvec
[0] = ada_value_ind (argvec
[0]);
10489 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10492 error (_("cannot subscript or call something of type `%s'"),
10493 ada_type_name (value_type (argvec
[0])));
10498 switch (type
->code ())
10500 case TYPE_CODE_FUNC
:
10501 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10503 if (TYPE_TARGET_TYPE (type
) == NULL
)
10504 error_call_unknown_return_type (NULL
);
10505 return allocate_value (TYPE_TARGET_TYPE (type
));
10507 return call_function_by_hand (argvec
[0], NULL
,
10508 gdb::make_array_view (argvec
+ 1,
10510 case TYPE_CODE_INTERNAL_FUNCTION
:
10511 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10512 /* We don't know anything about what the internal
10513 function might return, but we have to return
10515 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10518 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10519 argvec
[0], nargs
, argvec
+ 1);
10521 case TYPE_CODE_STRUCT
:
10525 arity
= ada_array_arity (type
);
10526 type
= ada_array_element_type (type
, nargs
);
10528 error (_("cannot subscript or call a record"));
10529 if (arity
!= nargs
)
10530 error (_("wrong number of subscripts; expecting %d"), arity
);
10531 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10532 return value_zero (ada_aligned_type (type
), lval_memory
);
10534 unwrap_value (ada_value_subscript
10535 (argvec
[0], nargs
, argvec
+ 1));
10537 case TYPE_CODE_ARRAY
:
10538 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10540 type
= ada_array_element_type (type
, nargs
);
10542 error (_("element type of array unknown"));
10544 return value_zero (ada_aligned_type (type
), lval_memory
);
10547 unwrap_value (ada_value_subscript
10548 (ada_coerce_to_simple_array (argvec
[0]),
10549 nargs
, argvec
+ 1));
10550 case TYPE_CODE_PTR
: /* Pointer to array */
10551 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10553 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10554 type
= ada_array_element_type (type
, nargs
);
10556 error (_("element type of array unknown"));
10558 return value_zero (ada_aligned_type (type
), lval_memory
);
10561 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10562 nargs
, argvec
+ 1));
10565 error (_("Attempt to index or call something other than an "
10566 "array or function"));
10571 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10572 struct value
*low_bound_val
=
10573 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10574 struct value
*high_bound_val
=
10575 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10577 LONGEST high_bound
;
10579 low_bound_val
= coerce_ref (low_bound_val
);
10580 high_bound_val
= coerce_ref (high_bound_val
);
10581 low_bound
= value_as_long (low_bound_val
);
10582 high_bound
= value_as_long (high_bound_val
);
10584 if (noside
== EVAL_SKIP
)
10587 /* If this is a reference to an aligner type, then remove all
10589 if (value_type (array
)->code () == TYPE_CODE_REF
10590 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10591 TYPE_TARGET_TYPE (value_type (array
)) =
10592 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10594 if (ada_is_constrained_packed_array_type (value_type (array
)))
10595 error (_("cannot slice a packed array"));
10597 /* If this is a reference to an array or an array lvalue,
10598 convert to a pointer. */
10599 if (value_type (array
)->code () == TYPE_CODE_REF
10600 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10601 && VALUE_LVAL (array
) == lval_memory
))
10602 array
= value_addr (array
);
10604 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10605 && ada_is_array_descriptor_type (ada_check_typedef
10606 (value_type (array
))))
10607 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10610 array
= ada_coerce_to_simple_array_ptr (array
);
10612 /* If we have more than one level of pointer indirection,
10613 dereference the value until we get only one level. */
10614 while (value_type (array
)->code () == TYPE_CODE_PTR
10615 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10617 array
= value_ind (array
);
10619 /* Make sure we really do have an array type before going further,
10620 to avoid a SEGV when trying to get the index type or the target
10621 type later down the road if the debug info generated by
10622 the compiler is incorrect or incomplete. */
10623 if (!ada_is_simple_array_type (value_type (array
)))
10624 error (_("cannot take slice of non-array"));
10626 if (ada_check_typedef (value_type (array
))->code ()
10629 struct type
*type0
= ada_check_typedef (value_type (array
));
10631 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10632 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10635 struct type
*arr_type0
=
10636 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10638 return ada_value_slice_from_ptr (array
, arr_type0
,
10639 longest_to_int (low_bound
),
10640 longest_to_int (high_bound
));
10643 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10645 else if (high_bound
< low_bound
)
10646 return empty_array (value_type (array
), low_bound
, high_bound
);
10648 return ada_value_slice (array
, longest_to_int (low_bound
),
10649 longest_to_int (high_bound
));
10652 case UNOP_IN_RANGE
:
10654 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10655 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10657 if (noside
== EVAL_SKIP
)
10660 switch (type
->code ())
10663 lim_warning (_("Membership test incompletely implemented; "
10664 "always returns true"));
10665 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10666 return value_from_longest (type
, (LONGEST
) 1);
10668 case TYPE_CODE_RANGE
:
10669 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
10670 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
10671 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10672 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10673 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10675 value_from_longest (type
,
10676 (value_less (arg1
, arg3
)
10677 || value_equal (arg1
, arg3
))
10678 && (value_less (arg2
, arg1
)
10679 || value_equal (arg2
, arg1
)));
10682 case BINOP_IN_BOUNDS
:
10684 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10685 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10687 if (noside
== EVAL_SKIP
)
10690 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10692 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10693 return value_zero (type
, not_lval
);
10696 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10698 type
= ada_index_type (value_type (arg2
), tem
, "range");
10700 type
= value_type (arg1
);
10702 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10703 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10705 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10706 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10707 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10709 value_from_longest (type
,
10710 (value_less (arg1
, arg3
)
10711 || value_equal (arg1
, arg3
))
10712 && (value_less (arg2
, arg1
)
10713 || value_equal (arg2
, arg1
)));
10715 case TERNOP_IN_RANGE
:
10716 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10717 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10718 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10720 if (noside
== EVAL_SKIP
)
10723 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10724 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10725 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10727 value_from_longest (type
,
10728 (value_less (arg1
, arg3
)
10729 || value_equal (arg1
, arg3
))
10730 && (value_less (arg2
, arg1
)
10731 || value_equal (arg2
, arg1
)));
10735 case OP_ATR_LENGTH
:
10737 struct type
*type_arg
;
10739 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10741 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10743 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10747 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10751 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10752 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10753 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10756 if (noside
== EVAL_SKIP
)
10758 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10760 if (type_arg
== NULL
)
10761 type_arg
= value_type (arg1
);
10763 if (ada_is_constrained_packed_array_type (type_arg
))
10764 type_arg
= decode_constrained_packed_array_type (type_arg
);
10766 if (!discrete_type_p (type_arg
))
10770 default: /* Should never happen. */
10771 error (_("unexpected attribute encountered"));
10774 type_arg
= ada_index_type (type_arg
, tem
,
10775 ada_attribute_name (op
));
10777 case OP_ATR_LENGTH
:
10778 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10783 return value_zero (type_arg
, not_lval
);
10785 else if (type_arg
== NULL
)
10787 arg1
= ada_coerce_ref (arg1
);
10789 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10790 arg1
= ada_coerce_to_simple_array (arg1
);
10792 if (op
== OP_ATR_LENGTH
)
10793 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10796 type
= ada_index_type (value_type (arg1
), tem
,
10797 ada_attribute_name (op
));
10799 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10804 default: /* Should never happen. */
10805 error (_("unexpected attribute encountered"));
10807 return value_from_longest
10808 (type
, ada_array_bound (arg1
, tem
, 0));
10810 return value_from_longest
10811 (type
, ada_array_bound (arg1
, tem
, 1));
10812 case OP_ATR_LENGTH
:
10813 return value_from_longest
10814 (type
, ada_array_length (arg1
, tem
));
10817 else if (discrete_type_p (type_arg
))
10819 struct type
*range_type
;
10820 const char *name
= ada_type_name (type_arg
);
10823 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10824 range_type
= to_fixed_range_type (type_arg
, NULL
);
10825 if (range_type
== NULL
)
10826 range_type
= type_arg
;
10830 error (_("unexpected attribute encountered"));
10832 return value_from_longest
10833 (range_type
, ada_discrete_type_low_bound (range_type
));
10835 return value_from_longest
10836 (range_type
, ada_discrete_type_high_bound (range_type
));
10837 case OP_ATR_LENGTH
:
10838 error (_("the 'length attribute applies only to array types"));
10841 else if (type_arg
->code () == TYPE_CODE_FLT
)
10842 error (_("unimplemented type attribute"));
10847 if (ada_is_constrained_packed_array_type (type_arg
))
10848 type_arg
= decode_constrained_packed_array_type (type_arg
);
10850 if (op
== OP_ATR_LENGTH
)
10851 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10854 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10856 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10862 error (_("unexpected attribute encountered"));
10864 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10865 return value_from_longest (type
, low
);
10867 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10868 return value_from_longest (type
, high
);
10869 case OP_ATR_LENGTH
:
10870 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10871 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10872 return value_from_longest (type
, high
- low
+ 1);
10878 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10879 if (noside
== EVAL_SKIP
)
10882 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10883 return value_zero (ada_tag_type (arg1
), not_lval
);
10885 return ada_value_tag (arg1
);
10889 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10890 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10891 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10892 if (noside
== EVAL_SKIP
)
10894 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10895 return value_zero (value_type (arg1
), not_lval
);
10898 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10899 return value_binop (arg1
, arg2
,
10900 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10903 case OP_ATR_MODULUS
:
10905 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10907 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10908 if (noside
== EVAL_SKIP
)
10911 if (!ada_is_modular_type (type_arg
))
10912 error (_("'modulus must be applied to modular type"));
10914 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10915 ada_modulus (type_arg
));
10920 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10921 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10922 if (noside
== EVAL_SKIP
)
10924 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10925 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10926 return value_zero (type
, not_lval
);
10928 return value_pos_atr (type
, arg1
);
10931 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10932 type
= value_type (arg1
);
10934 /* If the argument is a reference, then dereference its type, since
10935 the user is really asking for the size of the actual object,
10936 not the size of the pointer. */
10937 if (type
->code () == TYPE_CODE_REF
)
10938 type
= TYPE_TARGET_TYPE (type
);
10940 if (noside
== EVAL_SKIP
)
10942 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10943 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
10945 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
10946 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
10949 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10950 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10951 type
= exp
->elts
[pc
+ 2].type
;
10952 if (noside
== EVAL_SKIP
)
10954 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10955 return value_zero (type
, not_lval
);
10957 return value_val_atr (type
, arg1
);
10960 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10961 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10962 if (noside
== EVAL_SKIP
)
10964 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10965 return value_zero (value_type (arg1
), not_lval
);
10968 /* For integer exponentiation operations,
10969 only promote the first argument. */
10970 if (is_integral_type (value_type (arg2
)))
10971 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10973 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10975 return value_binop (arg1
, arg2
, op
);
10979 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10980 if (noside
== EVAL_SKIP
)
10986 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10987 if (noside
== EVAL_SKIP
)
10989 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10990 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
10991 return value_neg (arg1
);
10996 preeval_pos
= *pos
;
10997 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10998 if (noside
== EVAL_SKIP
)
11000 type
= ada_check_typedef (value_type (arg1
));
11001 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11003 if (ada_is_array_descriptor_type (type
))
11004 /* GDB allows dereferencing GNAT array descriptors. */
11006 struct type
*arrType
= ada_type_of_array (arg1
, 0);
11008 if (arrType
== NULL
)
11009 error (_("Attempt to dereference null array pointer."));
11010 return value_at_lazy (arrType
, 0);
11012 else if (type
->code () == TYPE_CODE_PTR
11013 || type
->code () == TYPE_CODE_REF
11014 /* In C you can dereference an array to get the 1st elt. */
11015 || type
->code () == TYPE_CODE_ARRAY
)
11017 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11018 only be determined by inspecting the object's tag.
11019 This means that we need to evaluate completely the
11020 expression in order to get its type. */
11022 if ((type
->code () == TYPE_CODE_REF
11023 || type
->code () == TYPE_CODE_PTR
)
11024 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
11026 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11028 type
= value_type (ada_value_ind (arg1
));
11032 type
= to_static_fixed_type
11034 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
11036 ada_ensure_varsize_limit (type
);
11037 return value_zero (type
, lval_memory
);
11039 else if (type
->code () == TYPE_CODE_INT
)
11041 /* GDB allows dereferencing an int. */
11042 if (expect_type
== NULL
)
11043 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11048 to_static_fixed_type (ada_aligned_type (expect_type
));
11049 return value_zero (expect_type
, lval_memory
);
11053 error (_("Attempt to take contents of a non-pointer value."));
11055 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11056 type
= ada_check_typedef (value_type (arg1
));
11058 if (type
->code () == TYPE_CODE_INT
)
11059 /* GDB allows dereferencing an int. If we were given
11060 the expect_type, then use that as the target type.
11061 Otherwise, assume that the target type is an int. */
11063 if (expect_type
!= NULL
)
11064 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11067 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11068 (CORE_ADDR
) value_as_address (arg1
));
11071 if (ada_is_array_descriptor_type (type
))
11072 /* GDB allows dereferencing GNAT array descriptors. */
11073 return ada_coerce_to_simple_array (arg1
);
11075 return ada_value_ind (arg1
);
11077 case STRUCTOP_STRUCT
:
11078 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11079 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11080 preeval_pos
= *pos
;
11081 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11082 if (noside
== EVAL_SKIP
)
11084 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11086 struct type
*type1
= value_type (arg1
);
11088 if (ada_is_tagged_type (type1
, 1))
11090 type
= ada_lookup_struct_elt_type (type1
,
11091 &exp
->elts
[pc
+ 2].string
,
11094 /* If the field is not found, check if it exists in the
11095 extension of this object's type. This means that we
11096 need to evaluate completely the expression. */
11100 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11102 arg1
= ada_value_struct_elt (arg1
,
11103 &exp
->elts
[pc
+ 2].string
,
11105 arg1
= unwrap_value (arg1
);
11106 type
= value_type (ada_to_fixed_value (arg1
));
11111 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11114 return value_zero (ada_aligned_type (type
), lval_memory
);
11118 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11119 arg1
= unwrap_value (arg1
);
11120 return ada_to_fixed_value (arg1
);
11124 /* The value is not supposed to be used. This is here to make it
11125 easier to accommodate expressions that contain types. */
11127 if (noside
== EVAL_SKIP
)
11129 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11130 return allocate_value (exp
->elts
[pc
+ 1].type
);
11132 error (_("Attempt to use a type name as an expression"));
11137 case OP_DISCRETE_RANGE
:
11138 case OP_POSITIONAL
:
11140 if (noside
== EVAL_NORMAL
)
11144 error (_("Undefined name, ambiguous name, or renaming used in "
11145 "component association: %s."), &exp
->elts
[pc
+2].string
);
11147 error (_("Aggregates only allowed on the right of an assignment"));
11149 internal_error (__FILE__
, __LINE__
,
11150 _("aggregate apparently mangled"));
11153 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11155 for (tem
= 0; tem
< nargs
; tem
+= 1)
11156 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11161 return eval_skip_value (exp
);
11167 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11168 type name that encodes the 'small and 'delta information.
11169 Otherwise, return NULL. */
11171 static const char *
11172 gnat_encoded_fixed_type_info (struct type
*type
)
11174 const char *name
= ada_type_name (type
);
11175 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: type
->code ();
11177 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11179 const char *tail
= strstr (name
, "___XF_");
11186 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11187 return gnat_encoded_fixed_type_info (TYPE_TARGET_TYPE (type
));
11192 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11195 ada_is_gnat_encoded_fixed_point_type (struct type
*type
)
11197 return gnat_encoded_fixed_type_info (type
) != NULL
;
11200 /* Return non-zero iff TYPE represents a System.Address type. */
11203 ada_is_system_address_type (struct type
*type
)
11205 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11208 /* Assuming that TYPE is the representation of an Ada fixed-point
11209 type, return the target floating-point type to be used to represent
11210 of this type during internal computation. */
11212 static struct type
*
11213 ada_scaling_type (struct type
*type
)
11215 return builtin_type (get_type_arch (type
))->builtin_long_double
;
11218 /* Assuming that TYPE is the representation of an Ada fixed-point
11219 type, return its delta, or NULL if the type is malformed and the
11220 delta cannot be determined. */
11223 gnat_encoded_fixed_point_delta (struct type
*type
)
11225 const char *encoding
= gnat_encoded_fixed_type_info (type
);
11226 struct type
*scale_type
= ada_scaling_type (type
);
11228 long long num
, den
;
11230 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11233 return value_binop (value_from_longest (scale_type
, num
),
11234 value_from_longest (scale_type
, den
), BINOP_DIV
);
11237 /* Assuming that ada_is_gnat_encoded_fixed_point_type (TYPE), return
11238 the scaling factor ('SMALL value) associated with the type. */
11241 ada_scaling_factor (struct type
*type
)
11243 const char *encoding
= gnat_encoded_fixed_type_info (type
);
11244 struct type
*scale_type
= ada_scaling_type (type
);
11246 long long num0
, den0
, num1
, den1
;
11249 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11250 &num0
, &den0
, &num1
, &den1
);
11253 return value_from_longest (scale_type
, 1);
11255 return value_binop (value_from_longest (scale_type
, num1
),
11256 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11258 return value_binop (value_from_longest (scale_type
, num0
),
11259 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11266 /* Scan STR beginning at position K for a discriminant name, and
11267 return the value of that discriminant field of DVAL in *PX. If
11268 PNEW_K is not null, put the position of the character beyond the
11269 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11270 not alter *PX and *PNEW_K if unsuccessful. */
11273 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11276 static char *bound_buffer
= NULL
;
11277 static size_t bound_buffer_len
= 0;
11278 const char *pstart
, *pend
, *bound
;
11279 struct value
*bound_val
;
11281 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11285 pend
= strstr (pstart
, "__");
11289 k
+= strlen (bound
);
11293 int len
= pend
- pstart
;
11295 /* Strip __ and beyond. */
11296 GROW_VECT (bound_buffer
, bound_buffer_len
, len
+ 1);
11297 strncpy (bound_buffer
, pstart
, len
);
11298 bound_buffer
[len
] = '\0';
11300 bound
= bound_buffer
;
11304 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11305 if (bound_val
== NULL
)
11308 *px
= value_as_long (bound_val
);
11309 if (pnew_k
!= NULL
)
11314 /* Value of variable named NAME in the current environment. If
11315 no such variable found, then if ERR_MSG is null, returns 0, and
11316 otherwise causes an error with message ERR_MSG. */
11318 static struct value
*
11319 get_var_value (const char *name
, const char *err_msg
)
11321 lookup_name_info
lookup_name (name
, symbol_name_match_type::FULL
);
11323 std::vector
<struct block_symbol
> syms
;
11324 int nsyms
= ada_lookup_symbol_list_worker (lookup_name
,
11325 get_selected_block (0),
11326 VAR_DOMAIN
, &syms
, 1);
11330 if (err_msg
== NULL
)
11333 error (("%s"), err_msg
);
11336 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11339 /* Value of integer variable named NAME in the current environment.
11340 If no such variable is found, returns false. Otherwise, sets VALUE
11341 to the variable's value and returns true. */
11344 get_int_var_value (const char *name
, LONGEST
&value
)
11346 struct value
*var_val
= get_var_value (name
, 0);
11351 value
= value_as_long (var_val
);
11356 /* Return a range type whose base type is that of the range type named
11357 NAME in the current environment, and whose bounds are calculated
11358 from NAME according to the GNAT range encoding conventions.
11359 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11360 corresponding range type from debug information; fall back to using it
11361 if symbol lookup fails. If a new type must be created, allocate it
11362 like ORIG_TYPE was. The bounds information, in general, is encoded
11363 in NAME, the base type given in the named range type. */
11365 static struct type
*
11366 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11369 struct type
*base_type
;
11370 const char *subtype_info
;
11372 gdb_assert (raw_type
!= NULL
);
11373 gdb_assert (raw_type
->name () != NULL
);
11375 if (raw_type
->code () == TYPE_CODE_RANGE
)
11376 base_type
= TYPE_TARGET_TYPE (raw_type
);
11378 base_type
= raw_type
;
11380 name
= raw_type
->name ();
11381 subtype_info
= strstr (name
, "___XD");
11382 if (subtype_info
== NULL
)
11384 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11385 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11387 if (L
< INT_MIN
|| U
> INT_MAX
)
11390 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11395 static char *name_buf
= NULL
;
11396 static size_t name_len
= 0;
11397 int prefix_len
= subtype_info
- name
;
11400 const char *bounds_str
;
11403 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11404 strncpy (name_buf
, name
, prefix_len
);
11405 name_buf
[prefix_len
] = '\0';
11408 bounds_str
= strchr (subtype_info
, '_');
11411 if (*subtype_info
== 'L')
11413 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11414 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11416 if (bounds_str
[n
] == '_')
11418 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11424 strcpy (name_buf
+ prefix_len
, "___L");
11425 if (!get_int_var_value (name_buf
, L
))
11427 lim_warning (_("Unknown lower bound, using 1."));
11432 if (*subtype_info
== 'U')
11434 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11435 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11440 strcpy (name_buf
+ prefix_len
, "___U");
11441 if (!get_int_var_value (name_buf
, U
))
11443 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11448 type
= create_static_range_type (alloc_type_copy (raw_type
),
11450 /* create_static_range_type alters the resulting type's length
11451 to match the size of the base_type, which is not what we want.
11452 Set it back to the original range type's length. */
11453 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11454 type
->set_name (name
);
11459 /* True iff NAME is the name of a range type. */
11462 ada_is_range_type_name (const char *name
)
11464 return (name
!= NULL
&& strstr (name
, "___XD"));
11468 /* Modular types */
11470 /* True iff TYPE is an Ada modular type. */
11473 ada_is_modular_type (struct type
*type
)
11475 struct type
*subranged_type
= get_base_type (type
);
11477 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11478 && subranged_type
->code () == TYPE_CODE_INT
11479 && TYPE_UNSIGNED (subranged_type
));
11482 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11485 ada_modulus (struct type
*type
)
11487 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
11491 /* Ada exception catchpoint support:
11492 ---------------------------------
11494 We support 3 kinds of exception catchpoints:
11495 . catchpoints on Ada exceptions
11496 . catchpoints on unhandled Ada exceptions
11497 . catchpoints on failed assertions
11499 Exceptions raised during failed assertions, or unhandled exceptions
11500 could perfectly be caught with the general catchpoint on Ada exceptions.
11501 However, we can easily differentiate these two special cases, and having
11502 the option to distinguish these two cases from the rest can be useful
11503 to zero-in on certain situations.
11505 Exception catchpoints are a specialized form of breakpoint,
11506 since they rely on inserting breakpoints inside known routines
11507 of the GNAT runtime. The implementation therefore uses a standard
11508 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11511 Support in the runtime for exception catchpoints have been changed
11512 a few times already, and these changes affect the implementation
11513 of these catchpoints. In order to be able to support several
11514 variants of the runtime, we use a sniffer that will determine
11515 the runtime variant used by the program being debugged. */
11517 /* Ada's standard exceptions.
11519 The Ada 83 standard also defined Numeric_Error. But there so many
11520 situations where it was unclear from the Ada 83 Reference Manual
11521 (RM) whether Constraint_Error or Numeric_Error should be raised,
11522 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11523 Interpretation saying that anytime the RM says that Numeric_Error
11524 should be raised, the implementation may raise Constraint_Error.
11525 Ada 95 went one step further and pretty much removed Numeric_Error
11526 from the list of standard exceptions (it made it a renaming of
11527 Constraint_Error, to help preserve compatibility when compiling
11528 an Ada83 compiler). As such, we do not include Numeric_Error from
11529 this list of standard exceptions. */
11531 static const char *standard_exc
[] = {
11532 "constraint_error",
11538 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11540 /* A structure that describes how to support exception catchpoints
11541 for a given executable. */
11543 struct exception_support_info
11545 /* The name of the symbol to break on in order to insert
11546 a catchpoint on exceptions. */
11547 const char *catch_exception_sym
;
11549 /* The name of the symbol to break on in order to insert
11550 a catchpoint on unhandled exceptions. */
11551 const char *catch_exception_unhandled_sym
;
11553 /* The name of the symbol to break on in order to insert
11554 a catchpoint on failed assertions. */
11555 const char *catch_assert_sym
;
11557 /* The name of the symbol to break on in order to insert
11558 a catchpoint on exception handling. */
11559 const char *catch_handlers_sym
;
11561 /* Assuming that the inferior just triggered an unhandled exception
11562 catchpoint, this function is responsible for returning the address
11563 in inferior memory where the name of that exception is stored.
11564 Return zero if the address could not be computed. */
11565 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11568 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11569 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11571 /* The following exception support info structure describes how to
11572 implement exception catchpoints with the latest version of the
11573 Ada runtime (as of 2019-08-??). */
11575 static const struct exception_support_info default_exception_support_info
=
11577 "__gnat_debug_raise_exception", /* catch_exception_sym */
11578 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11579 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11580 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11581 ada_unhandled_exception_name_addr
11584 /* The following exception support info structure describes how to
11585 implement exception catchpoints with an earlier version of the
11586 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11588 static const struct exception_support_info exception_support_info_v0
=
11590 "__gnat_debug_raise_exception", /* catch_exception_sym */
11591 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11592 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11593 "__gnat_begin_handler", /* catch_handlers_sym */
11594 ada_unhandled_exception_name_addr
11597 /* The following exception support info structure describes how to
11598 implement exception catchpoints with a slightly older version
11599 of the Ada runtime. */
11601 static const struct exception_support_info exception_support_info_fallback
=
11603 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11604 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11605 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11606 "__gnat_begin_handler", /* catch_handlers_sym */
11607 ada_unhandled_exception_name_addr_from_raise
11610 /* Return nonzero if we can detect the exception support routines
11611 described in EINFO.
11613 This function errors out if an abnormal situation is detected
11614 (for instance, if we find the exception support routines, but
11615 that support is found to be incomplete). */
11618 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11620 struct symbol
*sym
;
11622 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11623 that should be compiled with debugging information. As a result, we
11624 expect to find that symbol in the symtabs. */
11626 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11629 /* Perhaps we did not find our symbol because the Ada runtime was
11630 compiled without debugging info, or simply stripped of it.
11631 It happens on some GNU/Linux distributions for instance, where
11632 users have to install a separate debug package in order to get
11633 the runtime's debugging info. In that situation, let the user
11634 know why we cannot insert an Ada exception catchpoint.
11636 Note: Just for the purpose of inserting our Ada exception
11637 catchpoint, we could rely purely on the associated minimal symbol.
11638 But we would be operating in degraded mode anyway, since we are
11639 still lacking the debugging info needed later on to extract
11640 the name of the exception being raised (this name is printed in
11641 the catchpoint message, and is also used when trying to catch
11642 a specific exception). We do not handle this case for now. */
11643 struct bound_minimal_symbol msym
11644 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11646 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11647 error (_("Your Ada runtime appears to be missing some debugging "
11648 "information.\nCannot insert Ada exception catchpoint "
11649 "in this configuration."));
11654 /* Make sure that the symbol we found corresponds to a function. */
11656 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11658 error (_("Symbol \"%s\" is not a function (class = %d)"),
11659 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11663 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11666 struct bound_minimal_symbol msym
11667 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11669 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11670 error (_("Your Ada runtime appears to be missing some debugging "
11671 "information.\nCannot insert Ada exception catchpoint "
11672 "in this configuration."));
11677 /* Make sure that the symbol we found corresponds to a function. */
11679 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11681 error (_("Symbol \"%s\" is not a function (class = %d)"),
11682 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11689 /* Inspect the Ada runtime and determine which exception info structure
11690 should be used to provide support for exception catchpoints.
11692 This function will always set the per-inferior exception_info,
11693 or raise an error. */
11696 ada_exception_support_info_sniffer (void)
11698 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11700 /* If the exception info is already known, then no need to recompute it. */
11701 if (data
->exception_info
!= NULL
)
11704 /* Check the latest (default) exception support info. */
11705 if (ada_has_this_exception_support (&default_exception_support_info
))
11707 data
->exception_info
= &default_exception_support_info
;
11711 /* Try the v0 exception suport info. */
11712 if (ada_has_this_exception_support (&exception_support_info_v0
))
11714 data
->exception_info
= &exception_support_info_v0
;
11718 /* Try our fallback exception suport info. */
11719 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11721 data
->exception_info
= &exception_support_info_fallback
;
11725 /* Sometimes, it is normal for us to not be able to find the routine
11726 we are looking for. This happens when the program is linked with
11727 the shared version of the GNAT runtime, and the program has not been
11728 started yet. Inform the user of these two possible causes if
11731 if (ada_update_initial_language (language_unknown
) != language_ada
)
11732 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11734 /* If the symbol does not exist, then check that the program is
11735 already started, to make sure that shared libraries have been
11736 loaded. If it is not started, this may mean that the symbol is
11737 in a shared library. */
11739 if (inferior_ptid
.pid () == 0)
11740 error (_("Unable to insert catchpoint. Try to start the program first."));
11742 /* At this point, we know that we are debugging an Ada program and
11743 that the inferior has been started, but we still are not able to
11744 find the run-time symbols. That can mean that we are in
11745 configurable run time mode, or that a-except as been optimized
11746 out by the linker... In any case, at this point it is not worth
11747 supporting this feature. */
11749 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11752 /* True iff FRAME is very likely to be that of a function that is
11753 part of the runtime system. This is all very heuristic, but is
11754 intended to be used as advice as to what frames are uninteresting
11758 is_known_support_routine (struct frame_info
*frame
)
11760 enum language func_lang
;
11762 const char *fullname
;
11764 /* If this code does not have any debugging information (no symtab),
11765 This cannot be any user code. */
11767 symtab_and_line sal
= find_frame_sal (frame
);
11768 if (sal
.symtab
== NULL
)
11771 /* If there is a symtab, but the associated source file cannot be
11772 located, then assume this is not user code: Selecting a frame
11773 for which we cannot display the code would not be very helpful
11774 for the user. This should also take care of case such as VxWorks
11775 where the kernel has some debugging info provided for a few units. */
11777 fullname
= symtab_to_fullname (sal
.symtab
);
11778 if (access (fullname
, R_OK
) != 0)
11781 /* Check the unit filename against the Ada runtime file naming.
11782 We also check the name of the objfile against the name of some
11783 known system libraries that sometimes come with debugging info
11786 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11788 re_comp (known_runtime_file_name_patterns
[i
]);
11789 if (re_exec (lbasename (sal
.symtab
->filename
)))
11791 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11792 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11796 /* Check whether the function is a GNAT-generated entity. */
11798 gdb::unique_xmalloc_ptr
<char> func_name
11799 = find_frame_funname (frame
, &func_lang
, NULL
);
11800 if (func_name
== NULL
)
11803 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11805 re_comp (known_auxiliary_function_name_patterns
[i
]);
11806 if (re_exec (func_name
.get ()))
11813 /* Find the first frame that contains debugging information and that is not
11814 part of the Ada run-time, starting from FI and moving upward. */
11817 ada_find_printable_frame (struct frame_info
*fi
)
11819 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11821 if (!is_known_support_routine (fi
))
11830 /* Assuming that the inferior just triggered an unhandled exception
11831 catchpoint, return the address in inferior memory where the name
11832 of the exception is stored.
11834 Return zero if the address could not be computed. */
11837 ada_unhandled_exception_name_addr (void)
11839 return parse_and_eval_address ("e.full_name");
11842 /* Same as ada_unhandled_exception_name_addr, except that this function
11843 should be used when the inferior uses an older version of the runtime,
11844 where the exception name needs to be extracted from a specific frame
11845 several frames up in the callstack. */
11848 ada_unhandled_exception_name_addr_from_raise (void)
11851 struct frame_info
*fi
;
11852 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11854 /* To determine the name of this exception, we need to select
11855 the frame corresponding to RAISE_SYM_NAME. This frame is
11856 at least 3 levels up, so we simply skip the first 3 frames
11857 without checking the name of their associated function. */
11858 fi
= get_current_frame ();
11859 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11861 fi
= get_prev_frame (fi
);
11865 enum language func_lang
;
11867 gdb::unique_xmalloc_ptr
<char> func_name
11868 = find_frame_funname (fi
, &func_lang
, NULL
);
11869 if (func_name
!= NULL
)
11871 if (strcmp (func_name
.get (),
11872 data
->exception_info
->catch_exception_sym
) == 0)
11873 break; /* We found the frame we were looking for... */
11875 fi
= get_prev_frame (fi
);
11882 return parse_and_eval_address ("id.full_name");
11885 /* Assuming the inferior just triggered an Ada exception catchpoint
11886 (of any type), return the address in inferior memory where the name
11887 of the exception is stored, if applicable.
11889 Assumes the selected frame is the current frame.
11891 Return zero if the address could not be computed, or if not relevant. */
11894 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11895 struct breakpoint
*b
)
11897 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11901 case ada_catch_exception
:
11902 return (parse_and_eval_address ("e.full_name"));
11905 case ada_catch_exception_unhandled
:
11906 return data
->exception_info
->unhandled_exception_name_addr ();
11909 case ada_catch_handlers
:
11910 return 0; /* The runtimes does not provide access to the exception
11914 case ada_catch_assert
:
11915 return 0; /* Exception name is not relevant in this case. */
11919 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11923 return 0; /* Should never be reached. */
11926 /* Assuming the inferior is stopped at an exception catchpoint,
11927 return the message which was associated to the exception, if
11928 available. Return NULL if the message could not be retrieved.
11930 Note: The exception message can be associated to an exception
11931 either through the use of the Raise_Exception function, or
11932 more simply (Ada 2005 and later), via:
11934 raise Exception_Name with "exception message";
11938 static gdb::unique_xmalloc_ptr
<char>
11939 ada_exception_message_1 (void)
11941 struct value
*e_msg_val
;
11944 /* For runtimes that support this feature, the exception message
11945 is passed as an unbounded string argument called "message". */
11946 e_msg_val
= parse_and_eval ("message");
11947 if (e_msg_val
== NULL
)
11948 return NULL
; /* Exception message not supported. */
11950 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
11951 gdb_assert (e_msg_val
!= NULL
);
11952 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
11954 /* If the message string is empty, then treat it as if there was
11955 no exception message. */
11956 if (e_msg_len
<= 0)
11959 return target_read_string (value_address (e_msg_val
), INT_MAX
);
11962 /* Same as ada_exception_message_1, except that all exceptions are
11963 contained here (returning NULL instead). */
11965 static gdb::unique_xmalloc_ptr
<char>
11966 ada_exception_message (void)
11968 gdb::unique_xmalloc_ptr
<char> e_msg
;
11972 e_msg
= ada_exception_message_1 ();
11974 catch (const gdb_exception_error
&e
)
11976 e_msg
.reset (nullptr);
11982 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11983 any error that ada_exception_name_addr_1 might cause to be thrown.
11984 When an error is intercepted, a warning with the error message is printed,
11985 and zero is returned. */
11988 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
11989 struct breakpoint
*b
)
11991 CORE_ADDR result
= 0;
11995 result
= ada_exception_name_addr_1 (ex
, b
);
11998 catch (const gdb_exception_error
&e
)
12000 warning (_("failed to get exception name: %s"), e
.what ());
12007 static std::string ada_exception_catchpoint_cond_string
12008 (const char *excep_string
,
12009 enum ada_exception_catchpoint_kind ex
);
12011 /* Ada catchpoints.
12013 In the case of catchpoints on Ada exceptions, the catchpoint will
12014 stop the target on every exception the program throws. When a user
12015 specifies the name of a specific exception, we translate this
12016 request into a condition expression (in text form), and then parse
12017 it into an expression stored in each of the catchpoint's locations.
12018 We then use this condition to check whether the exception that was
12019 raised is the one the user is interested in. If not, then the
12020 target is resumed again. We store the name of the requested
12021 exception, in order to be able to re-set the condition expression
12022 when symbols change. */
12024 /* An instance of this type is used to represent an Ada catchpoint
12025 breakpoint location. */
12027 class ada_catchpoint_location
: public bp_location
12030 ada_catchpoint_location (breakpoint
*owner
)
12031 : bp_location (owner
, bp_loc_software_breakpoint
)
12034 /* The condition that checks whether the exception that was raised
12035 is the specific exception the user specified on catchpoint
12037 expression_up excep_cond_expr
;
12040 /* An instance of this type is used to represent an Ada catchpoint. */
12042 struct ada_catchpoint
: public breakpoint
12044 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
12049 /* The name of the specific exception the user specified. */
12050 std::string excep_string
;
12052 /* What kind of catchpoint this is. */
12053 enum ada_exception_catchpoint_kind m_kind
;
12056 /* Parse the exception condition string in the context of each of the
12057 catchpoint's locations, and store them for later evaluation. */
12060 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12061 enum ada_exception_catchpoint_kind ex
)
12063 struct bp_location
*bl
;
12065 /* Nothing to do if there's no specific exception to catch. */
12066 if (c
->excep_string
.empty ())
12069 /* Same if there are no locations... */
12070 if (c
->loc
== NULL
)
12073 /* Compute the condition expression in text form, from the specific
12074 expection we want to catch. */
12075 std::string cond_string
12076 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
12078 /* Iterate over all the catchpoint's locations, and parse an
12079 expression for each. */
12080 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
12082 struct ada_catchpoint_location
*ada_loc
12083 = (struct ada_catchpoint_location
*) bl
;
12086 if (!bl
->shlib_disabled
)
12090 s
= cond_string
.c_str ();
12093 exp
= parse_exp_1 (&s
, bl
->address
,
12094 block_for_pc (bl
->address
),
12097 catch (const gdb_exception_error
&e
)
12099 warning (_("failed to reevaluate internal exception condition "
12100 "for catchpoint %d: %s"),
12101 c
->number
, e
.what ());
12105 ada_loc
->excep_cond_expr
= std::move (exp
);
12109 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12110 structure for all exception catchpoint kinds. */
12112 static struct bp_location
*
12113 allocate_location_exception (struct breakpoint
*self
)
12115 return new ada_catchpoint_location (self
);
12118 /* Implement the RE_SET method in the breakpoint_ops structure for all
12119 exception catchpoint kinds. */
12122 re_set_exception (struct breakpoint
*b
)
12124 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12126 /* Call the base class's method. This updates the catchpoint's
12128 bkpt_breakpoint_ops
.re_set (b
);
12130 /* Reparse the exception conditional expressions. One for each
12132 create_excep_cond_exprs (c
, c
->m_kind
);
12135 /* Returns true if we should stop for this breakpoint hit. If the
12136 user specified a specific exception, we only want to cause a stop
12137 if the program thrown that exception. */
12140 should_stop_exception (const struct bp_location
*bl
)
12142 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12143 const struct ada_catchpoint_location
*ada_loc
12144 = (const struct ada_catchpoint_location
*) bl
;
12147 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12148 if (c
->m_kind
== ada_catch_assert
)
12149 clear_internalvar (var
);
12156 if (c
->m_kind
== ada_catch_handlers
)
12157 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12158 ".all.occurrence.id");
12162 struct value
*exc
= parse_and_eval (expr
);
12163 set_internalvar (var
, exc
);
12165 catch (const gdb_exception_error
&ex
)
12167 clear_internalvar (var
);
12171 /* With no specific exception, should always stop. */
12172 if (c
->excep_string
.empty ())
12175 if (ada_loc
->excep_cond_expr
== NULL
)
12177 /* We will have a NULL expression if back when we were creating
12178 the expressions, this location's had failed to parse. */
12185 struct value
*mark
;
12187 mark
= value_mark ();
12188 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12189 value_free_to_mark (mark
);
12191 catch (const gdb_exception
&ex
)
12193 exception_fprintf (gdb_stderr
, ex
,
12194 _("Error in testing exception condition:\n"));
12200 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12201 for all exception catchpoint kinds. */
12204 check_status_exception (bpstat bs
)
12206 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
12209 /* Implement the PRINT_IT method in the breakpoint_ops structure
12210 for all exception catchpoint kinds. */
12212 static enum print_stop_action
12213 print_it_exception (bpstat bs
)
12215 struct ui_out
*uiout
= current_uiout
;
12216 struct breakpoint
*b
= bs
->breakpoint_at
;
12218 annotate_catchpoint (b
->number
);
12220 if (uiout
->is_mi_like_p ())
12222 uiout
->field_string ("reason",
12223 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12224 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12227 uiout
->text (b
->disposition
== disp_del
12228 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12229 uiout
->field_signed ("bkptno", b
->number
);
12230 uiout
->text (", ");
12232 /* ada_exception_name_addr relies on the selected frame being the
12233 current frame. Need to do this here because this function may be
12234 called more than once when printing a stop, and below, we'll
12235 select the first frame past the Ada run-time (see
12236 ada_find_printable_frame). */
12237 select_frame (get_current_frame ());
12239 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12242 case ada_catch_exception
:
12243 case ada_catch_exception_unhandled
:
12244 case ada_catch_handlers
:
12246 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12247 char exception_name
[256];
12251 read_memory (addr
, (gdb_byte
*) exception_name
,
12252 sizeof (exception_name
) - 1);
12253 exception_name
[sizeof (exception_name
) - 1] = '\0';
12257 /* For some reason, we were unable to read the exception
12258 name. This could happen if the Runtime was compiled
12259 without debugging info, for instance. In that case,
12260 just replace the exception name by the generic string
12261 "exception" - it will read as "an exception" in the
12262 notification we are about to print. */
12263 memcpy (exception_name
, "exception", sizeof ("exception"));
12265 /* In the case of unhandled exception breakpoints, we print
12266 the exception name as "unhandled EXCEPTION_NAME", to make
12267 it clearer to the user which kind of catchpoint just got
12268 hit. We used ui_out_text to make sure that this extra
12269 info does not pollute the exception name in the MI case. */
12270 if (c
->m_kind
== ada_catch_exception_unhandled
)
12271 uiout
->text ("unhandled ");
12272 uiout
->field_string ("exception-name", exception_name
);
12275 case ada_catch_assert
:
12276 /* In this case, the name of the exception is not really
12277 important. Just print "failed assertion" to make it clearer
12278 that his program just hit an assertion-failure catchpoint.
12279 We used ui_out_text because this info does not belong in
12281 uiout
->text ("failed assertion");
12285 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12286 if (exception_message
!= NULL
)
12288 uiout
->text (" (");
12289 uiout
->field_string ("exception-message", exception_message
.get ());
12293 uiout
->text (" at ");
12294 ada_find_printable_frame (get_current_frame ());
12296 return PRINT_SRC_AND_LOC
;
12299 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12300 for all exception catchpoint kinds. */
12303 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12305 struct ui_out
*uiout
= current_uiout
;
12306 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12307 struct value_print_options opts
;
12309 get_user_print_options (&opts
);
12311 if (opts
.addressprint
)
12312 uiout
->field_skip ("addr");
12314 annotate_field (5);
12317 case ada_catch_exception
:
12318 if (!c
->excep_string
.empty ())
12320 std::string msg
= string_printf (_("`%s' Ada exception"),
12321 c
->excep_string
.c_str ());
12323 uiout
->field_string ("what", msg
);
12326 uiout
->field_string ("what", "all Ada exceptions");
12330 case ada_catch_exception_unhandled
:
12331 uiout
->field_string ("what", "unhandled Ada exceptions");
12334 case ada_catch_handlers
:
12335 if (!c
->excep_string
.empty ())
12337 uiout
->field_fmt ("what",
12338 _("`%s' Ada exception handlers"),
12339 c
->excep_string
.c_str ());
12342 uiout
->field_string ("what", "all Ada exceptions handlers");
12345 case ada_catch_assert
:
12346 uiout
->field_string ("what", "failed Ada assertions");
12350 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12355 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12356 for all exception catchpoint kinds. */
12359 print_mention_exception (struct breakpoint
*b
)
12361 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12362 struct ui_out
*uiout
= current_uiout
;
12364 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12365 : _("Catchpoint "));
12366 uiout
->field_signed ("bkptno", b
->number
);
12367 uiout
->text (": ");
12371 case ada_catch_exception
:
12372 if (!c
->excep_string
.empty ())
12374 std::string info
= string_printf (_("`%s' Ada exception"),
12375 c
->excep_string
.c_str ());
12376 uiout
->text (info
.c_str ());
12379 uiout
->text (_("all Ada exceptions"));
12382 case ada_catch_exception_unhandled
:
12383 uiout
->text (_("unhandled Ada exceptions"));
12386 case ada_catch_handlers
:
12387 if (!c
->excep_string
.empty ())
12390 = string_printf (_("`%s' Ada exception handlers"),
12391 c
->excep_string
.c_str ());
12392 uiout
->text (info
.c_str ());
12395 uiout
->text (_("all Ada exceptions handlers"));
12398 case ada_catch_assert
:
12399 uiout
->text (_("failed Ada assertions"));
12403 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12408 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12409 for all exception catchpoint kinds. */
12412 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12414 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12418 case ada_catch_exception
:
12419 fprintf_filtered (fp
, "catch exception");
12420 if (!c
->excep_string
.empty ())
12421 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12424 case ada_catch_exception_unhandled
:
12425 fprintf_filtered (fp
, "catch exception unhandled");
12428 case ada_catch_handlers
:
12429 fprintf_filtered (fp
, "catch handlers");
12432 case ada_catch_assert
:
12433 fprintf_filtered (fp
, "catch assert");
12437 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12439 print_recreate_thread (b
, fp
);
12442 /* Virtual tables for various breakpoint types. */
12443 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12444 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12445 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12446 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12448 /* See ada-lang.h. */
12451 is_ada_exception_catchpoint (breakpoint
*bp
)
12453 return (bp
->ops
== &catch_exception_breakpoint_ops
12454 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12455 || bp
->ops
== &catch_assert_breakpoint_ops
12456 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12459 /* Split the arguments specified in a "catch exception" command.
12460 Set EX to the appropriate catchpoint type.
12461 Set EXCEP_STRING to the name of the specific exception if
12462 specified by the user.
12463 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12464 "catch handlers" command. False otherwise.
12465 If a condition is found at the end of the arguments, the condition
12466 expression is stored in COND_STRING (memory must be deallocated
12467 after use). Otherwise COND_STRING is set to NULL. */
12470 catch_ada_exception_command_split (const char *args
,
12471 bool is_catch_handlers_cmd
,
12472 enum ada_exception_catchpoint_kind
*ex
,
12473 std::string
*excep_string
,
12474 std::string
*cond_string
)
12476 std::string exception_name
;
12478 exception_name
= extract_arg (&args
);
12479 if (exception_name
== "if")
12481 /* This is not an exception name; this is the start of a condition
12482 expression for a catchpoint on all exceptions. So, "un-get"
12483 this token, and set exception_name to NULL. */
12484 exception_name
.clear ();
12488 /* Check to see if we have a condition. */
12490 args
= skip_spaces (args
);
12491 if (startswith (args
, "if")
12492 && (isspace (args
[2]) || args
[2] == '\0'))
12495 args
= skip_spaces (args
);
12497 if (args
[0] == '\0')
12498 error (_("Condition missing after `if' keyword"));
12499 *cond_string
= args
;
12501 args
+= strlen (args
);
12504 /* Check that we do not have any more arguments. Anything else
12507 if (args
[0] != '\0')
12508 error (_("Junk at end of expression"));
12510 if (is_catch_handlers_cmd
)
12512 /* Catch handling of exceptions. */
12513 *ex
= ada_catch_handlers
;
12514 *excep_string
= exception_name
;
12516 else if (exception_name
.empty ())
12518 /* Catch all exceptions. */
12519 *ex
= ada_catch_exception
;
12520 excep_string
->clear ();
12522 else if (exception_name
== "unhandled")
12524 /* Catch unhandled exceptions. */
12525 *ex
= ada_catch_exception_unhandled
;
12526 excep_string
->clear ();
12530 /* Catch a specific exception. */
12531 *ex
= ada_catch_exception
;
12532 *excep_string
= exception_name
;
12536 /* Return the name of the symbol on which we should break in order to
12537 implement a catchpoint of the EX kind. */
12539 static const char *
12540 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12542 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12544 gdb_assert (data
->exception_info
!= NULL
);
12548 case ada_catch_exception
:
12549 return (data
->exception_info
->catch_exception_sym
);
12551 case ada_catch_exception_unhandled
:
12552 return (data
->exception_info
->catch_exception_unhandled_sym
);
12554 case ada_catch_assert
:
12555 return (data
->exception_info
->catch_assert_sym
);
12557 case ada_catch_handlers
:
12558 return (data
->exception_info
->catch_handlers_sym
);
12561 internal_error (__FILE__
, __LINE__
,
12562 _("unexpected catchpoint kind (%d)"), ex
);
12566 /* Return the breakpoint ops "virtual table" used for catchpoints
12569 static const struct breakpoint_ops
*
12570 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12574 case ada_catch_exception
:
12575 return (&catch_exception_breakpoint_ops
);
12577 case ada_catch_exception_unhandled
:
12578 return (&catch_exception_unhandled_breakpoint_ops
);
12580 case ada_catch_assert
:
12581 return (&catch_assert_breakpoint_ops
);
12583 case ada_catch_handlers
:
12584 return (&catch_handlers_breakpoint_ops
);
12587 internal_error (__FILE__
, __LINE__
,
12588 _("unexpected catchpoint kind (%d)"), ex
);
12592 /* Return the condition that will be used to match the current exception
12593 being raised with the exception that the user wants to catch. This
12594 assumes that this condition is used when the inferior just triggered
12595 an exception catchpoint.
12596 EX: the type of catchpoints used for catching Ada exceptions. */
12599 ada_exception_catchpoint_cond_string (const char *excep_string
,
12600 enum ada_exception_catchpoint_kind ex
)
12603 bool is_standard_exc
= false;
12604 std::string result
;
12606 if (ex
== ada_catch_handlers
)
12608 /* For exception handlers catchpoints, the condition string does
12609 not use the same parameter as for the other exceptions. */
12610 result
= ("long_integer (GNAT_GCC_exception_Access"
12611 "(gcc_exception).all.occurrence.id)");
12614 result
= "long_integer (e)";
12616 /* The standard exceptions are a special case. They are defined in
12617 runtime units that have been compiled without debugging info; if
12618 EXCEP_STRING is the not-fully-qualified name of a standard
12619 exception (e.g. "constraint_error") then, during the evaluation
12620 of the condition expression, the symbol lookup on this name would
12621 *not* return this standard exception. The catchpoint condition
12622 may then be set only on user-defined exceptions which have the
12623 same not-fully-qualified name (e.g. my_package.constraint_error).
12625 To avoid this unexcepted behavior, these standard exceptions are
12626 systematically prefixed by "standard". This means that "catch
12627 exception constraint_error" is rewritten into "catch exception
12628 standard.constraint_error".
12630 If an exception named constraint_error is defined in another package of
12631 the inferior program, then the only way to specify this exception as a
12632 breakpoint condition is to use its fully-qualified named:
12633 e.g. my_package.constraint_error. */
12635 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12637 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12639 is_standard_exc
= true;
12646 if (is_standard_exc
)
12647 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12649 string_appendf (result
, "long_integer (&%s)", excep_string
);
12654 /* Return the symtab_and_line that should be used to insert an exception
12655 catchpoint of the TYPE kind.
12657 ADDR_STRING returns the name of the function where the real
12658 breakpoint that implements the catchpoints is set, depending on the
12659 type of catchpoint we need to create. */
12661 static struct symtab_and_line
12662 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12663 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12665 const char *sym_name
;
12666 struct symbol
*sym
;
12668 /* First, find out which exception support info to use. */
12669 ada_exception_support_info_sniffer ();
12671 /* Then lookup the function on which we will break in order to catch
12672 the Ada exceptions requested by the user. */
12673 sym_name
= ada_exception_sym_name (ex
);
12674 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12677 error (_("Catchpoint symbol not found: %s"), sym_name
);
12679 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12680 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12682 /* Set ADDR_STRING. */
12683 *addr_string
= sym_name
;
12686 *ops
= ada_exception_breakpoint_ops (ex
);
12688 return find_function_start_sal (sym
, 1);
12691 /* Create an Ada exception catchpoint.
12693 EX_KIND is the kind of exception catchpoint to be created.
12695 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12696 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12697 of the exception to which this catchpoint applies.
12699 COND_STRING, if not empty, is the catchpoint condition.
12701 TEMPFLAG, if nonzero, means that the underlying breakpoint
12702 should be temporary.
12704 FROM_TTY is the usual argument passed to all commands implementations. */
12707 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12708 enum ada_exception_catchpoint_kind ex_kind
,
12709 const std::string
&excep_string
,
12710 const std::string
&cond_string
,
12715 std::string addr_string
;
12716 const struct breakpoint_ops
*ops
= NULL
;
12717 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12719 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12720 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12721 ops
, tempflag
, disabled
, from_tty
);
12722 c
->excep_string
= excep_string
;
12723 create_excep_cond_exprs (c
.get (), ex_kind
);
12724 if (!cond_string
.empty ())
12725 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
);
12726 install_breakpoint (0, std::move (c
), 1);
12729 /* Implement the "catch exception" command. */
12732 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12733 struct cmd_list_element
*command
)
12735 const char *arg
= arg_entry
;
12736 struct gdbarch
*gdbarch
= get_current_arch ();
12738 enum ada_exception_catchpoint_kind ex_kind
;
12739 std::string excep_string
;
12740 std::string cond_string
;
12742 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12746 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12748 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12749 excep_string
, cond_string
,
12750 tempflag
, 1 /* enabled */,
12754 /* Implement the "catch handlers" command. */
12757 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12758 struct cmd_list_element
*command
)
12760 const char *arg
= arg_entry
;
12761 struct gdbarch
*gdbarch
= get_current_arch ();
12763 enum ada_exception_catchpoint_kind ex_kind
;
12764 std::string excep_string
;
12765 std::string cond_string
;
12767 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12771 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12773 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12774 excep_string
, cond_string
,
12775 tempflag
, 1 /* enabled */,
12779 /* Completion function for the Ada "catch" commands. */
12782 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12783 const char *text
, const char *word
)
12785 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12787 for (const ada_exc_info
&info
: exceptions
)
12789 if (startswith (info
.name
, word
))
12790 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12794 /* Split the arguments specified in a "catch assert" command.
12796 ARGS contains the command's arguments (or the empty string if
12797 no arguments were passed).
12799 If ARGS contains a condition, set COND_STRING to that condition
12800 (the memory needs to be deallocated after use). */
12803 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12805 args
= skip_spaces (args
);
12807 /* Check whether a condition was provided. */
12808 if (startswith (args
, "if")
12809 && (isspace (args
[2]) || args
[2] == '\0'))
12812 args
= skip_spaces (args
);
12813 if (args
[0] == '\0')
12814 error (_("condition missing after `if' keyword"));
12815 cond_string
.assign (args
);
12818 /* Otherwise, there should be no other argument at the end of
12820 else if (args
[0] != '\0')
12821 error (_("Junk at end of arguments."));
12824 /* Implement the "catch assert" command. */
12827 catch_assert_command (const char *arg_entry
, int from_tty
,
12828 struct cmd_list_element
*command
)
12830 const char *arg
= arg_entry
;
12831 struct gdbarch
*gdbarch
= get_current_arch ();
12833 std::string cond_string
;
12835 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12839 catch_ada_assert_command_split (arg
, cond_string
);
12840 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12842 tempflag
, 1 /* enabled */,
12846 /* Return non-zero if the symbol SYM is an Ada exception object. */
12849 ada_is_exception_sym (struct symbol
*sym
)
12851 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12853 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12854 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12855 && SYMBOL_CLASS (sym
) != LOC_CONST
12856 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12857 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12860 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12861 Ada exception object. This matches all exceptions except the ones
12862 defined by the Ada language. */
12865 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12869 if (!ada_is_exception_sym (sym
))
12872 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12873 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
12874 return 0; /* A standard exception. */
12876 /* Numeric_Error is also a standard exception, so exclude it.
12877 See the STANDARD_EXC description for more details as to why
12878 this exception is not listed in that array. */
12879 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12885 /* A helper function for std::sort, comparing two struct ada_exc_info
12888 The comparison is determined first by exception name, and then
12889 by exception address. */
12892 ada_exc_info::operator< (const ada_exc_info
&other
) const
12896 result
= strcmp (name
, other
.name
);
12899 if (result
== 0 && addr
< other
.addr
)
12905 ada_exc_info::operator== (const ada_exc_info
&other
) const
12907 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12910 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12911 routine, but keeping the first SKIP elements untouched.
12913 All duplicates are also removed. */
12916 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12919 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12920 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12921 exceptions
->end ());
12924 /* Add all exceptions defined by the Ada standard whose name match
12925 a regular expression.
12927 If PREG is not NULL, then this regexp_t object is used to
12928 perform the symbol name matching. Otherwise, no name-based
12929 filtering is performed.
12931 EXCEPTIONS is a vector of exceptions to which matching exceptions
12935 ada_add_standard_exceptions (compiled_regex
*preg
,
12936 std::vector
<ada_exc_info
> *exceptions
)
12940 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12943 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
12945 struct bound_minimal_symbol msymbol
12946 = ada_lookup_simple_minsym (standard_exc
[i
]);
12948 if (msymbol
.minsym
!= NULL
)
12950 struct ada_exc_info info
12951 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
12953 exceptions
->push_back (info
);
12959 /* Add all Ada exceptions defined locally and accessible from the given
12962 If PREG is not NULL, then this regexp_t object is used to
12963 perform the symbol name matching. Otherwise, no name-based
12964 filtering is performed.
12966 EXCEPTIONS is a vector of exceptions to which matching exceptions
12970 ada_add_exceptions_from_frame (compiled_regex
*preg
,
12971 struct frame_info
*frame
,
12972 std::vector
<ada_exc_info
> *exceptions
)
12974 const struct block
*block
= get_frame_block (frame
, 0);
12978 struct block_iterator iter
;
12979 struct symbol
*sym
;
12981 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
12983 switch (SYMBOL_CLASS (sym
))
12990 if (ada_is_exception_sym (sym
))
12992 struct ada_exc_info info
= {sym
->print_name (),
12993 SYMBOL_VALUE_ADDRESS (sym
)};
12995 exceptions
->push_back (info
);
12999 if (BLOCK_FUNCTION (block
) != NULL
)
13001 block
= BLOCK_SUPERBLOCK (block
);
13005 /* Return true if NAME matches PREG or if PREG is NULL. */
13008 name_matches_regex (const char *name
, compiled_regex
*preg
)
13010 return (preg
== NULL
13011 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
13014 /* Add all exceptions defined globally whose name name match
13015 a regular expression, excluding standard exceptions.
13017 The reason we exclude standard exceptions is that they need
13018 to be handled separately: Standard exceptions are defined inside
13019 a runtime unit which is normally not compiled with debugging info,
13020 and thus usually do not show up in our symbol search. However,
13021 if the unit was in fact built with debugging info, we need to
13022 exclude them because they would duplicate the entry we found
13023 during the special loop that specifically searches for those
13024 standard exceptions.
13026 If PREG is not NULL, then this regexp_t object is used to
13027 perform the symbol name matching. Otherwise, no name-based
13028 filtering is performed.
13030 EXCEPTIONS is a vector of exceptions to which matching exceptions
13034 ada_add_global_exceptions (compiled_regex
*preg
,
13035 std::vector
<ada_exc_info
> *exceptions
)
13037 /* In Ada, the symbol "search name" is a linkage name, whereas the
13038 regular expression used to do the matching refers to the natural
13039 name. So match against the decoded name. */
13040 expand_symtabs_matching (NULL
,
13041 lookup_name_info::match_any (),
13042 [&] (const char *search_name
)
13044 std::string decoded
= ada_decode (search_name
);
13045 return name_matches_regex (decoded
.c_str (), preg
);
13050 for (objfile
*objfile
: current_program_space
->objfiles ())
13052 for (compunit_symtab
*s
: objfile
->compunits ())
13054 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13057 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13059 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13060 struct block_iterator iter
;
13061 struct symbol
*sym
;
13063 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13064 if (ada_is_non_standard_exception_sym (sym
)
13065 && name_matches_regex (sym
->natural_name (), preg
))
13067 struct ada_exc_info info
13068 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
13070 exceptions
->push_back (info
);
13077 /* Implements ada_exceptions_list with the regular expression passed
13078 as a regex_t, rather than a string.
13080 If not NULL, PREG is used to filter out exceptions whose names
13081 do not match. Otherwise, all exceptions are listed. */
13083 static std::vector
<ada_exc_info
>
13084 ada_exceptions_list_1 (compiled_regex
*preg
)
13086 std::vector
<ada_exc_info
> result
;
13089 /* First, list the known standard exceptions. These exceptions
13090 need to be handled separately, as they are usually defined in
13091 runtime units that have been compiled without debugging info. */
13093 ada_add_standard_exceptions (preg
, &result
);
13095 /* Next, find all exceptions whose scope is local and accessible
13096 from the currently selected frame. */
13098 if (has_stack_frames ())
13100 prev_len
= result
.size ();
13101 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13103 if (result
.size () > prev_len
)
13104 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13107 /* Add all exceptions whose scope is global. */
13109 prev_len
= result
.size ();
13110 ada_add_global_exceptions (preg
, &result
);
13111 if (result
.size () > prev_len
)
13112 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13117 /* Return a vector of ada_exc_info.
13119 If REGEXP is NULL, all exceptions are included in the result.
13120 Otherwise, it should contain a valid regular expression,
13121 and only the exceptions whose names match that regular expression
13122 are included in the result.
13124 The exceptions are sorted in the following order:
13125 - Standard exceptions (defined by the Ada language), in
13126 alphabetical order;
13127 - Exceptions only visible from the current frame, in
13128 alphabetical order;
13129 - Exceptions whose scope is global, in alphabetical order. */
13131 std::vector
<ada_exc_info
>
13132 ada_exceptions_list (const char *regexp
)
13134 if (regexp
== NULL
)
13135 return ada_exceptions_list_1 (NULL
);
13137 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13138 return ada_exceptions_list_1 (®
);
13141 /* Implement the "info exceptions" command. */
13144 info_exceptions_command (const char *regexp
, int from_tty
)
13146 struct gdbarch
*gdbarch
= get_current_arch ();
13148 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13150 if (regexp
!= NULL
)
13152 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13154 printf_filtered (_("All defined Ada exceptions:\n"));
13156 for (const ada_exc_info
&info
: exceptions
)
13157 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13161 /* Information about operators given special treatment in functions
13163 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13165 #define ADA_OPERATORS \
13166 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13167 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13168 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13169 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13170 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13171 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13172 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13173 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13174 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13175 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13176 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13177 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13178 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13179 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13180 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13181 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13182 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13183 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13184 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13187 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13190 switch (exp
->elts
[pc
- 1].opcode
)
13193 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13196 #define OP_DEFN(op, len, args, binop) \
13197 case op: *oplenp = len; *argsp = args; break;
13203 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13208 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13213 /* Implementation of the exp_descriptor method operator_check. */
13216 ada_operator_check (struct expression
*exp
, int pos
,
13217 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13220 const union exp_element
*const elts
= exp
->elts
;
13221 struct type
*type
= NULL
;
13223 switch (elts
[pos
].opcode
)
13225 case UNOP_IN_RANGE
:
13227 type
= elts
[pos
+ 1].type
;
13231 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13234 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13236 if (type
&& TYPE_OBJFILE (type
)
13237 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13243 static const char *
13244 ada_op_name (enum exp_opcode opcode
)
13249 return op_name_standard (opcode
);
13251 #define OP_DEFN(op, len, args, binop) case op: return #op;
13256 return "OP_AGGREGATE";
13258 return "OP_CHOICES";
13264 /* As for operator_length, but assumes PC is pointing at the first
13265 element of the operator, and gives meaningful results only for the
13266 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13269 ada_forward_operator_length (struct expression
*exp
, int pc
,
13270 int *oplenp
, int *argsp
)
13272 switch (exp
->elts
[pc
].opcode
)
13275 *oplenp
= *argsp
= 0;
13278 #define OP_DEFN(op, len, args, binop) \
13279 case op: *oplenp = len; *argsp = args; break;
13285 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13290 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13296 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13298 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13306 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13308 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13313 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13317 /* Ada attributes ('Foo). */
13320 case OP_ATR_LENGTH
:
13324 case OP_ATR_MODULUS
:
13331 case UNOP_IN_RANGE
:
13333 /* XXX: gdb_sprint_host_address, type_sprint */
13334 fprintf_filtered (stream
, _("Type @"));
13335 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13336 fprintf_filtered (stream
, " (");
13337 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13338 fprintf_filtered (stream
, ")");
13340 case BINOP_IN_BOUNDS
:
13341 fprintf_filtered (stream
, " (%d)",
13342 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13344 case TERNOP_IN_RANGE
:
13349 case OP_DISCRETE_RANGE
:
13350 case OP_POSITIONAL
:
13357 char *name
= &exp
->elts
[elt
+ 2].string
;
13358 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13360 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13365 return dump_subexp_body_standard (exp
, stream
, elt
);
13369 for (i
= 0; i
< nargs
; i
+= 1)
13370 elt
= dump_subexp (exp
, stream
, elt
);
13375 /* The Ada extension of print_subexp (q.v.). */
13378 ada_print_subexp (struct expression
*exp
, int *pos
,
13379 struct ui_file
*stream
, enum precedence prec
)
13381 int oplen
, nargs
, i
;
13383 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13385 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13392 print_subexp_standard (exp
, pos
, stream
, prec
);
13396 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13399 case BINOP_IN_BOUNDS
:
13400 /* XXX: sprint_subexp */
13401 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13402 fputs_filtered (" in ", stream
);
13403 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13404 fputs_filtered ("'range", stream
);
13405 if (exp
->elts
[pc
+ 1].longconst
> 1)
13406 fprintf_filtered (stream
, "(%ld)",
13407 (long) exp
->elts
[pc
+ 1].longconst
);
13410 case TERNOP_IN_RANGE
:
13411 if (prec
>= PREC_EQUAL
)
13412 fputs_filtered ("(", stream
);
13413 /* XXX: sprint_subexp */
13414 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13415 fputs_filtered (" in ", stream
);
13416 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13417 fputs_filtered (" .. ", stream
);
13418 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13419 if (prec
>= PREC_EQUAL
)
13420 fputs_filtered (")", stream
);
13425 case OP_ATR_LENGTH
:
13429 case OP_ATR_MODULUS
:
13434 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13436 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13437 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13438 &type_print_raw_options
);
13442 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13443 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13448 for (tem
= 1; tem
< nargs
; tem
+= 1)
13450 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13451 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13453 fputs_filtered (")", stream
);
13458 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13459 fputs_filtered ("'(", stream
);
13460 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13461 fputs_filtered (")", stream
);
13464 case UNOP_IN_RANGE
:
13465 /* XXX: sprint_subexp */
13466 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13467 fputs_filtered (" in ", stream
);
13468 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13469 &type_print_raw_options
);
13472 case OP_DISCRETE_RANGE
:
13473 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13474 fputs_filtered ("..", stream
);
13475 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13479 fputs_filtered ("others => ", stream
);
13480 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13484 for (i
= 0; i
< nargs
-1; i
+= 1)
13487 fputs_filtered ("|", stream
);
13488 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13490 fputs_filtered (" => ", stream
);
13491 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13494 case OP_POSITIONAL
:
13495 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13499 fputs_filtered ("(", stream
);
13500 for (i
= 0; i
< nargs
; i
+= 1)
13503 fputs_filtered (", ", stream
);
13504 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13506 fputs_filtered (")", stream
);
13511 /* Table mapping opcodes into strings for printing operators
13512 and precedences of the operators. */
13514 static const struct op_print ada_op_print_tab
[] = {
13515 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13516 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13517 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13518 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13519 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13520 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13521 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13522 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13523 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13524 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13525 {">", BINOP_GTR
, PREC_ORDER
, 0},
13526 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13527 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13528 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13529 {"+", BINOP_ADD
, PREC_ADD
, 0},
13530 {"-", BINOP_SUB
, PREC_ADD
, 0},
13531 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13532 {"*", BINOP_MUL
, PREC_MUL
, 0},
13533 {"/", BINOP_DIV
, PREC_MUL
, 0},
13534 {"rem", BINOP_REM
, PREC_MUL
, 0},
13535 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13536 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13537 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13538 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13539 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13540 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13541 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13542 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13543 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13544 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13545 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13546 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13549 enum ada_primitive_types
{
13550 ada_primitive_type_int
,
13551 ada_primitive_type_long
,
13552 ada_primitive_type_short
,
13553 ada_primitive_type_char
,
13554 ada_primitive_type_float
,
13555 ada_primitive_type_double
,
13556 ada_primitive_type_void
,
13557 ada_primitive_type_long_long
,
13558 ada_primitive_type_long_double
,
13559 ada_primitive_type_natural
,
13560 ada_primitive_type_positive
,
13561 ada_primitive_type_system_address
,
13562 ada_primitive_type_storage_offset
,
13563 nr_ada_primitive_types
13567 /* Language vector */
13569 /* Not really used, but needed in the ada_language_defn. */
13572 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
13574 ada_emit_char (c
, type
, stream
, quoter
, 1);
13578 parse (struct parser_state
*ps
)
13580 warnings_issued
= 0;
13581 return ada_parse (ps
);
13584 static const struct exp_descriptor ada_exp_descriptor
= {
13586 ada_operator_length
,
13587 ada_operator_check
,
13589 ada_dump_subexp_body
,
13590 ada_evaluate_subexp
13593 /* symbol_name_matcher_ftype adapter for wild_match. */
13596 do_wild_match (const char *symbol_search_name
,
13597 const lookup_name_info
&lookup_name
,
13598 completion_match_result
*comp_match_res
)
13600 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13603 /* symbol_name_matcher_ftype adapter for full_match. */
13606 do_full_match (const char *symbol_search_name
,
13607 const lookup_name_info
&lookup_name
,
13608 completion_match_result
*comp_match_res
)
13610 return full_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13613 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13616 do_exact_match (const char *symbol_search_name
,
13617 const lookup_name_info
&lookup_name
,
13618 completion_match_result
*comp_match_res
)
13620 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13623 /* Build the Ada lookup name for LOOKUP_NAME. */
13625 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13627 gdb::string_view user_name
= lookup_name
.name ();
13629 if (user_name
[0] == '<')
13631 if (user_name
.back () == '>')
13633 = user_name
.substr (1, user_name
.size () - 2).to_string ();
13636 = user_name
.substr (1, user_name
.size () - 1).to_string ();
13637 m_encoded_p
= true;
13638 m_verbatim_p
= true;
13639 m_wild_match_p
= false;
13640 m_standard_p
= false;
13644 m_verbatim_p
= false;
13646 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13650 const char *folded
= ada_fold_name (user_name
);
13651 const char *encoded
= ada_encode_1 (folded
, false);
13652 if (encoded
!= NULL
)
13653 m_encoded_name
= encoded
;
13655 m_encoded_name
= user_name
.to_string ();
13658 m_encoded_name
= user_name
.to_string ();
13660 /* Handle the 'package Standard' special case. See description
13661 of m_standard_p. */
13662 if (startswith (m_encoded_name
.c_str (), "standard__"))
13664 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13665 m_standard_p
= true;
13668 m_standard_p
= false;
13670 /* If the name contains a ".", then the user is entering a fully
13671 qualified entity name, and the match must not be done in wild
13672 mode. Similarly, if the user wants to complete what looks
13673 like an encoded name, the match must not be done in wild
13674 mode. Also, in the standard__ special case always do
13675 non-wild matching. */
13677 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13680 && user_name
.find ('.') == std::string::npos
);
13684 /* symbol_name_matcher_ftype method for Ada. This only handles
13685 completion mode. */
13688 ada_symbol_name_matches (const char *symbol_search_name
,
13689 const lookup_name_info
&lookup_name
,
13690 completion_match_result
*comp_match_res
)
13692 return lookup_name
.ada ().matches (symbol_search_name
,
13693 lookup_name
.match_type (),
13697 /* A name matcher that matches the symbol name exactly, with
13701 literal_symbol_name_matcher (const char *symbol_search_name
,
13702 const lookup_name_info
&lookup_name
,
13703 completion_match_result
*comp_match_res
)
13705 gdb::string_view name_view
= lookup_name
.name ();
13707 if (lookup_name
.completion_mode ()
13708 ? (strncmp (symbol_search_name
, name_view
.data (),
13709 name_view
.size ()) == 0)
13710 : symbol_search_name
== name_view
)
13712 if (comp_match_res
!= NULL
)
13713 comp_match_res
->set_match (symbol_search_name
);
13720 /* Implement the "get_symbol_name_matcher" language_defn method for
13723 static symbol_name_matcher_ftype
*
13724 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13726 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13727 return literal_symbol_name_matcher
;
13729 if (lookup_name
.completion_mode ())
13730 return ada_symbol_name_matches
;
13733 if (lookup_name
.ada ().wild_match_p ())
13734 return do_wild_match
;
13735 else if (lookup_name
.ada ().verbatim_p ())
13736 return do_exact_match
;
13738 return do_full_match
;
13742 static const char *ada_extensions
[] =
13744 ".adb", ".ads", ".a", ".ada", ".dg", NULL
13747 /* Constant data that describes the Ada language. */
13749 extern const struct language_data ada_language_data
=
13751 "ada", /* Language name */
13755 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
13756 that's not quite what this means. */
13758 macro_expansion_no
,
13760 &ada_exp_descriptor
,
13763 ada_printchar
, /* Print a character constant */
13764 ada_printstr
, /* Function to print string constant */
13765 emit_char
, /* Function to print single char (not used) */
13766 ada_print_typedef
, /* Print a typedef using appropriate syntax */
13767 NULL
, /* name_of_this */
13768 true, /* la_store_sym_names_in_linkage_form_p */
13769 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
13770 ada_op_print_tab
, /* expression operators for printing */
13771 0, /* c-style arrays */
13772 1, /* String lower bound */
13774 ada_is_string_type
,
13775 "(...)" /* la_struct_too_deep_ellipsis */
13778 /* Class representing the Ada language. */
13780 class ada_language
: public language_defn
13784 : language_defn (language_ada
, ada_language_data
)
13787 /* Print an array element index using the Ada syntax. */
13789 void print_array_index (struct type
*index_type
,
13791 struct ui_file
*stream
,
13792 const value_print_options
*options
) const override
13794 struct value
*index_value
= val_atr (index_type
, index
);
13796 LA_VALUE_PRINT (index_value
, stream
, options
);
13797 fprintf_filtered (stream
, " => ");
13800 /* Implement the "read_var_value" language_defn method for Ada. */
13802 struct value
*read_var_value (struct symbol
*var
,
13803 const struct block
*var_block
,
13804 struct frame_info
*frame
) const override
13806 /* The only case where default_read_var_value is not sufficient
13807 is when VAR is a renaming... */
13808 if (frame
!= nullptr)
13810 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13811 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13812 return ada_read_renaming_var_value (var
, frame_block
);
13815 /* This is a typical case where we expect the default_read_var_value
13816 function to work. */
13817 return language_defn::read_var_value (var
, var_block
, frame
);
13820 /* See language.h. */
13821 void language_arch_info (struct gdbarch
*gdbarch
,
13822 struct language_arch_info
*lai
) const override
13824 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13826 lai
->primitive_type_vector
13827 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
13830 lai
->primitive_type_vector
[ada_primitive_type_int
]
13831 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13833 lai
->primitive_type_vector
[ada_primitive_type_long
]
13834 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13835 0, "long_integer");
13836 lai
->primitive_type_vector
[ada_primitive_type_short
]
13837 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13838 0, "short_integer");
13839 lai
->string_char_type
13840 = lai
->primitive_type_vector
[ada_primitive_type_char
]
13841 = arch_character_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
13842 lai
->primitive_type_vector
[ada_primitive_type_float
]
13843 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13844 "float", gdbarch_float_format (gdbarch
));
13845 lai
->primitive_type_vector
[ada_primitive_type_double
]
13846 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13847 "long_float", gdbarch_double_format (gdbarch
));
13848 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
13849 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13850 0, "long_long_integer");
13851 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
13852 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13853 "long_long_float", gdbarch_long_double_format (gdbarch
));
13854 lai
->primitive_type_vector
[ada_primitive_type_natural
]
13855 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13857 lai
->primitive_type_vector
[ada_primitive_type_positive
]
13858 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13860 lai
->primitive_type_vector
[ada_primitive_type_void
]
13861 = builtin
->builtin_void
;
13863 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
13864 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13866 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
13867 ->set_name ("system__address");
13869 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13870 type. This is a signed integral type whose size is the same as
13871 the size of addresses. */
13873 unsigned int addr_length
= TYPE_LENGTH
13874 (lai
->primitive_type_vector
[ada_primitive_type_system_address
]);
13876 lai
->primitive_type_vector
[ada_primitive_type_storage_offset
]
13877 = arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13881 lai
->bool_type_symbol
= NULL
;
13882 lai
->bool_type_default
= builtin
->builtin_bool
;
13885 /* See language.h. */
13887 bool iterate_over_symbols
13888 (const struct block
*block
, const lookup_name_info
&name
,
13889 domain_enum domain
,
13890 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13892 std::vector
<struct block_symbol
> results
;
13894 ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
13895 for (block_symbol
&sym
: results
)
13897 if (!callback (&sym
))
13904 /* See language.h. */
13905 bool sniff_from_mangled_name (const char *mangled
,
13906 char **out
) const override
13908 std::string demangled
= ada_decode (mangled
);
13912 if (demangled
!= mangled
&& demangled
[0] != '<')
13914 /* Set the gsymbol language to Ada, but still return 0.
13915 Two reasons for that:
13917 1. For Ada, we prefer computing the symbol's decoded name
13918 on the fly rather than pre-compute it, in order to save
13919 memory (Ada projects are typically very large).
13921 2. There are some areas in the definition of the GNAT
13922 encoding where, with a bit of bad luck, we might be able
13923 to decode a non-Ada symbol, generating an incorrect
13924 demangled name (Eg: names ending with "TB" for instance
13925 are identified as task bodies and so stripped from
13926 the decoded name returned).
13928 Returning true, here, but not setting *DEMANGLED, helps us get
13929 a little bit of the best of both worlds. Because we're last,
13930 we should not affect any of the other languages that were
13931 able to demangle the symbol before us; we get to correctly
13932 tag Ada symbols as such; and even if we incorrectly tagged a
13933 non-Ada symbol, which should be rare, any routing through the
13934 Ada language should be transparent (Ada tries to behave much
13935 like C/C++ with non-Ada symbols). */
13942 /* See language.h. */
13944 char *demangle (const char *mangled
, int options
) const override
13946 return ada_la_decode (mangled
, options
);
13949 /* See language.h. */
13951 void print_type (struct type
*type
, const char *varstring
,
13952 struct ui_file
*stream
, int show
, int level
,
13953 const struct type_print_options
*flags
) const override
13955 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13958 /* See language.h. */
13960 const char *word_break_characters (void) const override
13962 return ada_completer_word_break_characters
;
13965 /* See language.h. */
13967 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13968 complete_symbol_mode mode
,
13969 symbol_name_match_type name_match_type
,
13970 const char *text
, const char *word
,
13971 enum type_code code
) const override
13973 struct symbol
*sym
;
13974 const struct block
*b
, *surrounding_static_block
= 0;
13975 struct block_iterator iter
;
13977 gdb_assert (code
== TYPE_CODE_UNDEF
);
13979 lookup_name_info
lookup_name (text
, name_match_type
, true);
13981 /* First, look at the partial symtab symbols. */
13982 expand_symtabs_matching (NULL
,
13988 /* At this point scan through the misc symbol vectors and add each
13989 symbol you find to the list. Eventually we want to ignore
13990 anything that isn't a text symbol (everything else will be
13991 handled by the psymtab code above). */
13993 for (objfile
*objfile
: current_program_space
->objfiles ())
13995 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
13999 if (completion_skip_symbol (mode
, msymbol
))
14002 language symbol_language
= msymbol
->language ();
14004 /* Ada minimal symbols won't have their language set to Ada. If
14005 we let completion_list_add_name compare using the
14006 default/C-like matcher, then when completing e.g., symbols in a
14007 package named "pck", we'd match internal Ada symbols like
14008 "pckS", which are invalid in an Ada expression, unless you wrap
14009 them in '<' '>' to request a verbatim match.
14011 Unfortunately, some Ada encoded names successfully demangle as
14012 C++ symbols (using an old mangling scheme), such as "name__2Xn"
14013 -> "Xn::name(void)" and thus some Ada minimal symbols end up
14014 with the wrong language set. Paper over that issue here. */
14015 if (symbol_language
== language_auto
14016 || symbol_language
== language_cplus
)
14017 symbol_language
= language_ada
;
14019 completion_list_add_name (tracker
,
14021 msymbol
->linkage_name (),
14022 lookup_name
, text
, word
);
14026 /* Search upwards from currently selected frame (so that we can
14027 complete on local vars. */
14029 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
14031 if (!BLOCK_SUPERBLOCK (b
))
14032 surrounding_static_block
= b
; /* For elmin of dups */
14034 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14036 if (completion_skip_symbol (mode
, sym
))
14039 completion_list_add_name (tracker
,
14041 sym
->linkage_name (),
14042 lookup_name
, text
, word
);
14046 /* Go through the symtabs and check the externs and statics for
14047 symbols which match. */
14049 for (objfile
*objfile
: current_program_space
->objfiles ())
14051 for (compunit_symtab
*s
: objfile
->compunits ())
14054 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
14055 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14057 if (completion_skip_symbol (mode
, sym
))
14060 completion_list_add_name (tracker
,
14062 sym
->linkage_name (),
14063 lookup_name
, text
, word
);
14068 for (objfile
*objfile
: current_program_space
->objfiles ())
14070 for (compunit_symtab
*s
: objfile
->compunits ())
14073 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
14074 /* Don't do this block twice. */
14075 if (b
== surrounding_static_block
)
14077 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14079 if (completion_skip_symbol (mode
, sym
))
14082 completion_list_add_name (tracker
,
14084 sym
->linkage_name (),
14085 lookup_name
, text
, word
);
14091 /* See language.h. */
14093 gdb::unique_xmalloc_ptr
<char> watch_location_expression
14094 (struct type
*type
, CORE_ADDR addr
) const override
14096 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
14097 std::string name
= type_to_string (type
);
14098 return gdb::unique_xmalloc_ptr
<char>
14099 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
14102 /* See language.h. */
14104 void value_print (struct value
*val
, struct ui_file
*stream
,
14105 const struct value_print_options
*options
) const override
14107 return ada_value_print (val
, stream
, options
);
14110 /* See language.h. */
14112 void value_print_inner
14113 (struct value
*val
, struct ui_file
*stream
, int recurse
,
14114 const struct value_print_options
*options
) const override
14116 return ada_value_print_inner (val
, stream
, recurse
, options
);
14120 /* See language.h. */
14122 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14123 (const lookup_name_info
&lookup_name
) const override
14125 return ada_get_symbol_name_matcher (lookup_name
);
14129 /* Single instance of the Ada language class. */
14131 static ada_language ada_language_defn
;
14133 /* Command-list for the "set/show ada" prefix command. */
14134 static struct cmd_list_element
*set_ada_list
;
14135 static struct cmd_list_element
*show_ada_list
;
14138 initialize_ada_catchpoint_ops (void)
14140 struct breakpoint_ops
*ops
;
14142 initialize_breakpoint_ops ();
14144 ops
= &catch_exception_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_exception_unhandled_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_assert_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
;
14174 ops
= &catch_handlers_breakpoint_ops
;
14175 *ops
= bkpt_breakpoint_ops
;
14176 ops
->allocate_location
= allocate_location_exception
;
14177 ops
->re_set
= re_set_exception
;
14178 ops
->check_status
= check_status_exception
;
14179 ops
->print_it
= print_it_exception
;
14180 ops
->print_one
= print_one_exception
;
14181 ops
->print_mention
= print_mention_exception
;
14182 ops
->print_recreate
= print_recreate_exception
;
14185 /* This module's 'new_objfile' observer. */
14188 ada_new_objfile_observer (struct objfile
*objfile
)
14190 ada_clear_symbol_cache ();
14193 /* This module's 'free_objfile' observer. */
14196 ada_free_objfile_observer (struct objfile
*objfile
)
14198 ada_clear_symbol_cache ();
14201 void _initialize_ada_language ();
14203 _initialize_ada_language ()
14205 initialize_ada_catchpoint_ops ();
14207 add_basic_prefix_cmd ("ada", no_class
,
14208 _("Prefix command for changing Ada-specific settings."),
14209 &set_ada_list
, "set ada ", 0, &setlist
);
14211 add_show_prefix_cmd ("ada", no_class
,
14212 _("Generic command for showing Ada-specific settings."),
14213 &show_ada_list
, "show ada ", 0, &showlist
);
14215 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14216 &trust_pad_over_xvs
, _("\
14217 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14218 Show whether an optimization trusting PAD types over XVS types is activated."),
14220 This is related to the encoding used by the GNAT compiler. The debugger\n\
14221 should normally trust the contents of PAD types, but certain older versions\n\
14222 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14223 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14224 work around this bug. It is always safe to turn this option \"off\", but\n\
14225 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14226 this option to \"off\" unless necessary."),
14227 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14229 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14230 &print_signatures
, _("\
14231 Enable or disable the output of formal and return types for functions in the \
14232 overloads selection menu."), _("\
14233 Show whether the output of formal and return types for functions in the \
14234 overloads selection menu is activated."),
14235 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14237 add_catch_command ("exception", _("\
14238 Catch Ada exceptions, when raised.\n\
14239 Usage: catch exception [ARG] [if CONDITION]\n\
14240 Without any argument, stop when any Ada exception is raised.\n\
14241 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14242 being raised does not have a handler (and will therefore lead to the task's\n\
14244 Otherwise, the catchpoint only stops when the name of the exception being\n\
14245 raised is the same as ARG.\n\
14246 CONDITION is a boolean expression that is evaluated to see whether the\n\
14247 exception should cause a stop."),
14248 catch_ada_exception_command
,
14249 catch_ada_completer
,
14253 add_catch_command ("handlers", _("\
14254 Catch Ada exceptions, when handled.\n\
14255 Usage: catch handlers [ARG] [if CONDITION]\n\
14256 Without any argument, stop when any Ada exception is handled.\n\
14257 With an argument, catch only exceptions with the given name.\n\
14258 CONDITION is a boolean expression that is evaluated to see whether the\n\
14259 exception should cause a stop."),
14260 catch_ada_handlers_command
,
14261 catch_ada_completer
,
14264 add_catch_command ("assert", _("\
14265 Catch failed Ada assertions, when raised.\n\
14266 Usage: catch assert [if CONDITION]\n\
14267 CONDITION is a boolean expression that is evaluated to see whether the\n\
14268 exception should cause a stop."),
14269 catch_assert_command
,
14274 varsize_limit
= 65536;
14275 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14276 &varsize_limit
, _("\
14277 Set the maximum number of bytes allowed in a variable-size object."), _("\
14278 Show the maximum number of bytes allowed in a variable-size object."), _("\
14279 Attempts to access an object whose size is not a compile-time constant\n\
14280 and exceeds this limit will cause an error."),
14281 NULL
, NULL
, &setlist
, &showlist
);
14283 add_info ("exceptions", info_exceptions_command
,
14285 List all Ada exception names.\n\
14286 Usage: info exceptions [REGEXP]\n\
14287 If a regular expression is passed as an argument, only those matching\n\
14288 the regular expression are listed."));
14290 add_basic_prefix_cmd ("ada", class_maintenance
,
14291 _("Set Ada maintenance-related variables."),
14292 &maint_set_ada_cmdlist
, "maintenance set ada ",
14293 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14295 add_show_prefix_cmd ("ada", class_maintenance
,
14296 _("Show Ada maintenance-related variables."),
14297 &maint_show_ada_cmdlist
, "maintenance show ada ",
14298 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14300 add_setshow_boolean_cmd
14301 ("ignore-descriptive-types", class_maintenance
,
14302 &ada_ignore_descriptive_types_p
,
14303 _("Set whether descriptive types generated by GNAT should be ignored."),
14304 _("Show whether descriptive types generated by GNAT should be ignored."),
14306 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14307 DWARF attribute."),
14308 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14310 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14311 NULL
, xcalloc
, xfree
);
14313 /* The ada-lang observers. */
14314 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14315 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14316 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);