1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2019 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/>. */
24 #include "gdb_regex.h"
29 #include "expression.h"
30 #include "parser-defs.h"
37 #include "breakpoint.h"
40 #include "gdb_obstack.h"
42 #include "completer.h"
47 #include "dictionary.h"
51 #include "observable.h"
53 #include "gdbsupport/gdb_vecs.h"
54 #include "typeprint.h"
55 #include "namespace.h"
56 #include "cli/cli-style.h"
60 #include "mi/mi-common.h"
61 #include "arch-utils.h"
62 #include "cli/cli-utils.h"
63 #include "gdbsupport/function-view.h"
64 #include "gdbsupport/byte-vector.h"
68 /* Define whether or not the C operator '/' truncates towards zero for
69 differently signed operands (truncation direction is undefined in C).
70 Copied from valarith.c. */
72 #ifndef TRUNCATION_TOWARDS_ZERO
73 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
76 static struct type
*desc_base_type (struct type
*);
78 static struct type
*desc_bounds_type (struct type
*);
80 static struct value
*desc_bounds (struct value
*);
82 static int fat_pntr_bounds_bitpos (struct type
*);
84 static int fat_pntr_bounds_bitsize (struct type
*);
86 static struct type
*desc_data_target_type (struct type
*);
88 static struct value
*desc_data (struct value
*);
90 static int fat_pntr_data_bitpos (struct type
*);
92 static int fat_pntr_data_bitsize (struct type
*);
94 static struct value
*desc_one_bound (struct value
*, int, int);
96 static int desc_bound_bitpos (struct type
*, int, int);
98 static int desc_bound_bitsize (struct type
*, int, int);
100 static struct type
*desc_index_type (struct type
*, int);
102 static int desc_arity (struct type
*);
104 static int ada_type_match (struct type
*, struct type
*, int);
106 static int ada_args_match (struct symbol
*, struct value
**, int);
108 static struct value
*make_array_descriptor (struct type
*, struct value
*);
110 static void ada_add_block_symbols (struct obstack
*,
111 const struct block
*,
112 const lookup_name_info
&lookup_name
,
113 domain_enum
, struct objfile
*);
115 static void ada_add_all_symbols (struct obstack
*, const struct block
*,
116 const lookup_name_info
&lookup_name
,
117 domain_enum
, int, int *);
119 static int is_nonfunction (struct block_symbol
*, int);
121 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
122 const struct block
*);
124 static int num_defns_collected (struct obstack
*);
126 static struct block_symbol
*defns_collected (struct obstack
*, int);
128 static struct value
*resolve_subexp (expression_up
*, int *, int,
130 innermost_block_tracker
*);
132 static void replace_operator_with_call (expression_up
*, int, int, int,
133 struct symbol
*, const struct block
*);
135 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
137 static const char *ada_op_name (enum exp_opcode
);
139 static const char *ada_decoded_op_name (enum exp_opcode
);
141 static int numeric_type_p (struct type
*);
143 static int integer_type_p (struct type
*);
145 static int scalar_type_p (struct type
*);
147 static int discrete_type_p (struct type
*);
149 static struct type
*ada_lookup_struct_elt_type (struct type
*, const char *,
152 static struct value
*evaluate_subexp_type (struct expression
*, int *);
154 static struct type
*ada_find_parallel_type_with_name (struct type
*,
157 static int is_dynamic_field (struct type
*, int);
159 static struct type
*to_fixed_variant_branch_type (struct type
*,
161 CORE_ADDR
, struct value
*);
163 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
165 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
167 static struct type
*to_static_fixed_type (struct type
*);
168 static struct type
*static_unwrap_type (struct type
*type
);
170 static struct value
*unwrap_value (struct value
*);
172 static struct type
*constrained_packed_array_type (struct type
*, long *);
174 static struct type
*decode_constrained_packed_array_type (struct type
*);
176 static long decode_packed_array_bitsize (struct type
*);
178 static struct value
*decode_constrained_packed_array (struct value
*);
180 static int ada_is_packed_array_type (struct type
*);
182 static int ada_is_unconstrained_packed_array_type (struct type
*);
184 static struct value
*value_subscript_packed (struct value
*, int,
187 static struct value
*coerce_unspec_val_to_type (struct value
*,
190 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
192 static int equiv_types (struct type
*, struct type
*);
194 static int is_name_suffix (const char *);
196 static int advance_wild_match (const char **, const char *, int);
198 static bool wild_match (const char *name
, const char *patn
);
200 static struct value
*ada_coerce_ref (struct value
*);
202 static LONGEST
pos_atr (struct value
*);
204 static struct value
*value_pos_atr (struct type
*, struct value
*);
206 static struct value
*value_val_atr (struct type
*, struct value
*);
208 static struct symbol
*standard_lookup (const char *, const struct block
*,
211 static struct value
*ada_search_struct_field (const char *, struct value
*, int,
214 static struct value
*ada_value_primitive_field (struct value
*, int, int,
217 static int find_struct_field (const char *, struct type
*, int,
218 struct type
**, int *, int *, int *, int *);
220 static int ada_resolve_function (struct block_symbol
*, int,
221 struct value
**, int, const char *,
224 static int ada_is_direct_array_type (struct type
*);
226 static void ada_language_arch_info (struct gdbarch
*,
227 struct language_arch_info
*);
229 static struct value
*ada_index_struct_field (int, struct value
*, int,
232 static struct value
*assign_aggregate (struct value
*, struct value
*,
236 static void aggregate_assign_from_choices (struct value
*, struct value
*,
238 int *, LONGEST
*, int *,
239 int, LONGEST
, LONGEST
);
241 static void aggregate_assign_positional (struct value
*, struct value
*,
243 int *, LONGEST
*, int *, int,
247 static void aggregate_assign_others (struct value
*, struct value
*,
249 int *, LONGEST
*, int, LONGEST
, LONGEST
);
252 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
255 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
258 static void ada_forward_operator_length (struct expression
*, int, int *,
261 static struct type
*ada_find_any_type (const char *name
);
263 static symbol_name_matcher_ftype
*ada_get_symbol_name_matcher
264 (const lookup_name_info
&lookup_name
);
268 /* The result of a symbol lookup to be stored in our symbol cache. */
272 /* The name used to perform the lookup. */
274 /* The namespace used during the lookup. */
276 /* The symbol returned by the lookup, or NULL if no matching symbol
279 /* The block where the symbol was found, or NULL if no matching
281 const struct block
*block
;
282 /* A pointer to the next entry with the same hash. */
283 struct cache_entry
*next
;
286 /* The Ada symbol cache, used to store the result of Ada-mode symbol
287 lookups in the course of executing the user's commands.
289 The cache is implemented using a simple, fixed-sized hash.
290 The size is fixed on the grounds that there are not likely to be
291 all that many symbols looked up during any given session, regardless
292 of the size of the symbol table. If we decide to go to a resizable
293 table, let's just use the stuff from libiberty instead. */
295 #define HASH_SIZE 1009
297 struct ada_symbol_cache
299 /* An obstack used to store the entries in our cache. */
300 struct obstack cache_space
;
302 /* The root of the hash table used to implement our symbol cache. */
303 struct cache_entry
*root
[HASH_SIZE
];
306 static void ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
);
308 /* Maximum-sized dynamic type. */
309 static unsigned int varsize_limit
;
311 static const char ada_completer_word_break_characters
[] =
313 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
315 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
318 /* The name of the symbol to use to get the name of the main subprogram. */
319 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
320 = "__gnat_ada_main_program_name";
322 /* Limit on the number of warnings to raise per expression evaluation. */
323 static int warning_limit
= 2;
325 /* Number of warning messages issued; reset to 0 by cleanups after
326 expression evaluation. */
327 static int warnings_issued
= 0;
329 static const char *known_runtime_file_name_patterns
[] = {
330 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
333 static const char *known_auxiliary_function_name_patterns
[] = {
334 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
337 /* Maintenance-related settings for this module. */
339 static struct cmd_list_element
*maint_set_ada_cmdlist
;
340 static struct cmd_list_element
*maint_show_ada_cmdlist
;
342 /* Implement the "maintenance set ada" (prefix) command. */
345 maint_set_ada_cmd (const char *args
, int from_tty
)
347 help_list (maint_set_ada_cmdlist
, "maintenance set ada ", all_commands
,
351 /* Implement the "maintenance show ada" (prefix) command. */
354 maint_show_ada_cmd (const char *args
, int from_tty
)
356 cmd_show_list (maint_show_ada_cmdlist
, from_tty
, "");
359 /* The "maintenance ada set/show ignore-descriptive-type" value. */
361 static bool ada_ignore_descriptive_types_p
= false;
363 /* Inferior-specific data. */
365 /* Per-inferior data for this module. */
367 struct ada_inferior_data
369 /* The ada__tags__type_specific_data type, which is used when decoding
370 tagged types. With older versions of GNAT, this type was directly
371 accessible through a component ("tsd") in the object tag. But this
372 is no longer the case, so we cache it for each inferior. */
373 struct type
*tsd_type
= nullptr;
375 /* The exception_support_info data. This data is used to determine
376 how to implement support for Ada exception catchpoints in a given
378 const struct exception_support_info
*exception_info
= nullptr;
381 /* Our key to this module's inferior data. */
382 static const struct inferior_key
<ada_inferior_data
> ada_inferior_data
;
384 /* Return our inferior data for the given inferior (INF).
386 This function always returns a valid pointer to an allocated
387 ada_inferior_data structure. If INF's inferior data has not
388 been previously set, this functions creates a new one with all
389 fields set to zero, sets INF's inferior to it, and then returns
390 a pointer to that newly allocated ada_inferior_data. */
392 static struct ada_inferior_data
*
393 get_ada_inferior_data (struct inferior
*inf
)
395 struct ada_inferior_data
*data
;
397 data
= ada_inferior_data
.get (inf
);
399 data
= ada_inferior_data
.emplace (inf
);
404 /* Perform all necessary cleanups regarding our module's inferior data
405 that is required after the inferior INF just exited. */
408 ada_inferior_exit (struct inferior
*inf
)
410 ada_inferior_data
.clear (inf
);
414 /* program-space-specific data. */
416 /* This module's per-program-space data. */
417 struct ada_pspace_data
421 if (sym_cache
!= NULL
)
422 ada_free_symbol_cache (sym_cache
);
425 /* The Ada symbol cache. */
426 struct ada_symbol_cache
*sym_cache
= nullptr;
429 /* Key to our per-program-space data. */
430 static const struct program_space_key
<ada_pspace_data
> ada_pspace_data_handle
;
432 /* Return this module's data for the given program space (PSPACE).
433 If not is found, add a zero'ed one now.
435 This function always returns a valid object. */
437 static struct ada_pspace_data
*
438 get_ada_pspace_data (struct program_space
*pspace
)
440 struct ada_pspace_data
*data
;
442 data
= ada_pspace_data_handle
.get (pspace
);
444 data
= ada_pspace_data_handle
.emplace (pspace
);
451 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
452 all typedef layers have been peeled. Otherwise, return TYPE.
454 Normally, we really expect a typedef type to only have 1 typedef layer.
455 In other words, we really expect the target type of a typedef type to be
456 a non-typedef type. This is particularly true for Ada units, because
457 the language does not have a typedef vs not-typedef distinction.
458 In that respect, the Ada compiler has been trying to eliminate as many
459 typedef definitions in the debugging information, since they generally
460 do not bring any extra information (we still use typedef under certain
461 circumstances related mostly to the GNAT encoding).
463 Unfortunately, we have seen situations where the debugging information
464 generated by the compiler leads to such multiple typedef layers. For
465 instance, consider the following example with stabs:
467 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
468 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
470 This is an error in the debugging information which causes type
471 pck__float_array___XUP to be defined twice, and the second time,
472 it is defined as a typedef of a typedef.
474 This is on the fringe of legality as far as debugging information is
475 concerned, and certainly unexpected. But it is easy to handle these
476 situations correctly, so we can afford to be lenient in this case. */
479 ada_typedef_target_type (struct type
*type
)
481 while (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
482 type
= TYPE_TARGET_TYPE (type
);
486 /* Given DECODED_NAME a string holding a symbol name in its
487 decoded form (ie using the Ada dotted notation), returns
488 its unqualified name. */
491 ada_unqualified_name (const char *decoded_name
)
495 /* If the decoded name starts with '<', it means that the encoded
496 name does not follow standard naming conventions, and thus that
497 it is not your typical Ada symbol name. Trying to unqualify it
498 is therefore pointless and possibly erroneous. */
499 if (decoded_name
[0] == '<')
502 result
= strrchr (decoded_name
, '.');
504 result
++; /* Skip the dot... */
506 result
= decoded_name
;
511 /* Return a string starting with '<', followed by STR, and '>'. */
514 add_angle_brackets (const char *str
)
516 return string_printf ("<%s>", str
);
520 ada_get_gdb_completer_word_break_characters (void)
522 return ada_completer_word_break_characters
;
525 /* Print an array element index using the Ada syntax. */
528 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
529 const struct value_print_options
*options
)
531 LA_VALUE_PRINT (index_value
, stream
, options
);
532 fprintf_filtered (stream
, " => ");
535 /* la_watch_location_expression for Ada. */
537 gdb::unique_xmalloc_ptr
<char>
538 ada_watch_location_expression (struct type
*type
, CORE_ADDR addr
)
540 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
541 std::string name
= type_to_string (type
);
542 return gdb::unique_xmalloc_ptr
<char>
543 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
546 /* Assuming VECT points to an array of *SIZE objects of size
547 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
548 updating *SIZE as necessary and returning the (new) array. */
551 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
553 if (*size
< min_size
)
556 if (*size
< min_size
)
558 vect
= xrealloc (vect
, *size
* element_size
);
563 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
564 suffix of FIELD_NAME beginning "___". */
567 field_name_match (const char *field_name
, const char *target
)
569 int len
= strlen (target
);
572 (strncmp (field_name
, target
, len
) == 0
573 && (field_name
[len
] == '\0'
574 || (startswith (field_name
+ len
, "___")
575 && strcmp (field_name
+ strlen (field_name
) - 6,
580 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
581 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
582 and return its index. This function also handles fields whose name
583 have ___ suffixes because the compiler sometimes alters their name
584 by adding such a suffix to represent fields with certain constraints.
585 If the field could not be found, return a negative number if
586 MAYBE_MISSING is set. Otherwise raise an error. */
589 ada_get_field_index (const struct type
*type
, const char *field_name
,
593 struct type
*struct_type
= check_typedef ((struct type
*) type
);
595 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (struct_type
); fieldno
++)
596 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
600 error (_("Unable to find field %s in struct %s. Aborting"),
601 field_name
, TYPE_NAME (struct_type
));
606 /* The length of the prefix of NAME prior to any "___" suffix. */
609 ada_name_prefix_len (const char *name
)
615 const char *p
= strstr (name
, "___");
618 return strlen (name
);
624 /* Return non-zero if SUFFIX is a suffix of STR.
625 Return zero if STR is null. */
628 is_suffix (const char *str
, const char *suffix
)
635 len2
= strlen (suffix
);
636 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
639 /* The contents of value VAL, treated as a value of type TYPE. The
640 result is an lval in memory if VAL is. */
642 static struct value
*
643 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
645 type
= ada_check_typedef (type
);
646 if (value_type (val
) == type
)
650 struct value
*result
;
652 /* Make sure that the object size is not unreasonable before
653 trying to allocate some memory for it. */
654 ada_ensure_varsize_limit (type
);
657 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
658 result
= allocate_value_lazy (type
);
661 result
= allocate_value (type
);
662 value_contents_copy_raw (result
, 0, val
, 0, TYPE_LENGTH (type
));
664 set_value_component_location (result
, val
);
665 set_value_bitsize (result
, value_bitsize (val
));
666 set_value_bitpos (result
, value_bitpos (val
));
667 if (VALUE_LVAL (result
) == lval_memory
)
668 set_value_address (result
, value_address (val
));
673 static const gdb_byte
*
674 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
679 return valaddr
+ offset
;
683 cond_offset_target (CORE_ADDR address
, long offset
)
688 return address
+ offset
;
691 /* Issue a warning (as for the definition of warning in utils.c, but
692 with exactly one argument rather than ...), unless the limit on the
693 number of warnings has passed during the evaluation of the current
696 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
697 provided by "complaint". */
698 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
701 lim_warning (const char *format
, ...)
705 va_start (args
, format
);
706 warnings_issued
+= 1;
707 if (warnings_issued
<= warning_limit
)
708 vwarning (format
, args
);
713 /* Issue an error if the size of an object of type T is unreasonable,
714 i.e. if it would be a bad idea to allocate a value of this type in
718 ada_ensure_varsize_limit (const struct type
*type
)
720 if (TYPE_LENGTH (type
) > varsize_limit
)
721 error (_("object size is larger than varsize-limit"));
724 /* Maximum value of a SIZE-byte signed integer type. */
726 max_of_size (int size
)
728 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
730 return top_bit
| (top_bit
- 1);
733 /* Minimum value of a SIZE-byte signed integer type. */
735 min_of_size (int size
)
737 return -max_of_size (size
) - 1;
740 /* Maximum value of a SIZE-byte unsigned integer type. */
742 umax_of_size (int size
)
744 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
746 return top_bit
| (top_bit
- 1);
749 /* Maximum value of integral type T, as a signed quantity. */
751 max_of_type (struct type
*t
)
753 if (TYPE_UNSIGNED (t
))
754 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
756 return max_of_size (TYPE_LENGTH (t
));
759 /* Minimum value of integral type T, as a signed quantity. */
761 min_of_type (struct type
*t
)
763 if (TYPE_UNSIGNED (t
))
766 return min_of_size (TYPE_LENGTH (t
));
769 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
771 ada_discrete_type_high_bound (struct type
*type
)
773 type
= resolve_dynamic_type (type
, NULL
, 0);
774 switch (TYPE_CODE (type
))
776 case TYPE_CODE_RANGE
:
777 return TYPE_HIGH_BOUND (type
);
779 return TYPE_FIELD_ENUMVAL (type
, TYPE_NFIELDS (type
) - 1);
784 return max_of_type (type
);
786 error (_("Unexpected type in ada_discrete_type_high_bound."));
790 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
792 ada_discrete_type_low_bound (struct type
*type
)
794 type
= resolve_dynamic_type (type
, NULL
, 0);
795 switch (TYPE_CODE (type
))
797 case TYPE_CODE_RANGE
:
798 return TYPE_LOW_BOUND (type
);
800 return TYPE_FIELD_ENUMVAL (type
, 0);
805 return min_of_type (type
);
807 error (_("Unexpected type in ada_discrete_type_low_bound."));
811 /* The identity on non-range types. For range types, the underlying
812 non-range scalar type. */
815 get_base_type (struct type
*type
)
817 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
819 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
821 type
= TYPE_TARGET_TYPE (type
);
826 /* Return a decoded version of the given VALUE. This means returning
827 a value whose type is obtained by applying all the GNAT-specific
828 encodings, making the resulting type a static but standard description
829 of the initial type. */
832 ada_get_decoded_value (struct value
*value
)
834 struct type
*type
= ada_check_typedef (value_type (value
));
836 if (ada_is_array_descriptor_type (type
)
837 || (ada_is_constrained_packed_array_type (type
)
838 && TYPE_CODE (type
) != TYPE_CODE_PTR
))
840 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
) /* array access type. */
841 value
= ada_coerce_to_simple_array_ptr (value
);
843 value
= ada_coerce_to_simple_array (value
);
846 value
= ada_to_fixed_value (value
);
851 /* Same as ada_get_decoded_value, but with the given TYPE.
852 Because there is no associated actual value for this type,
853 the resulting type might be a best-effort approximation in
854 the case of dynamic types. */
857 ada_get_decoded_type (struct type
*type
)
859 type
= to_static_fixed_type (type
);
860 if (ada_is_constrained_packed_array_type (type
))
861 type
= ada_coerce_to_simple_array_type (type
);
867 /* Language Selection */
869 /* If the main program is in Ada, return language_ada, otherwise return LANG
870 (the main program is in Ada iif the adainit symbol is found). */
873 ada_update_initial_language (enum language lang
)
875 if (lookup_minimal_symbol ("adainit", NULL
, NULL
).minsym
!= NULL
)
881 /* If the main procedure is written in Ada, then return its name.
882 The result is good until the next call. Return NULL if the main
883 procedure doesn't appear to be in Ada. */
888 struct bound_minimal_symbol msym
;
889 static gdb::unique_xmalloc_ptr
<char> main_program_name
;
891 /* For Ada, the name of the main procedure is stored in a specific
892 string constant, generated by the binder. Look for that symbol,
893 extract its address, and then read that string. If we didn't find
894 that string, then most probably the main procedure is not written
896 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
898 if (msym
.minsym
!= NULL
)
900 CORE_ADDR main_program_name_addr
;
903 main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
904 if (main_program_name_addr
== 0)
905 error (_("Invalid address for Ada main program name."));
907 target_read_string (main_program_name_addr
, &main_program_name
,
912 return main_program_name
.get ();
915 /* The main procedure doesn't seem to be in Ada. */
921 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
924 const struct ada_opname_map ada_opname_table
[] = {
925 {"Oadd", "\"+\"", BINOP_ADD
},
926 {"Osubtract", "\"-\"", BINOP_SUB
},
927 {"Omultiply", "\"*\"", BINOP_MUL
},
928 {"Odivide", "\"/\"", BINOP_DIV
},
929 {"Omod", "\"mod\"", BINOP_MOD
},
930 {"Orem", "\"rem\"", BINOP_REM
},
931 {"Oexpon", "\"**\"", BINOP_EXP
},
932 {"Olt", "\"<\"", BINOP_LESS
},
933 {"Ole", "\"<=\"", BINOP_LEQ
},
934 {"Ogt", "\">\"", BINOP_GTR
},
935 {"Oge", "\">=\"", BINOP_GEQ
},
936 {"Oeq", "\"=\"", BINOP_EQUAL
},
937 {"One", "\"/=\"", BINOP_NOTEQUAL
},
938 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
939 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
940 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
941 {"Oconcat", "\"&\"", BINOP_CONCAT
},
942 {"Oabs", "\"abs\"", UNOP_ABS
},
943 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
944 {"Oadd", "\"+\"", UNOP_PLUS
},
945 {"Osubtract", "\"-\"", UNOP_NEG
},
949 /* The "encoded" form of DECODED, according to GNAT conventions. The
950 result is valid until the next call to ada_encode. If
951 THROW_ERRORS, throw an error if invalid operator name is found.
952 Otherwise, return NULL in that case. */
955 ada_encode_1 (const char *decoded
, bool throw_errors
)
957 static char *encoding_buffer
= NULL
;
958 static size_t encoding_buffer_size
= 0;
965 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
966 2 * strlen (decoded
) + 10);
969 for (p
= decoded
; *p
!= '\0'; p
+= 1)
973 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
978 const struct ada_opname_map
*mapping
;
980 for (mapping
= ada_opname_table
;
981 mapping
->encoded
!= NULL
982 && !startswith (p
, mapping
->decoded
); mapping
+= 1)
984 if (mapping
->encoded
== NULL
)
987 error (_("invalid Ada operator name: %s"), p
);
991 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
992 k
+= strlen (mapping
->encoded
);
997 encoding_buffer
[k
] = *p
;
1002 encoding_buffer
[k
] = '\0';
1003 return encoding_buffer
;
1006 /* The "encoded" form of DECODED, according to GNAT conventions.
1007 The result is valid until the next call to ada_encode. */
1010 ada_encode (const char *decoded
)
1012 return ada_encode_1 (decoded
, true);
1015 /* Return NAME folded to lower case, or, if surrounded by single
1016 quotes, unfolded, but with the quotes stripped away. Result good
1020 ada_fold_name (const char *name
)
1022 static char *fold_buffer
= NULL
;
1023 static size_t fold_buffer_size
= 0;
1025 int len
= strlen (name
);
1026 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
1028 if (name
[0] == '\'')
1030 strncpy (fold_buffer
, name
+ 1, len
- 2);
1031 fold_buffer
[len
- 2] = '\000';
1037 for (i
= 0; i
<= len
; i
+= 1)
1038 fold_buffer
[i
] = tolower (name
[i
]);
1044 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1047 is_lower_alphanum (const char c
)
1049 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1052 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1053 This function saves in LEN the length of that same symbol name but
1054 without either of these suffixes:
1060 These are suffixes introduced by the compiler for entities such as
1061 nested subprogram for instance, in order to avoid name clashes.
1062 They do not serve any purpose for the debugger. */
1065 ada_remove_trailing_digits (const char *encoded
, int *len
)
1067 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1071 while (i
> 0 && isdigit (encoded
[i
]))
1073 if (i
>= 0 && encoded
[i
] == '.')
1075 else if (i
>= 0 && encoded
[i
] == '$')
1077 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
1079 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
1084 /* Remove the suffix introduced by the compiler for protected object
1088 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1090 /* Remove trailing N. */
1092 /* Protected entry subprograms are broken into two
1093 separate subprograms: The first one is unprotected, and has
1094 a 'N' suffix; the second is the protected version, and has
1095 the 'P' suffix. The second calls the first one after handling
1096 the protection. Since the P subprograms are internally generated,
1097 we leave these names undecoded, giving the user a clue that this
1098 entity is internal. */
1101 && encoded
[*len
- 1] == 'N'
1102 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1106 /* If ENCODED follows the GNAT entity encoding conventions, then return
1107 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1108 replaced by ENCODED. */
1111 ada_decode (const char *encoded
)
1117 std::string decoded
;
1119 /* With function descriptors on PPC64, the value of a symbol named
1120 ".FN", if it exists, is the entry point of the function "FN". */
1121 if (encoded
[0] == '.')
1124 /* The name of the Ada main procedure starts with "_ada_".
1125 This prefix is not part of the decoded name, so skip this part
1126 if we see this prefix. */
1127 if (startswith (encoded
, "_ada_"))
1130 /* If the name starts with '_', then it is not a properly encoded
1131 name, so do not attempt to decode it. Similarly, if the name
1132 starts with '<', the name should not be decoded. */
1133 if (encoded
[0] == '_' || encoded
[0] == '<')
1136 len0
= strlen (encoded
);
1138 ada_remove_trailing_digits (encoded
, &len0
);
1139 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1141 /* Remove the ___X.* suffix if present. Do not forget to verify that
1142 the suffix is located before the current "end" of ENCODED. We want
1143 to avoid re-matching parts of ENCODED that have previously been
1144 marked as discarded (by decrementing LEN0). */
1145 p
= strstr (encoded
, "___");
1146 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1154 /* Remove any trailing TKB suffix. It tells us that this symbol
1155 is for the body of a task, but that information does not actually
1156 appear in the decoded name. */
1158 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1161 /* Remove any trailing TB suffix. The TB suffix is slightly different
1162 from the TKB suffix because it is used for non-anonymous task
1165 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1168 /* Remove trailing "B" suffixes. */
1169 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1171 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1174 /* Make decoded big enough for possible expansion by operator name. */
1176 decoded
.resize (2 * len0
+ 1, 'X');
1178 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1180 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1183 while ((i
>= 0 && isdigit (encoded
[i
]))
1184 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1186 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1188 else if (encoded
[i
] == '$')
1192 /* The first few characters that are not alphabetic are not part
1193 of any encoding we use, so we can copy them over verbatim. */
1195 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1196 decoded
[j
] = encoded
[i
];
1201 /* Is this a symbol function? */
1202 if (at_start_name
&& encoded
[i
] == 'O')
1206 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1208 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1209 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1211 && !isalnum (encoded
[i
+ op_len
]))
1213 strcpy (&decoded
.front() + j
, ada_opname_table
[k
].decoded
);
1216 j
+= strlen (ada_opname_table
[k
].decoded
);
1220 if (ada_opname_table
[k
].encoded
!= NULL
)
1225 /* Replace "TK__" with "__", which will eventually be translated
1226 into "." (just below). */
1228 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1231 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1232 be translated into "." (just below). These are internal names
1233 generated for anonymous blocks inside which our symbol is nested. */
1235 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1236 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1237 && isdigit (encoded
[i
+4]))
1241 while (k
< len0
&& isdigit (encoded
[k
]))
1242 k
++; /* Skip any extra digit. */
1244 /* Double-check that the "__B_{DIGITS}+" sequence we found
1245 is indeed followed by "__". */
1246 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1250 /* Remove _E{DIGITS}+[sb] */
1252 /* Just as for protected object subprograms, there are 2 categories
1253 of subprograms created by the compiler for each entry. The first
1254 one implements the actual entry code, and has a suffix following
1255 the convention above; the second one implements the barrier and
1256 uses the same convention as above, except that the 'E' is replaced
1259 Just as above, we do not decode the name of barrier functions
1260 to give the user a clue that the code he is debugging has been
1261 internally generated. */
1263 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1264 && isdigit (encoded
[i
+2]))
1268 while (k
< len0
&& isdigit (encoded
[k
]))
1272 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1275 /* Just as an extra precaution, make sure that if this
1276 suffix is followed by anything else, it is a '_'.
1277 Otherwise, we matched this sequence by accident. */
1279 || (k
< len0
&& encoded
[k
] == '_'))
1284 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1285 the GNAT front-end in protected object subprograms. */
1288 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1290 /* Backtrack a bit up until we reach either the begining of
1291 the encoded name, or "__". Make sure that we only find
1292 digits or lowercase characters. */
1293 const char *ptr
= encoded
+ i
- 1;
1295 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1298 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1302 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1304 /* This is a X[bn]* sequence not separated from the previous
1305 part of the name with a non-alpha-numeric character (in other
1306 words, immediately following an alpha-numeric character), then
1307 verify that it is placed at the end of the encoded name. If
1308 not, then the encoding is not valid and we should abort the
1309 decoding. Otherwise, just skip it, it is used in body-nested
1313 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1317 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1319 /* Replace '__' by '.'. */
1327 /* It's a character part of the decoded name, so just copy it
1329 decoded
[j
] = encoded
[i
];
1336 /* Decoded names should never contain any uppercase character.
1337 Double-check this, and abort the decoding if we find one. */
1339 for (i
= 0; i
< decoded
.length(); ++i
)
1340 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1346 if (encoded
[0] == '<')
1349 decoded
= '<' + std::string(encoded
) + '>';
1354 /* Table for keeping permanent unique copies of decoded names. Once
1355 allocated, names in this table are never released. While this is a
1356 storage leak, it should not be significant unless there are massive
1357 changes in the set of decoded names in successive versions of a
1358 symbol table loaded during a single session. */
1359 static struct htab
*decoded_names_store
;
1361 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1362 in the language-specific part of GSYMBOL, if it has not been
1363 previously computed. Tries to save the decoded name in the same
1364 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1365 in any case, the decoded symbol has a lifetime at least that of
1367 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1368 const, but nevertheless modified to a semantically equivalent form
1369 when a decoded name is cached in it. */
1372 ada_decode_symbol (const struct general_symbol_info
*arg
)
1374 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1375 const char **resultp
=
1376 &gsymbol
->language_specific
.demangled_name
;
1378 if (!gsymbol
->ada_mangled
)
1380 std::string decoded
= ada_decode (gsymbol
->name
);
1381 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1383 gsymbol
->ada_mangled
= 1;
1385 if (obstack
!= NULL
)
1386 *resultp
= obstack_strdup (obstack
, decoded
.c_str ());
1389 /* Sometimes, we can't find a corresponding objfile, in
1390 which case, we put the result on the heap. Since we only
1391 decode when needed, we hope this usually does not cause a
1392 significant memory leak (FIXME). */
1394 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1395 decoded
.c_str (), INSERT
);
1398 *slot
= xstrdup (decoded
.c_str ());
1407 ada_la_decode (const char *encoded
, int options
)
1409 return xstrdup (ada_decode (encoded
).c_str ());
1412 /* Implement la_sniff_from_mangled_name for Ada. */
1415 ada_sniff_from_mangled_name (const char *mangled
, char **out
)
1417 std::string demangled
= ada_decode (mangled
);
1421 if (demangled
!= mangled
&& demangled
[0] != '<')
1423 /* Set the gsymbol language to Ada, but still return 0.
1424 Two reasons for that:
1426 1. For Ada, we prefer computing the symbol's decoded name
1427 on the fly rather than pre-compute it, in order to save
1428 memory (Ada projects are typically very large).
1430 2. There are some areas in the definition of the GNAT
1431 encoding where, with a bit of bad luck, we might be able
1432 to decode a non-Ada symbol, generating an incorrect
1433 demangled name (Eg: names ending with "TB" for instance
1434 are identified as task bodies and so stripped from
1435 the decoded name returned).
1437 Returning 1, here, but not setting *DEMANGLED, helps us get a
1438 little bit of the best of both worlds. Because we're last,
1439 we should not affect any of the other languages that were
1440 able to demangle the symbol before us; we get to correctly
1441 tag Ada symbols as such; and even if we incorrectly tagged a
1442 non-Ada symbol, which should be rare, any routing through the
1443 Ada language should be transparent (Ada tries to behave much
1444 like C/C++ with non-Ada symbols). */
1455 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1456 generated by the GNAT compiler to describe the index type used
1457 for each dimension of an array, check whether it follows the latest
1458 known encoding. If not, fix it up to conform to the latest encoding.
1459 Otherwise, do nothing. This function also does nothing if
1460 INDEX_DESC_TYPE is NULL.
1462 The GNAT encoding used to describe the array index type evolved a bit.
1463 Initially, the information would be provided through the name of each
1464 field of the structure type only, while the type of these fields was
1465 described as unspecified and irrelevant. The debugger was then expected
1466 to perform a global type lookup using the name of that field in order
1467 to get access to the full index type description. Because these global
1468 lookups can be very expensive, the encoding was later enhanced to make
1469 the global lookup unnecessary by defining the field type as being
1470 the full index type description.
1472 The purpose of this routine is to allow us to support older versions
1473 of the compiler by detecting the use of the older encoding, and by
1474 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1475 we essentially replace each field's meaningless type by the associated
1479 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1483 if (index_desc_type
== NULL
)
1485 gdb_assert (TYPE_NFIELDS (index_desc_type
) > 0);
1487 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1488 to check one field only, no need to check them all). If not, return
1491 If our INDEX_DESC_TYPE was generated using the older encoding,
1492 the field type should be a meaningless integer type whose name
1493 is not equal to the field name. */
1494 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)) != NULL
1495 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)),
1496 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1499 /* Fixup each field of INDEX_DESC_TYPE. */
1500 for (i
= 0; i
< TYPE_NFIELDS (index_desc_type
); i
++)
1502 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1503 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1506 TYPE_FIELD_TYPE (index_desc_type
, i
) = raw_type
;
1510 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1512 static const char *bound_name
[] = {
1513 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1514 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1517 /* Maximum number of array dimensions we are prepared to handle. */
1519 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1522 /* The desc_* routines return primitive portions of array descriptors
1525 /* The descriptor or array type, if any, indicated by TYPE; removes
1526 level of indirection, if needed. */
1528 static struct type
*
1529 desc_base_type (struct type
*type
)
1533 type
= ada_check_typedef (type
);
1534 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
1535 type
= ada_typedef_target_type (type
);
1538 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1539 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1540 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1545 /* True iff TYPE indicates a "thin" array pointer type. */
1548 is_thin_pntr (struct type
*type
)
1551 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1552 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1555 /* The descriptor type for thin pointer type TYPE. */
1557 static struct type
*
1558 thin_descriptor_type (struct type
*type
)
1560 struct type
*base_type
= desc_base_type (type
);
1562 if (base_type
== NULL
)
1564 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1568 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1570 if (alt_type
== NULL
)
1577 /* A pointer to the array data for thin-pointer value VAL. */
1579 static struct value
*
1580 thin_data_pntr (struct value
*val
)
1582 struct type
*type
= ada_check_typedef (value_type (val
));
1583 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1585 data_type
= lookup_pointer_type (data_type
);
1587 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1588 return value_cast (data_type
, value_copy (val
));
1590 return value_from_longest (data_type
, value_address (val
));
1593 /* True iff TYPE indicates a "thick" array pointer type. */
1596 is_thick_pntr (struct type
*type
)
1598 type
= desc_base_type (type
);
1599 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1600 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1603 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1604 pointer to one, the type of its bounds data; otherwise, NULL. */
1606 static struct type
*
1607 desc_bounds_type (struct type
*type
)
1611 type
= desc_base_type (type
);
1615 else if (is_thin_pntr (type
))
1617 type
= thin_descriptor_type (type
);
1620 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1622 return ada_check_typedef (r
);
1624 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1626 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1628 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1633 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1634 one, a pointer to its bounds data. Otherwise NULL. */
1636 static struct value
*
1637 desc_bounds (struct value
*arr
)
1639 struct type
*type
= ada_check_typedef (value_type (arr
));
1641 if (is_thin_pntr (type
))
1643 struct type
*bounds_type
=
1644 desc_bounds_type (thin_descriptor_type (type
));
1647 if (bounds_type
== NULL
)
1648 error (_("Bad GNAT array descriptor"));
1650 /* NOTE: The following calculation is not really kosher, but
1651 since desc_type is an XVE-encoded type (and shouldn't be),
1652 the correct calculation is a real pain. FIXME (and fix GCC). */
1653 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1654 addr
= value_as_long (arr
);
1656 addr
= value_address (arr
);
1659 value_from_longest (lookup_pointer_type (bounds_type
),
1660 addr
- TYPE_LENGTH (bounds_type
));
1663 else if (is_thick_pntr (type
))
1665 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1666 _("Bad GNAT array descriptor"));
1667 struct type
*p_bounds_type
= value_type (p_bounds
);
1670 && TYPE_CODE (p_bounds_type
) == TYPE_CODE_PTR
)
1672 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1674 if (TYPE_STUB (target_type
))
1675 p_bounds
= value_cast (lookup_pointer_type
1676 (ada_check_typedef (target_type
)),
1680 error (_("Bad GNAT array descriptor"));
1688 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1689 position of the field containing the address of the bounds data. */
1692 fat_pntr_bounds_bitpos (struct type
*type
)
1694 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1697 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1698 size of the field containing the address of the bounds data. */
1701 fat_pntr_bounds_bitsize (struct type
*type
)
1703 type
= desc_base_type (type
);
1705 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1706 return TYPE_FIELD_BITSIZE (type
, 1);
1708 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1711 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1712 pointer to one, the type of its array data (a array-with-no-bounds type);
1713 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1716 static struct type
*
1717 desc_data_target_type (struct type
*type
)
1719 type
= desc_base_type (type
);
1721 /* NOTE: The following is bogus; see comment in desc_bounds. */
1722 if (is_thin_pntr (type
))
1723 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1));
1724 else if (is_thick_pntr (type
))
1726 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1729 && TYPE_CODE (ada_check_typedef (data_type
)) == TYPE_CODE_PTR
)
1730 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1736 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1739 static struct value
*
1740 desc_data (struct value
*arr
)
1742 struct type
*type
= value_type (arr
);
1744 if (is_thin_pntr (type
))
1745 return thin_data_pntr (arr
);
1746 else if (is_thick_pntr (type
))
1747 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1748 _("Bad GNAT array descriptor"));
1754 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1755 position of the field containing the address of the data. */
1758 fat_pntr_data_bitpos (struct type
*type
)
1760 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1763 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1764 size of the field containing the address of the data. */
1767 fat_pntr_data_bitsize (struct type
*type
)
1769 type
= desc_base_type (type
);
1771 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1772 return TYPE_FIELD_BITSIZE (type
, 0);
1774 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1777 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1778 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1779 bound, if WHICH is 1. The first bound is I=1. */
1781 static struct value
*
1782 desc_one_bound (struct value
*bounds
, int i
, int which
)
1784 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1785 _("Bad GNAT array descriptor bounds"));
1788 /* If BOUNDS is an array-bounds structure type, return the bit position
1789 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1790 bound, if WHICH is 1. The first bound is I=1. */
1793 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1795 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1798 /* If BOUNDS is an array-bounds structure type, return the bit field size
1799 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1800 bound, if WHICH is 1. The first bound is I=1. */
1803 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1805 type
= desc_base_type (type
);
1807 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1808 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1810 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1813 /* If TYPE is the type of an array-bounds structure, the type of its
1814 Ith bound (numbering from 1). Otherwise, NULL. */
1816 static struct type
*
1817 desc_index_type (struct type
*type
, int i
)
1819 type
= desc_base_type (type
);
1821 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1822 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1827 /* The number of index positions in the array-bounds type TYPE.
1828 Return 0 if TYPE is NULL. */
1831 desc_arity (struct type
*type
)
1833 type
= desc_base_type (type
);
1836 return TYPE_NFIELDS (type
) / 2;
1840 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1841 an array descriptor type (representing an unconstrained array
1845 ada_is_direct_array_type (struct type
*type
)
1849 type
= ada_check_typedef (type
);
1850 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1851 || ada_is_array_descriptor_type (type
));
1854 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1858 ada_is_array_type (struct type
*type
)
1861 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1862 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1863 type
= TYPE_TARGET_TYPE (type
);
1864 return ada_is_direct_array_type (type
);
1867 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1870 ada_is_simple_array_type (struct type
*type
)
1874 type
= ada_check_typedef (type
);
1875 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1876 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1877 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
)))
1878 == TYPE_CODE_ARRAY
));
1881 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1884 ada_is_array_descriptor_type (struct type
*type
)
1886 struct type
*data_type
= desc_data_target_type (type
);
1890 type
= ada_check_typedef (type
);
1891 return (data_type
!= NULL
1892 && TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
1893 && desc_arity (desc_bounds_type (type
)) > 0);
1896 /* Non-zero iff type is a partially mal-formed GNAT array
1897 descriptor. FIXME: This is to compensate for some problems with
1898 debugging output from GNAT. Re-examine periodically to see if it
1902 ada_is_bogus_array_descriptor (struct type
*type
)
1906 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1907 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1908 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1909 && !ada_is_array_descriptor_type (type
);
1913 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1914 (fat pointer) returns the type of the array data described---specifically,
1915 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1916 in from the descriptor; otherwise, they are left unspecified. If
1917 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1918 returns NULL. The result is simply the type of ARR if ARR is not
1921 ada_type_of_array (struct value
*arr
, int bounds
)
1923 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1924 return decode_constrained_packed_array_type (value_type (arr
));
1926 if (!ada_is_array_descriptor_type (value_type (arr
)))
1927 return value_type (arr
);
1931 struct type
*array_type
=
1932 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1934 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1935 TYPE_FIELD_BITSIZE (array_type
, 0) =
1936 decode_packed_array_bitsize (value_type (arr
));
1942 struct type
*elt_type
;
1944 struct value
*descriptor
;
1946 elt_type
= ada_array_element_type (value_type (arr
), -1);
1947 arity
= ada_array_arity (value_type (arr
));
1949 if (elt_type
== NULL
|| arity
== 0)
1950 return ada_check_typedef (value_type (arr
));
1952 descriptor
= desc_bounds (arr
);
1953 if (value_as_long (descriptor
) == 0)
1957 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1958 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1959 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1960 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1963 create_static_range_type (range_type
, value_type (low
),
1964 longest_to_int (value_as_long (low
)),
1965 longest_to_int (value_as_long (high
)));
1966 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1968 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1970 /* We need to store the element packed bitsize, as well as
1971 recompute the array size, because it was previously
1972 computed based on the unpacked element size. */
1973 LONGEST lo
= value_as_long (low
);
1974 LONGEST hi
= value_as_long (high
);
1976 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1977 decode_packed_array_bitsize (value_type (arr
));
1978 /* If the array has no element, then the size is already
1979 zero, and does not need to be recomputed. */
1983 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
1985 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
1990 return lookup_pointer_type (elt_type
);
1994 /* If ARR does not represent an array, returns ARR unchanged.
1995 Otherwise, returns either a standard GDB array with bounds set
1996 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1997 GDB array. Returns NULL if ARR is a null fat pointer. */
2000 ada_coerce_to_simple_array_ptr (struct value
*arr
)
2002 if (ada_is_array_descriptor_type (value_type (arr
)))
2004 struct type
*arrType
= ada_type_of_array (arr
, 1);
2006 if (arrType
== NULL
)
2008 return value_cast (arrType
, value_copy (desc_data (arr
)));
2010 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
2011 return decode_constrained_packed_array (arr
);
2016 /* If ARR does not represent an array, returns ARR unchanged.
2017 Otherwise, returns a standard GDB array describing ARR (which may
2018 be ARR itself if it already is in the proper form). */
2021 ada_coerce_to_simple_array (struct value
*arr
)
2023 if (ada_is_array_descriptor_type (value_type (arr
)))
2025 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
2028 error (_("Bounds unavailable for null array pointer."));
2029 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
2030 return value_ind (arrVal
);
2032 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
2033 return decode_constrained_packed_array (arr
);
2038 /* If TYPE represents a GNAT array type, return it translated to an
2039 ordinary GDB array type (possibly with BITSIZE fields indicating
2040 packing). For other types, is the identity. */
2043 ada_coerce_to_simple_array_type (struct type
*type
)
2045 if (ada_is_constrained_packed_array_type (type
))
2046 return decode_constrained_packed_array_type (type
);
2048 if (ada_is_array_descriptor_type (type
))
2049 return ada_check_typedef (desc_data_target_type (type
));
2054 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2057 ada_is_packed_array_type (struct type
*type
)
2061 type
= desc_base_type (type
);
2062 type
= ada_check_typedef (type
);
2064 ada_type_name (type
) != NULL
2065 && strstr (ada_type_name (type
), "___XP") != NULL
;
2068 /* Non-zero iff TYPE represents a standard GNAT constrained
2069 packed-array type. */
2072 ada_is_constrained_packed_array_type (struct type
*type
)
2074 return ada_is_packed_array_type (type
)
2075 && !ada_is_array_descriptor_type (type
);
2078 /* Non-zero iff TYPE represents an array descriptor for a
2079 unconstrained packed-array type. */
2082 ada_is_unconstrained_packed_array_type (struct type
*type
)
2084 return ada_is_packed_array_type (type
)
2085 && ada_is_array_descriptor_type (type
);
2088 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2089 return the size of its elements in bits. */
2092 decode_packed_array_bitsize (struct type
*type
)
2094 const char *raw_name
;
2098 /* Access to arrays implemented as fat pointers are encoded as a typedef
2099 of the fat pointer type. We need the name of the fat pointer type
2100 to do the decoding, so strip the typedef layer. */
2101 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
2102 type
= ada_typedef_target_type (type
);
2104 raw_name
= ada_type_name (ada_check_typedef (type
));
2106 raw_name
= ada_type_name (desc_base_type (type
));
2111 tail
= strstr (raw_name
, "___XP");
2112 gdb_assert (tail
!= NULL
);
2114 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2117 (_("could not understand bit size information on packed array"));
2124 /* Given that TYPE is a standard GDB array type with all bounds filled
2125 in, and that the element size of its ultimate scalar constituents
2126 (that is, either its elements, or, if it is an array of arrays, its
2127 elements' elements, etc.) is *ELT_BITS, return an identical type,
2128 but with the bit sizes of its elements (and those of any
2129 constituent arrays) recorded in the BITSIZE components of its
2130 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2133 Note that, for arrays whose index type has an XA encoding where
2134 a bound references a record discriminant, getting that discriminant,
2135 and therefore the actual value of that bound, is not possible
2136 because none of the given parameters gives us access to the record.
2137 This function assumes that it is OK in the context where it is being
2138 used to return an array whose bounds are still dynamic and where
2139 the length is arbitrary. */
2141 static struct type
*
2142 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2144 struct type
*new_elt_type
;
2145 struct type
*new_type
;
2146 struct type
*index_type_desc
;
2147 struct type
*index_type
;
2148 LONGEST low_bound
, high_bound
;
2150 type
= ada_check_typedef (type
);
2151 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2154 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2155 if (index_type_desc
)
2156 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, 0),
2159 index_type
= TYPE_INDEX_TYPE (type
);
2161 new_type
= alloc_type_copy (type
);
2163 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2165 create_array_type (new_type
, new_elt_type
, index_type
);
2166 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2167 TYPE_NAME (new_type
) = ada_type_name (type
);
2169 if ((TYPE_CODE (check_typedef (index_type
)) == TYPE_CODE_RANGE
2170 && is_dynamic_type (check_typedef (index_type
)))
2171 || get_discrete_bounds (index_type
, &low_bound
, &high_bound
) < 0)
2172 low_bound
= high_bound
= 0;
2173 if (high_bound
< low_bound
)
2174 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2177 *elt_bits
*= (high_bound
- low_bound
+ 1);
2178 TYPE_LENGTH (new_type
) =
2179 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2182 TYPE_FIXED_INSTANCE (new_type
) = 1;
2186 /* The array type encoded by TYPE, where
2187 ada_is_constrained_packed_array_type (TYPE). */
2189 static struct type
*
2190 decode_constrained_packed_array_type (struct type
*type
)
2192 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2195 struct type
*shadow_type
;
2199 raw_name
= ada_type_name (desc_base_type (type
));
2204 name
= (char *) alloca (strlen (raw_name
) + 1);
2205 tail
= strstr (raw_name
, "___XP");
2206 type
= desc_base_type (type
);
2208 memcpy (name
, raw_name
, tail
- raw_name
);
2209 name
[tail
- raw_name
] = '\000';
2211 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2213 if (shadow_type
== NULL
)
2215 lim_warning (_("could not find bounds information on packed array"));
2218 shadow_type
= check_typedef (shadow_type
);
2220 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
2222 lim_warning (_("could not understand bounds "
2223 "information on packed array"));
2227 bits
= decode_packed_array_bitsize (type
);
2228 return constrained_packed_array_type (shadow_type
, &bits
);
2231 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2232 array, returns a simple array that denotes that array. Its type is a
2233 standard GDB array type except that the BITSIZEs of the array
2234 target types are set to the number of bits in each element, and the
2235 type length is set appropriately. */
2237 static struct value
*
2238 decode_constrained_packed_array (struct value
*arr
)
2242 /* If our value is a pointer, then dereference it. Likewise if
2243 the value is a reference. Make sure that this operation does not
2244 cause the target type to be fixed, as this would indirectly cause
2245 this array to be decoded. The rest of the routine assumes that
2246 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2247 and "value_ind" routines to perform the dereferencing, as opposed
2248 to using "ada_coerce_ref" or "ada_value_ind". */
2249 arr
= coerce_ref (arr
);
2250 if (TYPE_CODE (ada_check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
2251 arr
= value_ind (arr
);
2253 type
= decode_constrained_packed_array_type (value_type (arr
));
2256 error (_("can't unpack array"));
2260 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr
)))
2261 && ada_is_modular_type (value_type (arr
)))
2263 /* This is a (right-justified) modular type representing a packed
2264 array with no wrapper. In order to interpret the value through
2265 the (left-justified) packed array type we just built, we must
2266 first left-justify it. */
2267 int bit_size
, bit_pos
;
2270 mod
= ada_modulus (value_type (arr
)) - 1;
2277 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2278 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2279 bit_pos
/ HOST_CHAR_BIT
,
2280 bit_pos
% HOST_CHAR_BIT
,
2285 return coerce_unspec_val_to_type (arr
, type
);
2289 /* The value of the element of packed array ARR at the ARITY indices
2290 given in IND. ARR must be a simple array. */
2292 static struct value
*
2293 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2296 int bits
, elt_off
, bit_off
;
2297 long elt_total_bit_offset
;
2298 struct type
*elt_type
;
2302 elt_total_bit_offset
= 0;
2303 elt_type
= ada_check_typedef (value_type (arr
));
2304 for (i
= 0; i
< arity
; i
+= 1)
2306 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
2307 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2309 (_("attempt to do packed indexing of "
2310 "something other than a packed array"));
2313 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
2314 LONGEST lowerbound
, upperbound
;
2317 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2319 lim_warning (_("don't know bounds of array"));
2320 lowerbound
= upperbound
= 0;
2323 idx
= pos_atr (ind
[i
]);
2324 if (idx
< lowerbound
|| idx
> upperbound
)
2325 lim_warning (_("packed array index %ld out of bounds"),
2327 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2328 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2329 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2332 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2333 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2335 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2340 /* Non-zero iff TYPE includes negative integer values. */
2343 has_negatives (struct type
*type
)
2345 switch (TYPE_CODE (type
))
2350 return !TYPE_UNSIGNED (type
);
2351 case TYPE_CODE_RANGE
:
2352 return TYPE_LOW_BOUND (type
) - TYPE_RANGE_DATA (type
)->bias
< 0;
2356 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2357 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2358 the unpacked buffer.
2360 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2361 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2363 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2366 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2368 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2371 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2372 gdb_byte
*unpacked
, int unpacked_len
,
2373 int is_big_endian
, int is_signed_type
,
2376 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2377 int src_idx
; /* Index into the source area */
2378 int src_bytes_left
; /* Number of source bytes left to process. */
2379 int srcBitsLeft
; /* Number of source bits left to move */
2380 int unusedLS
; /* Number of bits in next significant
2381 byte of source that are unused */
2383 int unpacked_idx
; /* Index into the unpacked buffer */
2384 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2386 unsigned long accum
; /* Staging area for bits being transferred */
2387 int accumSize
; /* Number of meaningful bits in accum */
2390 /* Transmit bytes from least to most significant; delta is the direction
2391 the indices move. */
2392 int delta
= is_big_endian
? -1 : 1;
2394 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2396 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2397 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2398 bit_size
, unpacked_len
);
2400 srcBitsLeft
= bit_size
;
2401 src_bytes_left
= src_len
;
2402 unpacked_bytes_left
= unpacked_len
;
2407 src_idx
= src_len
- 1;
2409 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2413 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2419 unpacked_idx
= unpacked_len
- 1;
2423 /* Non-scalar values must be aligned at a byte boundary... */
2425 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2426 /* ... And are placed at the beginning (most-significant) bytes
2428 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2429 unpacked_bytes_left
= unpacked_idx
+ 1;
2434 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2436 src_idx
= unpacked_idx
= 0;
2437 unusedLS
= bit_offset
;
2440 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2445 while (src_bytes_left
> 0)
2447 /* Mask for removing bits of the next source byte that are not
2448 part of the value. */
2449 unsigned int unusedMSMask
=
2450 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2452 /* Sign-extend bits for this byte. */
2453 unsigned int signMask
= sign
& ~unusedMSMask
;
2456 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2457 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2458 if (accumSize
>= HOST_CHAR_BIT
)
2460 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2461 accumSize
-= HOST_CHAR_BIT
;
2462 accum
>>= HOST_CHAR_BIT
;
2463 unpacked_bytes_left
-= 1;
2464 unpacked_idx
+= delta
;
2466 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2468 src_bytes_left
-= 1;
2471 while (unpacked_bytes_left
> 0)
2473 accum
|= sign
<< accumSize
;
2474 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2475 accumSize
-= HOST_CHAR_BIT
;
2478 accum
>>= HOST_CHAR_BIT
;
2479 unpacked_bytes_left
-= 1;
2480 unpacked_idx
+= delta
;
2484 /* Create a new value of type TYPE from the contents of OBJ starting
2485 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2486 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2487 assigning through the result will set the field fetched from.
2488 VALADDR is ignored unless OBJ is NULL, in which case,
2489 VALADDR+OFFSET must address the start of storage containing the
2490 packed value. The value returned in this case is never an lval.
2491 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2494 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2495 long offset
, int bit_offset
, int bit_size
,
2499 const gdb_byte
*src
; /* First byte containing data to unpack */
2501 const int is_scalar
= is_scalar_type (type
);
2502 const int is_big_endian
= gdbarch_bits_big_endian (get_type_arch (type
));
2503 gdb::byte_vector staging
;
2505 type
= ada_check_typedef (type
);
2508 src
= valaddr
+ offset
;
2510 src
= value_contents (obj
) + offset
;
2512 if (is_dynamic_type (type
))
2514 /* The length of TYPE might by dynamic, so we need to resolve
2515 TYPE in order to know its actual size, which we then use
2516 to create the contents buffer of the value we return.
2517 The difficulty is that the data containing our object is
2518 packed, and therefore maybe not at a byte boundary. So, what
2519 we do, is unpack the data into a byte-aligned buffer, and then
2520 use that buffer as our object's value for resolving the type. */
2521 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2522 staging
.resize (staging_len
);
2524 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2525 staging
.data (), staging
.size (),
2526 is_big_endian
, has_negatives (type
),
2528 type
= resolve_dynamic_type (type
, staging
.data (), 0);
2529 if (TYPE_LENGTH (type
) < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2531 /* This happens when the length of the object is dynamic,
2532 and is actually smaller than the space reserved for it.
2533 For instance, in an array of variant records, the bit_size
2534 we're given is the array stride, which is constant and
2535 normally equal to the maximum size of its element.
2536 But, in reality, each element only actually spans a portion
2538 bit_size
= TYPE_LENGTH (type
) * HOST_CHAR_BIT
;
2544 v
= allocate_value (type
);
2545 src
= valaddr
+ offset
;
2547 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2549 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2552 v
= value_at (type
, value_address (obj
) + offset
);
2553 buf
= (gdb_byte
*) alloca (src_len
);
2554 read_memory (value_address (v
), buf
, src_len
);
2559 v
= allocate_value (type
);
2560 src
= value_contents (obj
) + offset
;
2565 long new_offset
= offset
;
2567 set_value_component_location (v
, obj
);
2568 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2569 set_value_bitsize (v
, bit_size
);
2570 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2573 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2575 set_value_offset (v
, new_offset
);
2577 /* Also set the parent value. This is needed when trying to
2578 assign a new value (in inferior memory). */
2579 set_value_parent (v
, obj
);
2582 set_value_bitsize (v
, bit_size
);
2583 unpacked
= value_contents_writeable (v
);
2587 memset (unpacked
, 0, TYPE_LENGTH (type
));
2591 if (staging
.size () == TYPE_LENGTH (type
))
2593 /* Small short-cut: If we've unpacked the data into a buffer
2594 of the same size as TYPE's length, then we can reuse that,
2595 instead of doing the unpacking again. */
2596 memcpy (unpacked
, staging
.data (), staging
.size ());
2599 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2600 unpacked
, TYPE_LENGTH (type
),
2601 is_big_endian
, has_negatives (type
), is_scalar
);
2606 /* Store the contents of FROMVAL into the location of TOVAL.
2607 Return a new value with the location of TOVAL and contents of
2608 FROMVAL. Handles assignment into packed fields that have
2609 floating-point or non-scalar types. */
2611 static struct value
*
2612 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2614 struct type
*type
= value_type (toval
);
2615 int bits
= value_bitsize (toval
);
2617 toval
= ada_coerce_ref (toval
);
2618 fromval
= ada_coerce_ref (fromval
);
2620 if (ada_is_direct_array_type (value_type (toval
)))
2621 toval
= ada_coerce_to_simple_array (toval
);
2622 if (ada_is_direct_array_type (value_type (fromval
)))
2623 fromval
= ada_coerce_to_simple_array (fromval
);
2625 if (!deprecated_value_modifiable (toval
))
2626 error (_("Left operand of assignment is not a modifiable lvalue."));
2628 if (VALUE_LVAL (toval
) == lval_memory
2630 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2631 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2633 int len
= (value_bitpos (toval
)
2634 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2636 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2638 CORE_ADDR to_addr
= value_address (toval
);
2640 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2641 fromval
= value_cast (type
, fromval
);
2643 read_memory (to_addr
, buffer
, len
);
2644 from_size
= value_bitsize (fromval
);
2646 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2648 const int is_big_endian
= gdbarch_bits_big_endian (get_type_arch (type
));
2649 ULONGEST from_offset
= 0;
2650 if (is_big_endian
&& is_scalar_type (value_type (fromval
)))
2651 from_offset
= from_size
- bits
;
2652 copy_bitwise (buffer
, value_bitpos (toval
),
2653 value_contents (fromval
), from_offset
,
2654 bits
, is_big_endian
);
2655 write_memory_with_notification (to_addr
, buffer
, len
);
2657 val
= value_copy (toval
);
2658 memcpy (value_contents_raw (val
), value_contents (fromval
),
2659 TYPE_LENGTH (type
));
2660 deprecated_set_value_type (val
, type
);
2665 return value_assign (toval
, fromval
);
2669 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2670 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2671 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2672 COMPONENT, and not the inferior's memory. The current contents
2673 of COMPONENT are ignored.
2675 Although not part of the initial design, this function also works
2676 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2677 had a null address, and COMPONENT had an address which is equal to
2678 its offset inside CONTAINER. */
2681 value_assign_to_component (struct value
*container
, struct value
*component
,
2684 LONGEST offset_in_container
=
2685 (LONGEST
) (value_address (component
) - value_address (container
));
2686 int bit_offset_in_container
=
2687 value_bitpos (component
) - value_bitpos (container
);
2690 val
= value_cast (value_type (component
), val
);
2692 if (value_bitsize (component
) == 0)
2693 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2695 bits
= value_bitsize (component
);
2697 if (gdbarch_bits_big_endian (get_type_arch (value_type (container
))))
2701 if (is_scalar_type (check_typedef (value_type (component
))))
2703 = TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
;
2706 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2707 value_bitpos (container
) + bit_offset_in_container
,
2708 value_contents (val
), src_offset
, bits
, 1);
2711 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2712 value_bitpos (container
) + bit_offset_in_container
,
2713 value_contents (val
), 0, bits
, 0);
2716 /* Determine if TYPE is an access to an unconstrained array. */
2719 ada_is_access_to_unconstrained_array (struct type
*type
)
2721 return (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
2722 && is_thick_pntr (ada_typedef_target_type (type
)));
2725 /* The value of the element of array ARR at the ARITY indices given in IND.
2726 ARR may be either a simple array, GNAT array descriptor, or pointer
2730 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2734 struct type
*elt_type
;
2736 elt
= ada_coerce_to_simple_array (arr
);
2738 elt_type
= ada_check_typedef (value_type (elt
));
2739 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2740 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2741 return value_subscript_packed (elt
, arity
, ind
);
2743 for (k
= 0; k
< arity
; k
+= 1)
2745 struct type
*saved_elt_type
= TYPE_TARGET_TYPE (elt_type
);
2747 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2748 error (_("too many subscripts (%d expected)"), k
);
2750 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2752 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
2753 && TYPE_CODE (value_type (elt
)) != TYPE_CODE_TYPEDEF
)
2755 /* The element is a typedef to an unconstrained array,
2756 except that the value_subscript call stripped the
2757 typedef layer. The typedef layer is GNAT's way to
2758 specify that the element is, at the source level, an
2759 access to the unconstrained array, rather than the
2760 unconstrained array. So, we need to restore that
2761 typedef layer, which we can do by forcing the element's
2762 type back to its original type. Otherwise, the returned
2763 value is going to be printed as the array, rather
2764 than as an access. Another symptom of the same issue
2765 would be that an expression trying to dereference the
2766 element would also be improperly rejected. */
2767 deprecated_set_value_type (elt
, saved_elt_type
);
2770 elt_type
= ada_check_typedef (value_type (elt
));
2776 /* Assuming ARR is a pointer to a GDB array, the value of the element
2777 of *ARR at the ARITY indices given in IND.
2778 Does not read the entire array into memory.
2780 Note: Unlike what one would expect, this function is used instead of
2781 ada_value_subscript for basically all non-packed array types. The reason
2782 for this is that a side effect of doing our own pointer arithmetics instead
2783 of relying on value_subscript is that there is no implicit typedef peeling.
2784 This is important for arrays of array accesses, where it allows us to
2785 preserve the fact that the array's element is an array access, where the
2786 access part os encoded in a typedef layer. */
2788 static struct value
*
2789 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2792 struct value
*array_ind
= ada_value_ind (arr
);
2794 = check_typedef (value_enclosing_type (array_ind
));
2796 if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
2797 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
2798 return value_subscript_packed (array_ind
, arity
, ind
);
2800 for (k
= 0; k
< arity
; k
+= 1)
2803 struct value
*lwb_value
;
2805 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2806 error (_("too many subscripts (%d expected)"), k
);
2807 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2809 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2810 lwb_value
= value_from_longest (value_type(ind
[k
]), lwb
);
2811 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - pos_atr (lwb_value
));
2812 type
= TYPE_TARGET_TYPE (type
);
2815 return value_ind (arr
);
2818 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2819 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2820 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2821 this array is LOW, as per Ada rules. */
2822 static struct value
*
2823 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2826 struct type
*type0
= ada_check_typedef (type
);
2827 struct type
*base_index_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0
));
2828 struct type
*index_type
2829 = create_static_range_type (NULL
, base_index_type
, low
, high
);
2830 struct type
*slice_type
= create_array_type_with_stride
2831 (NULL
, TYPE_TARGET_TYPE (type0
), index_type
,
2832 get_dyn_prop (DYN_PROP_BYTE_STRIDE
, type0
),
2833 TYPE_FIELD_BITSIZE (type0
, 0));
2834 int base_low
= ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0
));
2835 LONGEST base_low_pos
, low_pos
;
2838 if (!discrete_position (base_index_type
, low
, &low_pos
)
2839 || !discrete_position (base_index_type
, base_low
, &base_low_pos
))
2841 warning (_("unable to get positions in slice, use bounds instead"));
2843 base_low_pos
= base_low
;
2846 base
= value_as_address (array_ptr
)
2847 + ((low_pos
- base_low_pos
)
2848 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0
)));
2849 return value_at_lazy (slice_type
, base
);
2853 static struct value
*
2854 ada_value_slice (struct value
*array
, int low
, int high
)
2856 struct type
*type
= ada_check_typedef (value_type (array
));
2857 struct type
*base_index_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2858 struct type
*index_type
2859 = create_static_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2860 struct type
*slice_type
= create_array_type_with_stride
2861 (NULL
, TYPE_TARGET_TYPE (type
), index_type
,
2862 get_dyn_prop (DYN_PROP_BYTE_STRIDE
, type
),
2863 TYPE_FIELD_BITSIZE (type
, 0));
2864 LONGEST low_pos
, high_pos
;
2866 if (!discrete_position (base_index_type
, low
, &low_pos
)
2867 || !discrete_position (base_index_type
, high
, &high_pos
))
2869 warning (_("unable to get positions in slice, use bounds instead"));
2874 return value_cast (slice_type
,
2875 value_slice (array
, low
, high_pos
- low_pos
+ 1));
2878 /* If type is a record type in the form of a standard GNAT array
2879 descriptor, returns the number of dimensions for type. If arr is a
2880 simple array, returns the number of "array of"s that prefix its
2881 type designation. Otherwise, returns 0. */
2884 ada_array_arity (struct type
*type
)
2891 type
= desc_base_type (type
);
2894 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2895 return desc_arity (desc_bounds_type (type
));
2897 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2900 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2906 /* If TYPE is a record type in the form of a standard GNAT array
2907 descriptor or a simple array type, returns the element type for
2908 TYPE after indexing by NINDICES indices, or by all indices if
2909 NINDICES is -1. Otherwise, returns NULL. */
2912 ada_array_element_type (struct type
*type
, int nindices
)
2914 type
= desc_base_type (type
);
2916 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2919 struct type
*p_array_type
;
2921 p_array_type
= desc_data_target_type (type
);
2923 k
= ada_array_arity (type
);
2927 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2928 if (nindices
>= 0 && k
> nindices
)
2930 while (k
> 0 && p_array_type
!= NULL
)
2932 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2935 return p_array_type
;
2937 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2939 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2941 type
= TYPE_TARGET_TYPE (type
);
2950 /* The type of nth index in arrays of given type (n numbering from 1).
2951 Does not examine memory. Throws an error if N is invalid or TYPE
2952 is not an array type. NAME is the name of the Ada attribute being
2953 evaluated ('range, 'first, 'last, or 'length); it is used in building
2954 the error message. */
2956 static struct type
*
2957 ada_index_type (struct type
*type
, int n
, const char *name
)
2959 struct type
*result_type
;
2961 type
= desc_base_type (type
);
2963 if (n
< 0 || n
> ada_array_arity (type
))
2964 error (_("invalid dimension number to '%s"), name
);
2966 if (ada_is_simple_array_type (type
))
2970 for (i
= 1; i
< n
; i
+= 1)
2971 type
= TYPE_TARGET_TYPE (type
);
2972 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2973 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2974 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2975 perhaps stabsread.c would make more sense. */
2976 if (result_type
&& TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2981 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2982 if (result_type
== NULL
)
2983 error (_("attempt to take bound of something that is not an array"));
2989 /* Given that arr is an array type, returns the lower bound of the
2990 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2991 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2992 array-descriptor type. It works for other arrays with bounds supplied
2993 by run-time quantities other than discriminants. */
2996 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
2998 struct type
*type
, *index_type_desc
, *index_type
;
3001 gdb_assert (which
== 0 || which
== 1);
3003 if (ada_is_constrained_packed_array_type (arr_type
))
3004 arr_type
= decode_constrained_packed_array_type (arr_type
);
3006 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
3007 return (LONGEST
) - which
;
3009 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
3010 type
= TYPE_TARGET_TYPE (arr_type
);
3014 if (TYPE_FIXED_INSTANCE (type
))
3016 /* The array has already been fixed, so we do not need to
3017 check the parallel ___XA type again. That encoding has
3018 already been applied, so ignore it now. */
3019 index_type_desc
= NULL
;
3023 index_type_desc
= ada_find_parallel_type (type
, "___XA");
3024 ada_fixup_array_indexes_type (index_type_desc
);
3027 if (index_type_desc
!= NULL
)
3028 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, n
- 1),
3032 struct type
*elt_type
= check_typedef (type
);
3034 for (i
= 1; i
< n
; i
++)
3035 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
3037 index_type
= TYPE_INDEX_TYPE (elt_type
);
3041 (LONGEST
) (which
== 0
3042 ? ada_discrete_type_low_bound (index_type
)
3043 : ada_discrete_type_high_bound (index_type
));
3046 /* Given that arr is an array value, returns the lower bound of the
3047 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3048 WHICH is 1. This routine will also work for arrays with bounds
3049 supplied by run-time quantities other than discriminants. */
3052 ada_array_bound (struct value
*arr
, int n
, int which
)
3054 struct type
*arr_type
;
3056 if (TYPE_CODE (check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
3057 arr
= value_ind (arr
);
3058 arr_type
= value_enclosing_type (arr
);
3060 if (ada_is_constrained_packed_array_type (arr_type
))
3061 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
3062 else if (ada_is_simple_array_type (arr_type
))
3063 return ada_array_bound_from_type (arr_type
, n
, which
);
3065 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
3068 /* Given that arr is an array value, returns the length of the
3069 nth index. This routine will also work for arrays with bounds
3070 supplied by run-time quantities other than discriminants.
3071 Does not work for arrays indexed by enumeration types with representation
3072 clauses at the moment. */
3075 ada_array_length (struct value
*arr
, int n
)
3077 struct type
*arr_type
, *index_type
;
3080 if (TYPE_CODE (check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
3081 arr
= value_ind (arr
);
3082 arr_type
= value_enclosing_type (arr
);
3084 if (ada_is_constrained_packed_array_type (arr_type
))
3085 return ada_array_length (decode_constrained_packed_array (arr
), n
);
3087 if (ada_is_simple_array_type (arr_type
))
3089 low
= ada_array_bound_from_type (arr_type
, n
, 0);
3090 high
= ada_array_bound_from_type (arr_type
, n
, 1);
3094 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
3095 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
3098 arr_type
= check_typedef (arr_type
);
3099 index_type
= ada_index_type (arr_type
, n
, "length");
3100 if (index_type
!= NULL
)
3102 struct type
*base_type
;
3103 if (TYPE_CODE (index_type
) == TYPE_CODE_RANGE
)
3104 base_type
= TYPE_TARGET_TYPE (index_type
);
3106 base_type
= index_type
;
3108 low
= pos_atr (value_from_longest (base_type
, low
));
3109 high
= pos_atr (value_from_longest (base_type
, high
));
3111 return high
- low
+ 1;
3114 /* An array whose type is that of ARR_TYPE (an array type), with
3115 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3116 less than LOW, then LOW-1 is used. */
3118 static struct value
*
3119 empty_array (struct type
*arr_type
, int low
, int high
)
3121 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3122 struct type
*index_type
3123 = create_static_range_type
3124 (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0
)), low
,
3125 high
< low
? low
- 1 : high
);
3126 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3128 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3132 /* Name resolution */
3134 /* The "decoded" name for the user-definable Ada operator corresponding
3138 ada_decoded_op_name (enum exp_opcode op
)
3142 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3144 if (ada_opname_table
[i
].op
== op
)
3145 return ada_opname_table
[i
].decoded
;
3147 error (_("Could not find operator name for opcode"));
3151 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3152 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3153 undefined namespace) and converts operators that are
3154 user-defined into appropriate function calls. If CONTEXT_TYPE is
3155 non-null, it provides a preferred result type [at the moment, only
3156 type void has any effect---causing procedures to be preferred over
3157 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3158 return type is preferred. May change (expand) *EXP. */
3161 resolve (expression_up
*expp
, int void_context_p
, int parse_completion
,
3162 innermost_block_tracker
*tracker
)
3164 struct type
*context_type
= NULL
;
3168 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
3170 resolve_subexp (expp
, &pc
, 1, context_type
, parse_completion
, tracker
);
3173 /* Resolve the operator of the subexpression beginning at
3174 position *POS of *EXPP. "Resolving" consists of replacing
3175 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3176 with their resolutions, replacing built-in operators with
3177 function calls to user-defined operators, where appropriate, and,
3178 when DEPROCEDURE_P is non-zero, converting function-valued variables
3179 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3180 are as in ada_resolve, above. */
3182 static struct value
*
3183 resolve_subexp (expression_up
*expp
, int *pos
, int deprocedure_p
,
3184 struct type
*context_type
, int parse_completion
,
3185 innermost_block_tracker
*tracker
)
3189 struct expression
*exp
; /* Convenience: == *expp. */
3190 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3191 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3192 int nargs
; /* Number of operands. */
3199 /* Pass one: resolve operands, saving their types and updating *pos,
3204 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3205 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3210 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3212 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3217 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3222 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
),
3223 parse_completion
, tracker
);
3226 case OP_ATR_MODULUS
:
3236 case TERNOP_IN_RANGE
:
3237 case BINOP_IN_BOUNDS
:
3243 case OP_DISCRETE_RANGE
:
3245 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3254 arg1
= resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3256 resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
, tracker
);
3258 resolve_subexp (expp
, pos
, 1, value_type (arg1
), parse_completion
,
3276 case BINOP_LOGICAL_AND
:
3277 case BINOP_LOGICAL_OR
:
3278 case BINOP_BITWISE_AND
:
3279 case BINOP_BITWISE_IOR
:
3280 case BINOP_BITWISE_XOR
:
3283 case BINOP_NOTEQUAL
:
3290 case BINOP_SUBSCRIPT
:
3298 case UNOP_LOGICAL_NOT
:
3308 case OP_VAR_MSYM_VALUE
:
3315 case OP_INTERNALVAR
:
3325 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3328 case STRUCTOP_STRUCT
:
3329 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3342 error (_("Unexpected operator during name resolution"));
3345 argvec
= XALLOCAVEC (struct value
*, nargs
+ 1);
3346 for (i
= 0; i
< nargs
; i
+= 1)
3347 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
,
3352 /* Pass two: perform any resolution on principal operator. */
3359 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3361 std::vector
<struct block_symbol
> candidates
;
3365 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3366 (exp
->elts
[pc
+ 2].symbol
),
3367 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3370 if (n_candidates
> 1)
3372 /* Types tend to get re-introduced locally, so if there
3373 are any local symbols that are not types, first filter
3376 for (j
= 0; j
< n_candidates
; j
+= 1)
3377 switch (SYMBOL_CLASS (candidates
[j
].symbol
))
3382 case LOC_REGPARM_ADDR
:
3390 if (j
< n_candidates
)
3393 while (j
< n_candidates
)
3395 if (SYMBOL_CLASS (candidates
[j
].symbol
) == LOC_TYPEDEF
)
3397 candidates
[j
] = candidates
[n_candidates
- 1];
3406 if (n_candidates
== 0)
3407 error (_("No definition found for %s"),
3408 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3409 else if (n_candidates
== 1)
3411 else if (deprocedure_p
3412 && !is_nonfunction (candidates
.data (), n_candidates
))
3414 i
= ada_resolve_function
3415 (candidates
.data (), n_candidates
, NULL
, 0,
3416 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
3417 context_type
, parse_completion
);
3419 error (_("Could not find a match for %s"),
3420 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3424 printf_filtered (_("Multiple matches for %s\n"),
3425 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3426 user_select_syms (candidates
.data (), n_candidates
, 1);
3430 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3431 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].symbol
;
3432 tracker
->update (candidates
[i
]);
3436 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
3439 replace_operator_with_call (expp
, pc
, 0, 4,
3440 exp
->elts
[pc
+ 2].symbol
,
3441 exp
->elts
[pc
+ 1].block
);
3448 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3449 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3451 std::vector
<struct block_symbol
> candidates
;
3455 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3456 (exp
->elts
[pc
+ 5].symbol
),
3457 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3460 if (n_candidates
== 1)
3464 i
= ada_resolve_function
3465 (candidates
.data (), n_candidates
,
3467 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
3468 context_type
, parse_completion
);
3470 error (_("Could not find a match for %s"),
3471 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
3474 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3475 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].symbol
;
3476 tracker
->update (candidates
[i
]);
3487 case BINOP_BITWISE_AND
:
3488 case BINOP_BITWISE_IOR
:
3489 case BINOP_BITWISE_XOR
:
3491 case BINOP_NOTEQUAL
:
3499 case UNOP_LOGICAL_NOT
:
3501 if (possible_user_operator_p (op
, argvec
))
3503 std::vector
<struct block_symbol
> candidates
;
3507 ada_lookup_symbol_list (ada_decoded_op_name (op
),
3511 i
= ada_resolve_function (candidates
.data (), n_candidates
, argvec
,
3512 nargs
, ada_decoded_op_name (op
), NULL
,
3517 replace_operator_with_call (expp
, pc
, nargs
, 1,
3518 candidates
[i
].symbol
,
3519 candidates
[i
].block
);
3530 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
3531 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS
,
3532 exp
->elts
[pc
+ 1].objfile
,
3533 exp
->elts
[pc
+ 2].msymbol
);
3535 return evaluate_subexp_type (exp
, pos
);
3538 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3539 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3541 /* The term "match" here is rather loose. The match is heuristic and
3545 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3547 ftype
= ada_check_typedef (ftype
);
3548 atype
= ada_check_typedef (atype
);
3550 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3551 ftype
= TYPE_TARGET_TYPE (ftype
);
3552 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3553 atype
= TYPE_TARGET_TYPE (atype
);
3555 switch (TYPE_CODE (ftype
))
3558 return TYPE_CODE (ftype
) == TYPE_CODE (atype
);
3560 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3561 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3562 TYPE_TARGET_TYPE (atype
), 0);
3565 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3567 case TYPE_CODE_ENUM
:
3568 case TYPE_CODE_RANGE
:
3569 switch (TYPE_CODE (atype
))
3572 case TYPE_CODE_ENUM
:
3573 case TYPE_CODE_RANGE
:
3579 case TYPE_CODE_ARRAY
:
3580 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3581 || ada_is_array_descriptor_type (atype
));
3583 case TYPE_CODE_STRUCT
:
3584 if (ada_is_array_descriptor_type (ftype
))
3585 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3586 || ada_is_array_descriptor_type (atype
));
3588 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3589 && !ada_is_array_descriptor_type (atype
));
3591 case TYPE_CODE_UNION
:
3593 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3597 /* Return non-zero if the formals of FUNC "sufficiently match" the
3598 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3599 may also be an enumeral, in which case it is treated as a 0-
3600 argument function. */
3603 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3606 struct type
*func_type
= SYMBOL_TYPE (func
);
3608 if (SYMBOL_CLASS (func
) == LOC_CONST
3609 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3610 return (n_actuals
== 0);
3611 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3614 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3617 for (i
= 0; i
< n_actuals
; i
+= 1)
3619 if (actuals
[i
] == NULL
)
3623 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
,
3625 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3627 if (!ada_type_match (ftype
, atype
, 1))
3634 /* False iff function type FUNC_TYPE definitely does not produce a value
3635 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3636 FUNC_TYPE is not a valid function type with a non-null return type
3637 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3640 return_match (struct type
*func_type
, struct type
*context_type
)
3642 struct type
*return_type
;
3644 if (func_type
== NULL
)
3647 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3648 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3650 return_type
= get_base_type (func_type
);
3651 if (return_type
== NULL
)
3654 context_type
= get_base_type (context_type
);
3656 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3657 return context_type
== NULL
|| return_type
== context_type
;
3658 else if (context_type
== NULL
)
3659 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3661 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3665 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3666 function (if any) that matches the types of the NARGS arguments in
3667 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3668 that returns that type, then eliminate matches that don't. If
3669 CONTEXT_TYPE is void and there is at least one match that does not
3670 return void, eliminate all matches that do.
3672 Asks the user if there is more than one match remaining. Returns -1
3673 if there is no such symbol or none is selected. NAME is used
3674 solely for messages. May re-arrange and modify SYMS in
3675 the process; the index returned is for the modified vector. */
3678 ada_resolve_function (struct block_symbol syms
[],
3679 int nsyms
, struct value
**args
, int nargs
,
3680 const char *name
, struct type
*context_type
,
3681 int parse_completion
)
3685 int m
; /* Number of hits */
3688 /* In the first pass of the loop, we only accept functions matching
3689 context_type. If none are found, we add a second pass of the loop
3690 where every function is accepted. */
3691 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3693 for (k
= 0; k
< nsyms
; k
+= 1)
3695 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].symbol
));
3697 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
3698 && (fallback
|| return_match (type
, context_type
)))
3706 /* If we got multiple matches, ask the user which one to use. Don't do this
3707 interactive thing during completion, though, as the purpose of the
3708 completion is providing a list of all possible matches. Prompting the
3709 user to filter it down would be completely unexpected in this case. */
3712 else if (m
> 1 && !parse_completion
)
3714 printf_filtered (_("Multiple matches for %s\n"), name
);
3715 user_select_syms (syms
, m
, 1);
3721 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3722 in a listing of choices during disambiguation (see sort_choices, below).
3723 The idea is that overloadings of a subprogram name from the
3724 same package should sort in their source order. We settle for ordering
3725 such symbols by their trailing number (__N or $N). */
3728 encoded_ordered_before (const char *N0
, const char *N1
)
3732 else if (N0
== NULL
)
3738 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3740 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3742 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3743 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3748 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3751 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3753 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3754 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3756 return (strcmp (N0
, N1
) < 0);
3760 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3764 sort_choices (struct block_symbol syms
[], int nsyms
)
3768 for (i
= 1; i
< nsyms
; i
+= 1)
3770 struct block_symbol sym
= syms
[i
];
3773 for (j
= i
- 1; j
>= 0; j
-= 1)
3775 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].symbol
),
3776 SYMBOL_LINKAGE_NAME (sym
.symbol
)))
3778 syms
[j
+ 1] = syms
[j
];
3784 /* Whether GDB should display formals and return types for functions in the
3785 overloads selection menu. */
3786 static bool print_signatures
= true;
3788 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3789 all but functions, the signature is just the name of the symbol. For
3790 functions, this is the name of the function, the list of types for formals
3791 and the return type (if any). */
3794 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3795 const struct type_print_options
*flags
)
3797 struct type
*type
= SYMBOL_TYPE (sym
);
3799 fprintf_filtered (stream
, "%s", SYMBOL_PRINT_NAME (sym
));
3800 if (!print_signatures
3802 || TYPE_CODE (type
) != TYPE_CODE_FUNC
)
3805 if (TYPE_NFIELDS (type
) > 0)
3809 fprintf_filtered (stream
, " (");
3810 for (i
= 0; i
< TYPE_NFIELDS (type
); ++i
)
3813 fprintf_filtered (stream
, "; ");
3814 ada_print_type (TYPE_FIELD_TYPE (type
, i
), NULL
, stream
, -1, 0,
3817 fprintf_filtered (stream
, ")");
3819 if (TYPE_TARGET_TYPE (type
) != NULL
3820 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) != TYPE_CODE_VOID
)
3822 fprintf_filtered (stream
, " return ");
3823 ada_print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, -1, 0, flags
);
3827 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3828 by asking the user (if necessary), returning the number selected,
3829 and setting the first elements of SYMS items. Error if no symbols
3832 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3833 to be re-integrated one of these days. */
3836 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3839 int *chosen
= XALLOCAVEC (int , nsyms
);
3841 int first_choice
= (max_results
== 1) ? 1 : 2;
3842 const char *select_mode
= multiple_symbols_select_mode ();
3844 if (max_results
< 1)
3845 error (_("Request to select 0 symbols!"));
3849 if (select_mode
== multiple_symbols_cancel
)
3851 canceled because the command is ambiguous\n\
3852 See set/show multiple-symbol."));
3854 /* If select_mode is "all", then return all possible symbols.
3855 Only do that if more than one symbol can be selected, of course.
3856 Otherwise, display the menu as usual. */
3857 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3860 printf_filtered (_("[0] cancel\n"));
3861 if (max_results
> 1)
3862 printf_filtered (_("[1] all\n"));
3864 sort_choices (syms
, nsyms
);
3866 for (i
= 0; i
< nsyms
; i
+= 1)
3868 if (syms
[i
].symbol
== NULL
)
3871 if (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_BLOCK
)
3873 struct symtab_and_line sal
=
3874 find_function_start_sal (syms
[i
].symbol
, 1);
3876 printf_filtered ("[%d] ", i
+ first_choice
);
3877 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3878 &type_print_raw_options
);
3879 if (sal
.symtab
== NULL
)
3880 printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3881 metadata_style
.style ().ptr (), nullptr, sal
.line
);
3885 styled_string (file_name_style
.style (),
3886 symtab_to_filename_for_display (sal
.symtab
)),
3893 (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_CONST
3894 && SYMBOL_TYPE (syms
[i
].symbol
) != NULL
3895 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) == TYPE_CODE_ENUM
);
3896 struct symtab
*symtab
= NULL
;
3898 if (SYMBOL_OBJFILE_OWNED (syms
[i
].symbol
))
3899 symtab
= symbol_symtab (syms
[i
].symbol
);
3901 if (SYMBOL_LINE (syms
[i
].symbol
) != 0 && symtab
!= NULL
)
3903 printf_filtered ("[%d] ", i
+ first_choice
);
3904 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3905 &type_print_raw_options
);
3906 printf_filtered (_(" at %s:%d\n"),
3907 symtab_to_filename_for_display (symtab
),
3908 SYMBOL_LINE (syms
[i
].symbol
));
3910 else if (is_enumeral
3911 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].symbol
)) != NULL
)
3913 printf_filtered (("[%d] "), i
+ first_choice
);
3914 ada_print_type (SYMBOL_TYPE (syms
[i
].symbol
), NULL
,
3915 gdb_stdout
, -1, 0, &type_print_raw_options
);
3916 printf_filtered (_("'(%s) (enumeral)\n"),
3917 SYMBOL_PRINT_NAME (syms
[i
].symbol
));
3921 printf_filtered ("[%d] ", i
+ first_choice
);
3922 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3923 &type_print_raw_options
);
3926 printf_filtered (is_enumeral
3927 ? _(" in %s (enumeral)\n")
3929 symtab_to_filename_for_display (symtab
));
3931 printf_filtered (is_enumeral
3932 ? _(" (enumeral)\n")
3938 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3941 for (i
= 0; i
< n_chosen
; i
+= 1)
3942 syms
[i
] = syms
[chosen
[i
]];
3947 /* Read and validate a set of numeric choices from the user in the
3948 range 0 .. N_CHOICES-1. Place the results in increasing
3949 order in CHOICES[0 .. N-1], and return N.
3951 The user types choices as a sequence of numbers on one line
3952 separated by blanks, encoding them as follows:
3954 + A choice of 0 means to cancel the selection, throwing an error.
3955 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3956 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3958 The user is not allowed to choose more than MAX_RESULTS values.
3960 ANNOTATION_SUFFIX, if present, is used to annotate the input
3961 prompts (for use with the -f switch). */
3964 get_selections (int *choices
, int n_choices
, int max_results
,
3965 int is_all_choice
, const char *annotation_suffix
)
3970 int first_choice
= is_all_choice
? 2 : 1;
3972 prompt
= getenv ("PS2");
3976 args
= command_line_input (prompt
, annotation_suffix
);
3979 error_no_arg (_("one or more choice numbers"));
3983 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3984 order, as given in args. Choices are validated. */
3990 args
= skip_spaces (args
);
3991 if (*args
== '\0' && n_chosen
== 0)
3992 error_no_arg (_("one or more choice numbers"));
3993 else if (*args
== '\0')
3996 choice
= strtol (args
, &args2
, 10);
3997 if (args
== args2
|| choice
< 0
3998 || choice
> n_choices
+ first_choice
- 1)
3999 error (_("Argument must be choice number"));
4003 error (_("cancelled"));
4005 if (choice
< first_choice
)
4007 n_chosen
= n_choices
;
4008 for (j
= 0; j
< n_choices
; j
+= 1)
4012 choice
-= first_choice
;
4014 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
4018 if (j
< 0 || choice
!= choices
[j
])
4022 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
4023 choices
[k
+ 1] = choices
[k
];
4024 choices
[j
+ 1] = choice
;
4029 if (n_chosen
> max_results
)
4030 error (_("Select no more than %d of the above"), max_results
);
4035 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4036 on the function identified by SYM and BLOCK, and taking NARGS
4037 arguments. Update *EXPP as needed to hold more space. */
4040 replace_operator_with_call (expression_up
*expp
, int pc
, int nargs
,
4041 int oplen
, struct symbol
*sym
,
4042 const struct block
*block
)
4044 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4045 symbol, -oplen for operator being replaced). */
4046 struct expression
*newexp
= (struct expression
*)
4047 xzalloc (sizeof (struct expression
)
4048 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
4049 struct expression
*exp
= expp
->get ();
4051 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
4052 newexp
->language_defn
= exp
->language_defn
;
4053 newexp
->gdbarch
= exp
->gdbarch
;
4054 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
4055 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
4056 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
4058 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
4059 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
4061 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
4062 newexp
->elts
[pc
+ 4].block
= block
;
4063 newexp
->elts
[pc
+ 5].symbol
= sym
;
4065 expp
->reset (newexp
);
4068 /* Type-class predicates */
4070 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4074 numeric_type_p (struct type
*type
)
4080 switch (TYPE_CODE (type
))
4085 case TYPE_CODE_RANGE
:
4086 return (type
== TYPE_TARGET_TYPE (type
)
4087 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
4094 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4097 integer_type_p (struct type
*type
)
4103 switch (TYPE_CODE (type
))
4107 case TYPE_CODE_RANGE
:
4108 return (type
== TYPE_TARGET_TYPE (type
)
4109 || integer_type_p (TYPE_TARGET_TYPE (type
)));
4116 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4119 scalar_type_p (struct type
*type
)
4125 switch (TYPE_CODE (type
))
4128 case TYPE_CODE_RANGE
:
4129 case TYPE_CODE_ENUM
:
4138 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4141 discrete_type_p (struct type
*type
)
4147 switch (TYPE_CODE (type
))
4150 case TYPE_CODE_RANGE
:
4151 case TYPE_CODE_ENUM
:
4152 case TYPE_CODE_BOOL
:
4160 /* Returns non-zero if OP with operands in the vector ARGS could be
4161 a user-defined function. Errs on the side of pre-defined operators
4162 (i.e., result 0). */
4165 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4167 struct type
*type0
=
4168 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
4169 struct type
*type1
=
4170 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4184 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4188 case BINOP_BITWISE_AND
:
4189 case BINOP_BITWISE_IOR
:
4190 case BINOP_BITWISE_XOR
:
4191 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4194 case BINOP_NOTEQUAL
:
4199 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4202 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4205 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4209 case UNOP_LOGICAL_NOT
:
4211 return (!numeric_type_p (type0
));
4220 1. In the following, we assume that a renaming type's name may
4221 have an ___XD suffix. It would be nice if this went away at some
4223 2. We handle both the (old) purely type-based representation of
4224 renamings and the (new) variable-based encoding. At some point,
4225 it is devoutly to be hoped that the former goes away
4226 (FIXME: hilfinger-2007-07-09).
4227 3. Subprogram renamings are not implemented, although the XRS
4228 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4230 /* If SYM encodes a renaming,
4232 <renaming> renames <renamed entity>,
4234 sets *LEN to the length of the renamed entity's name,
4235 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4236 the string describing the subcomponent selected from the renamed
4237 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4238 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4239 are undefined). Otherwise, returns a value indicating the category
4240 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4241 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4242 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4243 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4244 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4245 may be NULL, in which case they are not assigned.
4247 [Currently, however, GCC does not generate subprogram renamings.] */
4249 enum ada_renaming_category
4250 ada_parse_renaming (struct symbol
*sym
,
4251 const char **renamed_entity
, int *len
,
4252 const char **renaming_expr
)
4254 enum ada_renaming_category kind
;
4259 return ADA_NOT_RENAMING
;
4260 switch (SYMBOL_CLASS (sym
))
4263 return ADA_NOT_RENAMING
;
4267 case LOC_OPTIMIZED_OUT
:
4268 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
4270 return ADA_NOT_RENAMING
;
4274 kind
= ADA_OBJECT_RENAMING
;
4278 kind
= ADA_EXCEPTION_RENAMING
;
4282 kind
= ADA_PACKAGE_RENAMING
;
4286 kind
= ADA_SUBPROGRAM_RENAMING
;
4290 return ADA_NOT_RENAMING
;
4294 if (renamed_entity
!= NULL
)
4295 *renamed_entity
= info
;
4296 suffix
= strstr (info
, "___XE");
4297 if (suffix
== NULL
|| suffix
== info
)
4298 return ADA_NOT_RENAMING
;
4300 *len
= strlen (info
) - strlen (suffix
);
4302 if (renaming_expr
!= NULL
)
4303 *renaming_expr
= suffix
;
4307 /* Compute the value of the given RENAMING_SYM, which is expected to
4308 be a symbol encoding a renaming expression. BLOCK is the block
4309 used to evaluate the renaming. */
4311 static struct value
*
4312 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4313 const struct block
*block
)
4315 const char *sym_name
;
4317 sym_name
= SYMBOL_LINKAGE_NAME (renaming_sym
);
4318 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4319 return evaluate_expression (expr
.get ());
4323 /* Evaluation: Function Calls */
4325 /* Return an lvalue containing the value VAL. This is the identity on
4326 lvalues, and otherwise has the side-effect of allocating memory
4327 in the inferior where a copy of the value contents is copied. */
4329 static struct value
*
4330 ensure_lval (struct value
*val
)
4332 if (VALUE_LVAL (val
) == not_lval
4333 || VALUE_LVAL (val
) == lval_internalvar
)
4335 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4336 const CORE_ADDR addr
=
4337 value_as_long (value_allocate_space_in_inferior (len
));
4339 VALUE_LVAL (val
) = lval_memory
;
4340 set_value_address (val
, addr
);
4341 write_memory (addr
, value_contents (val
), len
);
4347 /* Return the value ACTUAL, converted to be an appropriate value for a
4348 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4349 allocating any necessary descriptors (fat pointers), or copies of
4350 values not residing in memory, updating it as needed. */
4353 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4355 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4356 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4357 struct type
*formal_target
=
4358 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4359 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4360 struct type
*actual_target
=
4361 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
4362 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4364 if (ada_is_array_descriptor_type (formal_target
)
4365 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
4366 return make_array_descriptor (formal_type
, actual
);
4367 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4368 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
4370 struct value
*result
;
4372 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
4373 && ada_is_array_descriptor_type (actual_target
))
4374 result
= desc_data (actual
);
4375 else if (TYPE_CODE (formal_type
) != TYPE_CODE_PTR
)
4377 if (VALUE_LVAL (actual
) != lval_memory
)
4381 actual_type
= ada_check_typedef (value_type (actual
));
4382 val
= allocate_value (actual_type
);
4383 memcpy ((char *) value_contents_raw (val
),
4384 (char *) value_contents (actual
),
4385 TYPE_LENGTH (actual_type
));
4386 actual
= ensure_lval (val
);
4388 result
= value_addr (actual
);
4392 return value_cast_pointers (formal_type
, result
, 0);
4394 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
4395 return ada_value_ind (actual
);
4396 else if (ada_is_aligner_type (formal_type
))
4398 /* We need to turn this parameter into an aligner type
4400 struct value
*aligner
= allocate_value (formal_type
);
4401 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4403 value_assign_to_component (aligner
, component
, actual
);
4410 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4411 type TYPE. This is usually an inefficient no-op except on some targets
4412 (such as AVR) where the representation of a pointer and an address
4416 value_pointer (struct value
*value
, struct type
*type
)
4418 struct gdbarch
*gdbarch
= get_type_arch (type
);
4419 unsigned len
= TYPE_LENGTH (type
);
4420 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4423 addr
= value_address (value
);
4424 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4425 addr
= extract_unsigned_integer (buf
, len
, gdbarch_byte_order (gdbarch
));
4430 /* Push a descriptor of type TYPE for array value ARR on the stack at
4431 *SP, updating *SP to reflect the new descriptor. Return either
4432 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4433 to-descriptor type rather than a descriptor type), a struct value *
4434 representing a pointer to this descriptor. */
4436 static struct value
*
4437 make_array_descriptor (struct type
*type
, struct value
*arr
)
4439 struct type
*bounds_type
= desc_bounds_type (type
);
4440 struct type
*desc_type
= desc_base_type (type
);
4441 struct value
*descriptor
= allocate_value (desc_type
);
4442 struct value
*bounds
= allocate_value (bounds_type
);
4445 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4448 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4449 ada_array_bound (arr
, i
, 0),
4450 desc_bound_bitpos (bounds_type
, i
, 0),
4451 desc_bound_bitsize (bounds_type
, i
, 0));
4452 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4453 ada_array_bound (arr
, i
, 1),
4454 desc_bound_bitpos (bounds_type
, i
, 1),
4455 desc_bound_bitsize (bounds_type
, i
, 1));
4458 bounds
= ensure_lval (bounds
);
4460 modify_field (value_type (descriptor
),
4461 value_contents_writeable (descriptor
),
4462 value_pointer (ensure_lval (arr
),
4463 TYPE_FIELD_TYPE (desc_type
, 0)),
4464 fat_pntr_data_bitpos (desc_type
),
4465 fat_pntr_data_bitsize (desc_type
));
4467 modify_field (value_type (descriptor
),
4468 value_contents_writeable (descriptor
),
4469 value_pointer (bounds
,
4470 TYPE_FIELD_TYPE (desc_type
, 1)),
4471 fat_pntr_bounds_bitpos (desc_type
),
4472 fat_pntr_bounds_bitsize (desc_type
));
4474 descriptor
= ensure_lval (descriptor
);
4476 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
4477 return value_addr (descriptor
);
4482 /* Symbol Cache Module */
4484 /* Performance measurements made as of 2010-01-15 indicate that
4485 this cache does bring some noticeable improvements. Depending
4486 on the type of entity being printed, the cache can make it as much
4487 as an order of magnitude faster than without it.
4489 The descriptive type DWARF extension has significantly reduced
4490 the need for this cache, at least when DWARF is being used. However,
4491 even in this case, some expensive name-based symbol searches are still
4492 sometimes necessary - to find an XVZ variable, mostly. */
4494 /* Initialize the contents of SYM_CACHE. */
4497 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4499 obstack_init (&sym_cache
->cache_space
);
4500 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4503 /* Free the memory used by SYM_CACHE. */
4506 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4508 obstack_free (&sym_cache
->cache_space
, NULL
);
4512 /* Return the symbol cache associated to the given program space PSPACE.
4513 If not allocated for this PSPACE yet, allocate and initialize one. */
4515 static struct ada_symbol_cache
*
4516 ada_get_symbol_cache (struct program_space
*pspace
)
4518 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4520 if (pspace_data
->sym_cache
== NULL
)
4522 pspace_data
->sym_cache
= XCNEW (struct ada_symbol_cache
);
4523 ada_init_symbol_cache (pspace_data
->sym_cache
);
4526 return pspace_data
->sym_cache
;
4529 /* Clear all entries from the symbol cache. */
4532 ada_clear_symbol_cache (void)
4534 struct ada_symbol_cache
*sym_cache
4535 = ada_get_symbol_cache (current_program_space
);
4537 obstack_free (&sym_cache
->cache_space
, NULL
);
4538 ada_init_symbol_cache (sym_cache
);
4541 /* Search our cache for an entry matching NAME and DOMAIN.
4542 Return it if found, or NULL otherwise. */
4544 static struct cache_entry
**
4545 find_entry (const char *name
, domain_enum domain
)
4547 struct ada_symbol_cache
*sym_cache
4548 = ada_get_symbol_cache (current_program_space
);
4549 int h
= msymbol_hash (name
) % HASH_SIZE
;
4550 struct cache_entry
**e
;
4552 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4554 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4560 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4561 Return 1 if found, 0 otherwise.
4563 If an entry was found and SYM is not NULL, set *SYM to the entry's
4564 SYM. Same principle for BLOCK if not NULL. */
4567 lookup_cached_symbol (const char *name
, domain_enum domain
,
4568 struct symbol
**sym
, const struct block
**block
)
4570 struct cache_entry
**e
= find_entry (name
, domain
);
4577 *block
= (*e
)->block
;
4581 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4582 in domain DOMAIN, save this result in our symbol cache. */
4585 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4586 const struct block
*block
)
4588 struct ada_symbol_cache
*sym_cache
4589 = ada_get_symbol_cache (current_program_space
);
4592 struct cache_entry
*e
;
4594 /* Symbols for builtin types don't have a block.
4595 For now don't cache such symbols. */
4596 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4599 /* If the symbol is a local symbol, then do not cache it, as a search
4600 for that symbol depends on the context. To determine whether
4601 the symbol is local or not, we check the block where we found it
4602 against the global and static blocks of its associated symtab. */
4604 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4605 GLOBAL_BLOCK
) != block
4606 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4607 STATIC_BLOCK
) != block
)
4610 h
= msymbol_hash (name
) % HASH_SIZE
;
4611 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4612 e
->next
= sym_cache
->root
[h
];
4613 sym_cache
->root
[h
] = e
;
4615 = (char *) obstack_alloc (&sym_cache
->cache_space
, strlen (name
) + 1);
4616 strcpy (copy
, name
);
4624 /* Return the symbol name match type that should be used used when
4625 searching for all symbols matching LOOKUP_NAME.
4627 LOOKUP_NAME is expected to be a symbol name after transformation
4630 static symbol_name_match_type
4631 name_match_type_from_name (const char *lookup_name
)
4633 return (strstr (lookup_name
, "__") == NULL
4634 ? symbol_name_match_type::WILD
4635 : symbol_name_match_type::FULL
);
4638 /* Return the result of a standard (literal, C-like) lookup of NAME in
4639 given DOMAIN, visible from lexical block BLOCK. */
4641 static struct symbol
*
4642 standard_lookup (const char *name
, const struct block
*block
,
4645 /* Initialize it just to avoid a GCC false warning. */
4646 struct block_symbol sym
= {};
4648 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4650 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4651 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4656 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4657 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4658 since they contend in overloading in the same way. */
4660 is_nonfunction (struct block_symbol syms
[], int n
)
4664 for (i
= 0; i
< n
; i
+= 1)
4665 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) != TYPE_CODE_FUNC
4666 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) != TYPE_CODE_ENUM
4667 || SYMBOL_CLASS (syms
[i
].symbol
) != LOC_CONST
))
4673 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4674 struct types. Otherwise, they may not. */
4677 equiv_types (struct type
*type0
, struct type
*type1
)
4681 if (type0
== NULL
|| type1
== NULL
4682 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
4684 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
4685 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
4686 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4687 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4693 /* True iff SYM0 represents the same entity as SYM1, or one that is
4694 no more defined than that of SYM1. */
4697 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4701 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4702 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4705 switch (SYMBOL_CLASS (sym0
))
4711 struct type
*type0
= SYMBOL_TYPE (sym0
);
4712 struct type
*type1
= SYMBOL_TYPE (sym1
);
4713 const char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4714 const char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4715 int len0
= strlen (name0
);
4718 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4719 && (equiv_types (type0
, type1
)
4720 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4721 && startswith (name1
+ len0
, "___XV")));
4724 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4725 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4729 const char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4730 const char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4731 return (strcmp (name0
, name1
) == 0
4732 && SYMBOL_VALUE_ADDRESS (sym0
) == SYMBOL_VALUE_ADDRESS (sym1
));
4740 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4741 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4744 add_defn_to_vec (struct obstack
*obstackp
,
4746 const struct block
*block
)
4749 struct block_symbol
*prevDefns
= defns_collected (obstackp
, 0);
4751 /* Do not try to complete stub types, as the debugger is probably
4752 already scanning all symbols matching a certain name at the
4753 time when this function is called. Trying to replace the stub
4754 type by its associated full type will cause us to restart a scan
4755 which may lead to an infinite recursion. Instead, the client
4756 collecting the matching symbols will end up collecting several
4757 matches, with at least one of them complete. It can then filter
4758 out the stub ones if needed. */
4760 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4762 if (lesseq_defined_than (sym
, prevDefns
[i
].symbol
))
4764 else if (lesseq_defined_than (prevDefns
[i
].symbol
, sym
))
4766 prevDefns
[i
].symbol
= sym
;
4767 prevDefns
[i
].block
= block
;
4773 struct block_symbol info
;
4777 obstack_grow (obstackp
, &info
, sizeof (struct block_symbol
));
4781 /* Number of block_symbol structures currently collected in current vector in
4785 num_defns_collected (struct obstack
*obstackp
)
4787 return obstack_object_size (obstackp
) / sizeof (struct block_symbol
);
4790 /* Vector of block_symbol structures currently collected in current vector in
4791 OBSTACKP. If FINISH, close off the vector and return its final address. */
4793 static struct block_symbol
*
4794 defns_collected (struct obstack
*obstackp
, int finish
)
4797 return (struct block_symbol
*) obstack_finish (obstackp
);
4799 return (struct block_symbol
*) obstack_base (obstackp
);
4802 /* Return a bound minimal symbol matching NAME according to Ada
4803 decoding rules. Returns an invalid symbol if there is no such
4804 minimal symbol. Names prefixed with "standard__" are handled
4805 specially: "standard__" is first stripped off, and only static and
4806 global symbols are searched. */
4808 struct bound_minimal_symbol
4809 ada_lookup_simple_minsym (const char *name
)
4811 struct bound_minimal_symbol result
;
4813 memset (&result
, 0, sizeof (result
));
4815 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4816 lookup_name_info
lookup_name (name
, match_type
);
4818 symbol_name_matcher_ftype
*match_name
4819 = ada_get_symbol_name_matcher (lookup_name
);
4821 for (objfile
*objfile
: current_program_space
->objfiles ())
4823 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4825 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol
), lookup_name
, NULL
)
4826 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4828 result
.minsym
= msymbol
;
4829 result
.objfile
= objfile
;
4838 /* For all subprograms that statically enclose the subprogram of the
4839 selected frame, add symbols matching identifier NAME in DOMAIN
4840 and their blocks to the list of data in OBSTACKP, as for
4841 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4842 with a wildcard prefix. */
4845 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4846 const lookup_name_info
&lookup_name
,
4851 /* True if TYPE is definitely an artificial type supplied to a symbol
4852 for which no debugging information was given in the symbol file. */
4855 is_nondebugging_type (struct type
*type
)
4857 const char *name
= ada_type_name (type
);
4859 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4862 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4863 that are deemed "identical" for practical purposes.
4865 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4866 types and that their number of enumerals is identical (in other
4867 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4870 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4874 /* The heuristic we use here is fairly conservative. We consider
4875 that 2 enumerate types are identical if they have the same
4876 number of enumerals and that all enumerals have the same
4877 underlying value and name. */
4879 /* All enums in the type should have an identical underlying value. */
4880 for (i
= 0; i
< TYPE_NFIELDS (type1
); i
++)
4881 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4884 /* All enumerals should also have the same name (modulo any numerical
4886 for (i
= 0; i
< TYPE_NFIELDS (type1
); i
++)
4888 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4889 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4890 int len_1
= strlen (name_1
);
4891 int len_2
= strlen (name_2
);
4893 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4894 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4896 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4897 TYPE_FIELD_NAME (type2
, i
),
4905 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4906 that are deemed "identical" for practical purposes. Sometimes,
4907 enumerals are not strictly identical, but their types are so similar
4908 that they can be considered identical.
4910 For instance, consider the following code:
4912 type Color is (Black, Red, Green, Blue, White);
4913 type RGB_Color is new Color range Red .. Blue;
4915 Type RGB_Color is a subrange of an implicit type which is a copy
4916 of type Color. If we call that implicit type RGB_ColorB ("B" is
4917 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4918 As a result, when an expression references any of the enumeral
4919 by name (Eg. "print green"), the expression is technically
4920 ambiguous and the user should be asked to disambiguate. But
4921 doing so would only hinder the user, since it wouldn't matter
4922 what choice he makes, the outcome would always be the same.
4923 So, for practical purposes, we consider them as the same. */
4926 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
4930 /* Before performing a thorough comparison check of each type,
4931 we perform a series of inexpensive checks. We expect that these
4932 checks will quickly fail in the vast majority of cases, and thus
4933 help prevent the unnecessary use of a more expensive comparison.
4934 Said comparison also expects us to make some of these checks
4935 (see ada_identical_enum_types_p). */
4937 /* Quick check: All symbols should have an enum type. */
4938 for (i
= 0; i
< syms
.size (); i
++)
4939 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) != TYPE_CODE_ENUM
)
4942 /* Quick check: They should all have the same value. */
4943 for (i
= 1; i
< syms
.size (); i
++)
4944 if (SYMBOL_VALUE (syms
[i
].symbol
) != SYMBOL_VALUE (syms
[0].symbol
))
4947 /* Quick check: They should all have the same number of enumerals. */
4948 for (i
= 1; i
< syms
.size (); i
++)
4949 if (TYPE_NFIELDS (SYMBOL_TYPE (syms
[i
].symbol
))
4950 != TYPE_NFIELDS (SYMBOL_TYPE (syms
[0].symbol
)))
4953 /* All the sanity checks passed, so we might have a set of
4954 identical enumeration types. Perform a more complete
4955 comparison of the type of each symbol. */
4956 for (i
= 1; i
< syms
.size (); i
++)
4957 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].symbol
),
4958 SYMBOL_TYPE (syms
[0].symbol
)))
4964 /* Remove any non-debugging symbols in SYMS that definitely
4965 duplicate other symbols in the list (The only case I know of where
4966 this happens is when object files containing stabs-in-ecoff are
4967 linked with files containing ordinary ecoff debugging symbols (or no
4968 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4969 Returns the number of items in the modified list. */
4972 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
4976 /* We should never be called with less than 2 symbols, as there
4977 cannot be any extra symbol in that case. But it's easy to
4978 handle, since we have nothing to do in that case. */
4979 if (syms
->size () < 2)
4980 return syms
->size ();
4983 while (i
< syms
->size ())
4987 /* If two symbols have the same name and one of them is a stub type,
4988 the get rid of the stub. */
4990 if (TYPE_STUB (SYMBOL_TYPE ((*syms
)[i
].symbol
))
4991 && SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
) != NULL
)
4993 for (j
= 0; j
< syms
->size (); j
++)
4996 && !TYPE_STUB (SYMBOL_TYPE ((*syms
)[j
].symbol
))
4997 && SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
) != NULL
4998 && strcmp (SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
),
4999 SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
)) == 0)
5004 /* Two symbols with the same name, same class and same address
5005 should be identical. */
5007 else if (SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
) != NULL
5008 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5009 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5011 for (j
= 0; j
< syms
->size (); j
+= 1)
5014 && SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
) != NULL
5015 && strcmp (SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
),
5016 SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
)) == 0
5017 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5018 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5019 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5020 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5026 syms
->erase (syms
->begin () + i
);
5031 /* If all the remaining symbols are identical enumerals, then
5032 just keep the first one and discard the rest.
5034 Unlike what we did previously, we do not discard any entry
5035 unless they are ALL identical. This is because the symbol
5036 comparison is not a strict comparison, but rather a practical
5037 comparison. If all symbols are considered identical, then
5038 we can just go ahead and use the first one and discard the rest.
5039 But if we cannot reduce the list to a single element, we have
5040 to ask the user to disambiguate anyways. And if we have to
5041 present a multiple-choice menu, it's less confusing if the list
5042 isn't missing some choices that were identical and yet distinct. */
5043 if (symbols_are_identical_enums (*syms
))
5046 return syms
->size ();
5049 /* Given a type that corresponds to a renaming entity, use the type name
5050 to extract the scope (package name or function name, fully qualified,
5051 and following the GNAT encoding convention) where this renaming has been
5055 xget_renaming_scope (struct type
*renaming_type
)
5057 /* The renaming types adhere to the following convention:
5058 <scope>__<rename>___<XR extension>.
5059 So, to extract the scope, we search for the "___XR" extension,
5060 and then backtrack until we find the first "__". */
5062 const char *name
= TYPE_NAME (renaming_type
);
5063 const char *suffix
= strstr (name
, "___XR");
5066 /* Now, backtrack a bit until we find the first "__". Start looking
5067 at suffix - 3, as the <rename> part is at least one character long. */
5069 for (last
= suffix
- 3; last
> name
; last
--)
5070 if (last
[0] == '_' && last
[1] == '_')
5073 /* Make a copy of scope and return it. */
5074 return std::string (name
, last
);
5077 /* Return nonzero if NAME corresponds to a package name. */
5080 is_package_name (const char *name
)
5082 /* Here, We take advantage of the fact that no symbols are generated
5083 for packages, while symbols are generated for each function.
5084 So the condition for NAME represent a package becomes equivalent
5085 to NAME not existing in our list of symbols. There is only one
5086 small complication with library-level functions (see below). */
5088 /* If it is a function that has not been defined at library level,
5089 then we should be able to look it up in the symbols. */
5090 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5093 /* Library-level function names start with "_ada_". See if function
5094 "_ada_" followed by NAME can be found. */
5096 /* Do a quick check that NAME does not contain "__", since library-level
5097 functions names cannot contain "__" in them. */
5098 if (strstr (name
, "__") != NULL
)
5101 std::string fun_name
= string_printf ("_ada_%s", name
);
5103 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5106 /* Return nonzero if SYM corresponds to a renaming entity that is
5107 not visible from FUNCTION_NAME. */
5110 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5112 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5115 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5117 /* If the rename has been defined in a package, then it is visible. */
5118 if (is_package_name (scope
.c_str ()))
5121 /* Check that the rename is in the current function scope by checking
5122 that its name starts with SCOPE. */
5124 /* If the function name starts with "_ada_", it means that it is
5125 a library-level function. Strip this prefix before doing the
5126 comparison, as the encoding for the renaming does not contain
5128 if (startswith (function_name
, "_ada_"))
5131 return !startswith (function_name
, scope
.c_str ());
5134 /* Remove entries from SYMS that corresponds to a renaming entity that
5135 is not visible from the function associated with CURRENT_BLOCK or
5136 that is superfluous due to the presence of more specific renaming
5137 information. Places surviving symbols in the initial entries of
5138 SYMS and returns the number of surviving symbols.
5141 First, in cases where an object renaming is implemented as a
5142 reference variable, GNAT may produce both the actual reference
5143 variable and the renaming encoding. In this case, we discard the
5146 Second, GNAT emits a type following a specified encoding for each renaming
5147 entity. Unfortunately, STABS currently does not support the definition
5148 of types that are local to a given lexical block, so all renamings types
5149 are emitted at library level. As a consequence, if an application
5150 contains two renaming entities using the same name, and a user tries to
5151 print the value of one of these entities, the result of the ada symbol
5152 lookup will also contain the wrong renaming type.
5154 This function partially covers for this limitation by attempting to
5155 remove from the SYMS list renaming symbols that should be visible
5156 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5157 method with the current information available. The implementation
5158 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5160 - When the user tries to print a rename in a function while there
5161 is another rename entity defined in a package: Normally, the
5162 rename in the function has precedence over the rename in the
5163 package, so the latter should be removed from the list. This is
5164 currently not the case.
5166 - This function will incorrectly remove valid renames if
5167 the CURRENT_BLOCK corresponds to a function which symbol name
5168 has been changed by an "Export" pragma. As a consequence,
5169 the user will be unable to print such rename entities. */
5172 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5173 const struct block
*current_block
)
5175 struct symbol
*current_function
;
5176 const char *current_function_name
;
5178 int is_new_style_renaming
;
5180 /* If there is both a renaming foo___XR... encoded as a variable and
5181 a simple variable foo in the same block, discard the latter.
5182 First, zero out such symbols, then compress. */
5183 is_new_style_renaming
= 0;
5184 for (i
= 0; i
< syms
->size (); i
+= 1)
5186 struct symbol
*sym
= (*syms
)[i
].symbol
;
5187 const struct block
*block
= (*syms
)[i
].block
;
5191 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5193 name
= SYMBOL_LINKAGE_NAME (sym
);
5194 suffix
= strstr (name
, "___XR");
5198 int name_len
= suffix
- name
;
5201 is_new_style_renaming
= 1;
5202 for (j
= 0; j
< syms
->size (); j
+= 1)
5203 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5204 && strncmp (name
, SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
),
5206 && block
== (*syms
)[j
].block
)
5207 (*syms
)[j
].symbol
= NULL
;
5210 if (is_new_style_renaming
)
5214 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5215 if ((*syms
)[j
].symbol
!= NULL
)
5217 (*syms
)[k
] = (*syms
)[j
];
5223 /* Extract the function name associated to CURRENT_BLOCK.
5224 Abort if unable to do so. */
5226 if (current_block
== NULL
)
5227 return syms
->size ();
5229 current_function
= block_linkage_function (current_block
);
5230 if (current_function
== NULL
)
5231 return syms
->size ();
5233 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
5234 if (current_function_name
== NULL
)
5235 return syms
->size ();
5237 /* Check each of the symbols, and remove it from the list if it is
5238 a type corresponding to a renaming that is out of the scope of
5239 the current block. */
5242 while (i
< syms
->size ())
5244 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5245 == ADA_OBJECT_RENAMING
5246 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5247 current_function_name
))
5248 syms
->erase (syms
->begin () + i
);
5253 return syms
->size ();
5256 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5257 whose name and domain match NAME and DOMAIN respectively.
5258 If no match was found, then extend the search to "enclosing"
5259 routines (in other words, if we're inside a nested function,
5260 search the symbols defined inside the enclosing functions).
5261 If WILD_MATCH_P is nonzero, perform the naming matching in
5262 "wild" mode (see function "wild_match" for more info).
5264 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5267 ada_add_local_symbols (struct obstack
*obstackp
,
5268 const lookup_name_info
&lookup_name
,
5269 const struct block
*block
, domain_enum domain
)
5271 int block_depth
= 0;
5273 while (block
!= NULL
)
5276 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5278 /* If we found a non-function match, assume that's the one. */
5279 if (is_nonfunction (defns_collected (obstackp
, 0),
5280 num_defns_collected (obstackp
)))
5283 block
= BLOCK_SUPERBLOCK (block
);
5286 /* If no luck so far, try to find NAME as a local symbol in some lexically
5287 enclosing subprogram. */
5288 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5289 add_symbols_from_enclosing_procs (obstackp
, lookup_name
, domain
);
5292 /* An object of this type is used as the user_data argument when
5293 calling the map_matching_symbols method. */
5297 struct objfile
*objfile
;
5298 struct obstack
*obstackp
;
5299 struct symbol
*arg_sym
;
5303 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
5304 to a list of symbols. DATA is a pointer to a struct match_data *
5305 containing the obstack that collects the symbol list, the file that SYM
5306 must come from, a flag indicating whether a non-argument symbol has
5307 been found in the current block, and the last argument symbol
5308 passed in SYM within the current block (if any). When SYM is null,
5309 marking the end of a block, the argument symbol is added if no
5310 other has been found. */
5313 aux_add_nonlocal_symbols (struct block_symbol
*bsym
,
5314 struct match_data
*data
)
5316 const struct block
*block
= bsym
->block
;
5317 struct symbol
*sym
= bsym
->symbol
;
5321 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5322 add_defn_to_vec (data
->obstackp
,
5323 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5325 data
->found_sym
= 0;
5326 data
->arg_sym
= NULL
;
5330 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5332 else if (SYMBOL_IS_ARGUMENT (sym
))
5333 data
->arg_sym
= sym
;
5336 data
->found_sym
= 1;
5337 add_defn_to_vec (data
->obstackp
,
5338 fixup_symbol_section (sym
, data
->objfile
),
5345 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5346 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5347 symbols to OBSTACKP. Return whether we found such symbols. */
5350 ada_add_block_renamings (struct obstack
*obstackp
,
5351 const struct block
*block
,
5352 const lookup_name_info
&lookup_name
,
5355 struct using_direct
*renaming
;
5356 int defns_mark
= num_defns_collected (obstackp
);
5358 symbol_name_matcher_ftype
*name_match
5359 = ada_get_symbol_name_matcher (lookup_name
);
5361 for (renaming
= block_using (block
);
5363 renaming
= renaming
->next
)
5367 /* Avoid infinite recursions: skip this renaming if we are actually
5368 already traversing it.
5370 Currently, symbol lookup in Ada don't use the namespace machinery from
5371 C++/Fortran support: skip namespace imports that use them. */
5372 if (renaming
->searched
5373 || (renaming
->import_src
!= NULL
5374 && renaming
->import_src
[0] != '\0')
5375 || (renaming
->import_dest
!= NULL
5376 && renaming
->import_dest
[0] != '\0'))
5378 renaming
->searched
= 1;
5380 /* TODO: here, we perform another name-based symbol lookup, which can
5381 pull its own multiple overloads. In theory, we should be able to do
5382 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5383 not a simple name. But in order to do this, we would need to enhance
5384 the DWARF reader to associate a symbol to this renaming, instead of a
5385 name. So, for now, we do something simpler: re-use the C++/Fortran
5386 namespace machinery. */
5387 r_name
= (renaming
->alias
!= NULL
5389 : renaming
->declaration
);
5390 if (name_match (r_name
, lookup_name
, NULL
))
5392 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5393 lookup_name
.match_type ());
5394 ada_add_all_symbols (obstackp
, block
, decl_lookup_name
, domain
,
5397 renaming
->searched
= 0;
5399 return num_defns_collected (obstackp
) != defns_mark
;
5402 /* Implements compare_names, but only applying the comparision using
5403 the given CASING. */
5406 compare_names_with_case (const char *string1
, const char *string2
,
5407 enum case_sensitivity casing
)
5409 while (*string1
!= '\0' && *string2
!= '\0')
5413 if (isspace (*string1
) || isspace (*string2
))
5414 return strcmp_iw_ordered (string1
, string2
);
5416 if (casing
== case_sensitive_off
)
5418 c1
= tolower (*string1
);
5419 c2
= tolower (*string2
);
5436 return strcmp_iw_ordered (string1
, string2
);
5438 if (*string2
== '\0')
5440 if (is_name_suffix (string1
))
5447 if (*string2
== '(')
5448 return strcmp_iw_ordered (string1
, string2
);
5451 if (casing
== case_sensitive_off
)
5452 return tolower (*string1
) - tolower (*string2
);
5454 return *string1
- *string2
;
5459 /* Compare STRING1 to STRING2, with results as for strcmp.
5460 Compatible with strcmp_iw_ordered in that...
5462 strcmp_iw_ordered (STRING1, STRING2) <= 0
5466 compare_names (STRING1, STRING2) <= 0
5468 (they may differ as to what symbols compare equal). */
5471 compare_names (const char *string1
, const char *string2
)
5475 /* Similar to what strcmp_iw_ordered does, we need to perform
5476 a case-insensitive comparison first, and only resort to
5477 a second, case-sensitive, comparison if the first one was
5478 not sufficient to differentiate the two strings. */
5480 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5482 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5487 /* Convenience function to get at the Ada encoded lookup name for
5488 LOOKUP_NAME, as a C string. */
5491 ada_lookup_name (const lookup_name_info
&lookup_name
)
5493 return lookup_name
.ada ().lookup_name ().c_str ();
5496 /* Add to OBSTACKP all non-local symbols whose name and domain match
5497 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5498 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5499 symbols otherwise. */
5502 add_nonlocal_symbols (struct obstack
*obstackp
,
5503 const lookup_name_info
&lookup_name
,
5504 domain_enum domain
, int global
)
5506 struct match_data data
;
5508 memset (&data
, 0, sizeof data
);
5509 data
.obstackp
= obstackp
;
5511 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5513 auto callback
= [&] (struct block_symbol
*bsym
)
5515 return aux_add_nonlocal_symbols (bsym
, &data
);
5518 for (objfile
*objfile
: current_program_space
->objfiles ())
5520 data
.objfile
= objfile
;
5522 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
,
5523 domain
, global
, callback
,
5525 ? NULL
: compare_names
));
5527 for (compunit_symtab
*cu
: objfile
->compunits ())
5529 const struct block
*global_block
5530 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5532 if (ada_add_block_renamings (obstackp
, global_block
, lookup_name
,
5538 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
5540 const char *name
= ada_lookup_name (lookup_name
);
5541 lookup_name_info
name1 (std::string ("<_ada_") + name
+ '>',
5542 symbol_name_match_type::FULL
);
5544 for (objfile
*objfile
: current_program_space
->objfiles ())
5546 data
.objfile
= objfile
;
5547 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
,
5548 domain
, global
, callback
,
5554 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5555 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5556 returning the number of matches. Add these to OBSTACKP.
5558 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5559 symbol match within the nest of blocks whose innermost member is BLOCK,
5560 is the one match returned (no other matches in that or
5561 enclosing blocks is returned). If there are any matches in or
5562 surrounding BLOCK, then these alone are returned.
5564 Names prefixed with "standard__" are handled specially:
5565 "standard__" is first stripped off (by the lookup_name
5566 constructor), and only static and global symbols are searched.
5568 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5569 to lookup global symbols. */
5572 ada_add_all_symbols (struct obstack
*obstackp
,
5573 const struct block
*block
,
5574 const lookup_name_info
&lookup_name
,
5577 int *made_global_lookup_p
)
5581 if (made_global_lookup_p
)
5582 *made_global_lookup_p
= 0;
5584 /* Special case: If the user specifies a symbol name inside package
5585 Standard, do a non-wild matching of the symbol name without
5586 the "standard__" prefix. This was primarily introduced in order
5587 to allow the user to specifically access the standard exceptions
5588 using, for instance, Standard.Constraint_Error when Constraint_Error
5589 is ambiguous (due to the user defining its own Constraint_Error
5590 entity inside its program). */
5591 if (lookup_name
.ada ().standard_p ())
5594 /* Check the non-global symbols. If we have ANY match, then we're done. */
5599 ada_add_local_symbols (obstackp
, lookup_name
, block
, domain
);
5602 /* In the !full_search case we're are being called by
5603 ada_iterate_over_symbols, and we don't want to search
5605 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5607 if (num_defns_collected (obstackp
) > 0 || !full_search
)
5611 /* No non-global symbols found. Check our cache to see if we have
5612 already performed this search before. If we have, then return
5615 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5616 domain
, &sym
, &block
))
5619 add_defn_to_vec (obstackp
, sym
, block
);
5623 if (made_global_lookup_p
)
5624 *made_global_lookup_p
= 1;
5626 /* Search symbols from all global blocks. */
5628 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 1);
5630 /* Now add symbols from all per-file blocks if we've gotten no hits
5631 (not strictly correct, but perhaps better than an error). */
5633 if (num_defns_collected (obstackp
) == 0)
5634 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 0);
5637 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5638 is non-zero, enclosing scope and in global scopes, returning the number of
5640 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5641 found and the blocks and symbol tables (if any) in which they were
5644 When full_search is non-zero, any non-function/non-enumeral
5645 symbol match within the nest of blocks whose innermost member is BLOCK,
5646 is the one match returned (no other matches in that or
5647 enclosing blocks is returned). If there are any matches in or
5648 surrounding BLOCK, then these alone are returned.
5650 Names prefixed with "standard__" are handled specially: "standard__"
5651 is first stripped off, and only static and global symbols are searched. */
5654 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5655 const struct block
*block
,
5657 std::vector
<struct block_symbol
> *results
,
5660 int syms_from_global_search
;
5662 auto_obstack obstack
;
5664 ada_add_all_symbols (&obstack
, block
, lookup_name
,
5665 domain
, full_search
, &syms_from_global_search
);
5667 ndefns
= num_defns_collected (&obstack
);
5669 struct block_symbol
*base
= defns_collected (&obstack
, 1);
5670 for (int i
= 0; i
< ndefns
; ++i
)
5671 results
->push_back (base
[i
]);
5673 ndefns
= remove_extra_symbols (results
);
5675 if (ndefns
== 0 && full_search
&& syms_from_global_search
)
5676 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5678 if (ndefns
== 1 && full_search
&& syms_from_global_search
)
5679 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5680 (*results
)[0].symbol
, (*results
)[0].block
);
5682 ndefns
= remove_irrelevant_renamings (results
, block
);
5687 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5688 in global scopes, returning the number of matches, and filling *RESULTS
5689 with (SYM,BLOCK) tuples.
5691 See ada_lookup_symbol_list_worker for further details. */
5694 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5696 std::vector
<struct block_symbol
> *results
)
5698 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5699 lookup_name_info
lookup_name (name
, name_match_type
);
5701 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, results
, 1);
5704 /* Implementation of the la_iterate_over_symbols method. */
5707 ada_iterate_over_symbols
5708 (const struct block
*block
, const lookup_name_info
&name
,
5710 gdb::function_view
<symbol_found_callback_ftype
> callback
)
5713 std::vector
<struct block_symbol
> results
;
5715 ndefs
= ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
5717 for (i
= 0; i
< ndefs
; ++i
)
5719 if (!callback (&results
[i
]))
5726 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5727 to 1, but choosing the first symbol found if there are multiple
5730 The result is stored in *INFO, which must be non-NULL.
5731 If no match is found, INFO->SYM is set to NULL. */
5734 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5736 struct block_symbol
*info
)
5738 /* Since we already have an encoded name, wrap it in '<>' to force a
5739 verbatim match. Otherwise, if the name happens to not look like
5740 an encoded name (because it doesn't include a "__"),
5741 ada_lookup_name_info would re-encode/fold it again, and that
5742 would e.g., incorrectly lowercase object renaming names like
5743 "R28b" -> "r28b". */
5744 std::string verbatim
= std::string ("<") + name
+ '>';
5746 gdb_assert (info
!= NULL
);
5747 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
);
5750 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5751 scope and in global scopes, or NULL if none. NAME is folded and
5752 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5753 choosing the first symbol if there are multiple choices. */
5756 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5759 std::vector
<struct block_symbol
> candidates
;
5762 n_candidates
= ada_lookup_symbol_list (name
, block0
, domain
, &candidates
);
5764 if (n_candidates
== 0)
5767 block_symbol info
= candidates
[0];
5768 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5772 static struct block_symbol
5773 ada_lookup_symbol_nonlocal (const struct language_defn
*langdef
,
5775 const struct block
*block
,
5776 const domain_enum domain
)
5778 struct block_symbol sym
;
5780 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
5781 if (sym
.symbol
!= NULL
)
5784 /* If we haven't found a match at this point, try the primitive
5785 types. In other languages, this search is performed before
5786 searching for global symbols in order to short-circuit that
5787 global-symbol search if it happens that the name corresponds
5788 to a primitive type. But we cannot do the same in Ada, because
5789 it is perfectly legitimate for a program to declare a type which
5790 has the same name as a standard type. If looking up a type in
5791 that situation, we have traditionally ignored the primitive type
5792 in favor of user-defined types. This is why, unlike most other
5793 languages, we search the primitive types this late and only after
5794 having searched the global symbols without success. */
5796 if (domain
== VAR_DOMAIN
)
5798 struct gdbarch
*gdbarch
;
5801 gdbarch
= target_gdbarch ();
5803 gdbarch
= block_gdbarch (block
);
5804 sym
.symbol
= language_lookup_primitive_type_as_symbol (langdef
, gdbarch
, name
);
5805 if (sym
.symbol
!= NULL
)
5813 /* True iff STR is a possible encoded suffix of a normal Ada name
5814 that is to be ignored for matching purposes. Suffixes of parallel
5815 names (e.g., XVE) are not included here. Currently, the possible suffixes
5816 are given by any of the regular expressions:
5818 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5819 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5820 TKB [subprogram suffix for task bodies]
5821 _E[0-9]+[bs]$ [protected object entry suffixes]
5822 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5824 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5825 match is performed. This sequence is used to differentiate homonyms,
5826 is an optional part of a valid name suffix. */
5829 is_name_suffix (const char *str
)
5832 const char *matching
;
5833 const int len
= strlen (str
);
5835 /* Skip optional leading __[0-9]+. */
5837 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5840 while (isdigit (str
[0]))
5846 if (str
[0] == '.' || str
[0] == '$')
5849 while (isdigit (matching
[0]))
5851 if (matching
[0] == '\0')
5857 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5860 while (isdigit (matching
[0]))
5862 if (matching
[0] == '\0')
5866 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5868 if (strcmp (str
, "TKB") == 0)
5872 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5873 with a N at the end. Unfortunately, the compiler uses the same
5874 convention for other internal types it creates. So treating
5875 all entity names that end with an "N" as a name suffix causes
5876 some regressions. For instance, consider the case of an enumerated
5877 type. To support the 'Image attribute, it creates an array whose
5879 Having a single character like this as a suffix carrying some
5880 information is a bit risky. Perhaps we should change the encoding
5881 to be something like "_N" instead. In the meantime, do not do
5882 the following check. */
5883 /* Protected Object Subprograms */
5884 if (len
== 1 && str
[0] == 'N')
5889 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5892 while (isdigit (matching
[0]))
5894 if ((matching
[0] == 'b' || matching
[0] == 's')
5895 && matching
[1] == '\0')
5899 /* ??? We should not modify STR directly, as we are doing below. This
5900 is fine in this case, but may become problematic later if we find
5901 that this alternative did not work, and want to try matching
5902 another one from the begining of STR. Since we modified it, we
5903 won't be able to find the begining of the string anymore! */
5907 while (str
[0] != '_' && str
[0] != '\0')
5909 if (str
[0] != 'n' && str
[0] != 'b')
5915 if (str
[0] == '\000')
5920 if (str
[1] != '_' || str
[2] == '\000')
5924 if (strcmp (str
+ 3, "JM") == 0)
5926 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5927 the LJM suffix in favor of the JM one. But we will
5928 still accept LJM as a valid suffix for a reasonable
5929 amount of time, just to allow ourselves to debug programs
5930 compiled using an older version of GNAT. */
5931 if (strcmp (str
+ 3, "LJM") == 0)
5935 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5936 || str
[4] == 'U' || str
[4] == 'P')
5938 if (str
[4] == 'R' && str
[5] != 'T')
5942 if (!isdigit (str
[2]))
5944 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5945 if (!isdigit (str
[k
]) && str
[k
] != '_')
5949 if (str
[0] == '$' && isdigit (str
[1]))
5951 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5952 if (!isdigit (str
[k
]) && str
[k
] != '_')
5959 /* Return non-zero if the string starting at NAME and ending before
5960 NAME_END contains no capital letters. */
5963 is_valid_name_for_wild_match (const char *name0
)
5965 std::string decoded_name
= ada_decode (name0
);
5968 /* If the decoded name starts with an angle bracket, it means that
5969 NAME0 does not follow the GNAT encoding format. It should then
5970 not be allowed as a possible wild match. */
5971 if (decoded_name
[0] == '<')
5974 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5975 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5981 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5982 that could start a simple name. Assumes that *NAMEP points into
5983 the string beginning at NAME0. */
5986 advance_wild_match (const char **namep
, const char *name0
, int target0
)
5988 const char *name
= *namep
;
5998 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
6001 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
6006 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
6007 || name
[2] == target0
))
6015 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
6025 /* Return true iff NAME encodes a name of the form prefix.PATN.
6026 Ignores any informational suffixes of NAME (i.e., for which
6027 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6031 wild_match (const char *name
, const char *patn
)
6034 const char *name0
= name
;
6038 const char *match
= name
;
6042 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
6045 if (*p
== '\0' && is_name_suffix (name
))
6046 return match
== name0
|| is_valid_name_for_wild_match (name0
);
6048 if (name
[-1] == '_')
6051 if (!advance_wild_match (&name
, name0
, *patn
))
6056 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6057 any trailing suffixes that encode debugging information or leading
6058 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6059 information that is ignored). */
6062 full_match (const char *sym_name
, const char *search_name
)
6064 size_t search_name_len
= strlen (search_name
);
6066 if (strncmp (sym_name
, search_name
, search_name_len
) == 0
6067 && is_name_suffix (sym_name
+ search_name_len
))
6070 if (startswith (sym_name
, "_ada_")
6071 && strncmp (sym_name
+ 5, search_name
, search_name_len
) == 0
6072 && is_name_suffix (sym_name
+ search_name_len
+ 5))
6078 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6079 *defn_symbols, updating the list of symbols in OBSTACKP (if
6080 necessary). OBJFILE is the section containing BLOCK. */
6083 ada_add_block_symbols (struct obstack
*obstackp
,
6084 const struct block
*block
,
6085 const lookup_name_info
&lookup_name
,
6086 domain_enum domain
, struct objfile
*objfile
)
6088 struct block_iterator iter
;
6089 /* A matching argument symbol, if any. */
6090 struct symbol
*arg_sym
;
6091 /* Set true when we find a matching non-argument symbol. */
6097 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6099 sym
= block_iter_match_next (lookup_name
, &iter
))
6101 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
6102 SYMBOL_DOMAIN (sym
), domain
))
6104 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6106 if (SYMBOL_IS_ARGUMENT (sym
))
6111 add_defn_to_vec (obstackp
,
6112 fixup_symbol_section (sym
, objfile
),
6119 /* Handle renamings. */
6121 if (ada_add_block_renamings (obstackp
, block
, lookup_name
, domain
))
6124 if (!found_sym
&& arg_sym
!= NULL
)
6126 add_defn_to_vec (obstackp
,
6127 fixup_symbol_section (arg_sym
, objfile
),
6131 if (!lookup_name
.ada ().wild_match_p ())
6135 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6136 const char *name
= ada_lookup_name
.c_str ();
6137 size_t name_len
= ada_lookup_name
.size ();
6139 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6141 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
6142 SYMBOL_DOMAIN (sym
), domain
))
6146 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
6149 cmp
= !startswith (SYMBOL_LINKAGE_NAME (sym
), "_ada_");
6151 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
6156 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
6158 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6160 if (SYMBOL_IS_ARGUMENT (sym
))
6165 add_defn_to_vec (obstackp
,
6166 fixup_symbol_section (sym
, objfile
),
6174 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6175 They aren't parameters, right? */
6176 if (!found_sym
&& arg_sym
!= NULL
)
6178 add_defn_to_vec (obstackp
,
6179 fixup_symbol_section (arg_sym
, objfile
),
6186 /* Symbol Completion */
6191 ada_lookup_name_info::matches
6192 (const char *sym_name
,
6193 symbol_name_match_type match_type
,
6194 completion_match_result
*comp_match_res
) const
6197 const char *text
= m_encoded_name
.c_str ();
6198 size_t text_len
= m_encoded_name
.size ();
6200 /* First, test against the fully qualified name of the symbol. */
6202 if (strncmp (sym_name
, text
, text_len
) == 0)
6205 std::string decoded_name
= ada_decode (sym_name
);
6206 if (match
&& !m_encoded_p
)
6208 /* One needed check before declaring a positive match is to verify
6209 that iff we are doing a verbatim match, the decoded version
6210 of the symbol name starts with '<'. Otherwise, this symbol name
6211 is not a suitable completion. */
6213 bool has_angle_bracket
= (decoded_name
[0] == '<');
6214 match
= (has_angle_bracket
== m_verbatim_p
);
6217 if (match
&& !m_verbatim_p
)
6219 /* When doing non-verbatim match, another check that needs to
6220 be done is to verify that the potentially matching symbol name
6221 does not include capital letters, because the ada-mode would
6222 not be able to understand these symbol names without the
6223 angle bracket notation. */
6226 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6231 /* Second: Try wild matching... */
6233 if (!match
&& m_wild_match_p
)
6235 /* Since we are doing wild matching, this means that TEXT
6236 may represent an unqualified symbol name. We therefore must
6237 also compare TEXT against the unqualified name of the symbol. */
6238 sym_name
= ada_unqualified_name (decoded_name
.c_str ());
6240 if (strncmp (sym_name
, text
, text_len
) == 0)
6244 /* Finally: If we found a match, prepare the result to return. */
6249 if (comp_match_res
!= NULL
)
6251 std::string
&match_str
= comp_match_res
->match
.storage ();
6254 match_str
= ada_decode (sym_name
);
6258 match_str
= add_angle_brackets (sym_name
);
6260 match_str
= sym_name
;
6264 comp_match_res
->set_match (match_str
.c_str ());
6270 /* Add the list of possible symbol names completing TEXT to TRACKER.
6271 WORD is the entire command on which completion is made. */
6274 ada_collect_symbol_completion_matches (completion_tracker
&tracker
,
6275 complete_symbol_mode mode
,
6276 symbol_name_match_type name_match_type
,
6277 const char *text
, const char *word
,
6278 enum type_code code
)
6281 const struct block
*b
, *surrounding_static_block
= 0;
6282 struct block_iterator iter
;
6284 gdb_assert (code
== TYPE_CODE_UNDEF
);
6286 lookup_name_info
lookup_name (text
, name_match_type
, true);
6288 /* First, look at the partial symtab symbols. */
6289 expand_symtabs_matching (NULL
,
6295 /* At this point scan through the misc symbol vectors and add each
6296 symbol you find to the list. Eventually we want to ignore
6297 anything that isn't a text symbol (everything else will be
6298 handled by the psymtab code above). */
6300 for (objfile
*objfile
: current_program_space
->objfiles ())
6302 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
6306 if (completion_skip_symbol (mode
, msymbol
))
6309 language symbol_language
= MSYMBOL_LANGUAGE (msymbol
);
6311 /* Ada minimal symbols won't have their language set to Ada. If
6312 we let completion_list_add_name compare using the
6313 default/C-like matcher, then when completing e.g., symbols in a
6314 package named "pck", we'd match internal Ada symbols like
6315 "pckS", which are invalid in an Ada expression, unless you wrap
6316 them in '<' '>' to request a verbatim match.
6318 Unfortunately, some Ada encoded names successfully demangle as
6319 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6320 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6321 with the wrong language set. Paper over that issue here. */
6322 if (symbol_language
== language_auto
6323 || symbol_language
== language_cplus
)
6324 symbol_language
= language_ada
;
6326 completion_list_add_name (tracker
,
6328 MSYMBOL_LINKAGE_NAME (msymbol
),
6329 lookup_name
, text
, word
);
6333 /* Search upwards from currently selected frame (so that we can
6334 complete on local vars. */
6336 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
6338 if (!BLOCK_SUPERBLOCK (b
))
6339 surrounding_static_block
= b
; /* For elmin of dups */
6341 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6343 if (completion_skip_symbol (mode
, sym
))
6346 completion_list_add_name (tracker
,
6347 SYMBOL_LANGUAGE (sym
),
6348 SYMBOL_LINKAGE_NAME (sym
),
6349 lookup_name
, text
, word
);
6353 /* Go through the symtabs and check the externs and statics for
6354 symbols which match. */
6356 for (objfile
*objfile
: current_program_space
->objfiles ())
6358 for (compunit_symtab
*s
: objfile
->compunits ())
6361 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
6362 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6364 if (completion_skip_symbol (mode
, sym
))
6367 completion_list_add_name (tracker
,
6368 SYMBOL_LANGUAGE (sym
),
6369 SYMBOL_LINKAGE_NAME (sym
),
6370 lookup_name
, text
, word
);
6375 for (objfile
*objfile
: current_program_space
->objfiles ())
6377 for (compunit_symtab
*s
: objfile
->compunits ())
6380 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
6381 /* Don't do this block twice. */
6382 if (b
== surrounding_static_block
)
6384 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6386 if (completion_skip_symbol (mode
, sym
))
6389 completion_list_add_name (tracker
,
6390 SYMBOL_LANGUAGE (sym
),
6391 SYMBOL_LINKAGE_NAME (sym
),
6392 lookup_name
, text
, word
);
6400 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6401 for tagged types. */
6404 ada_is_dispatch_table_ptr_type (struct type
*type
)
6408 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
6411 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
6415 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6418 /* Return non-zero if TYPE is an interface tag. */
6421 ada_is_interface_tag (struct type
*type
)
6423 const char *name
= TYPE_NAME (type
);
6428 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6431 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6432 to be invisible to users. */
6435 ada_is_ignored_field (struct type
*type
, int field_num
)
6437 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
6440 /* Check the name of that field. */
6442 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6444 /* Anonymous field names should not be printed.
6445 brobecker/2007-02-20: I don't think this can actually happen
6446 but we don't want to print the value of annonymous fields anyway. */
6450 /* Normally, fields whose name start with an underscore ("_")
6451 are fields that have been internally generated by the compiler,
6452 and thus should not be printed. The "_parent" field is special,
6453 however: This is a field internally generated by the compiler
6454 for tagged types, and it contains the components inherited from
6455 the parent type. This field should not be printed as is, but
6456 should not be ignored either. */
6457 if (name
[0] == '_' && !startswith (name
, "_parent"))
6461 /* If this is the dispatch table of a tagged type or an interface tag,
6463 if (ada_is_tagged_type (type
, 1)
6464 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
))
6465 || ada_is_interface_tag (TYPE_FIELD_TYPE (type
, field_num
))))
6468 /* Not a special field, so it should not be ignored. */
6472 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6473 pointer or reference type whose ultimate target has a tag field. */
6476 ada_is_tagged_type (struct type
*type
, int refok
)
6478 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6481 /* True iff TYPE represents the type of X'Tag */
6484 ada_is_tag_type (struct type
*type
)
6486 type
= ada_check_typedef (type
);
6488 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
6492 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6494 return (name
!= NULL
6495 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6499 /* The type of the tag on VAL. */
6502 ada_tag_type (struct value
*val
)
6504 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6507 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6508 retired at Ada 05). */
6511 is_ada95_tag (struct value
*tag
)
6513 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6516 /* The value of the tag on VAL. */
6519 ada_value_tag (struct value
*val
)
6521 return ada_value_struct_elt (val
, "_tag", 0);
6524 /* The value of the tag on the object of type TYPE whose contents are
6525 saved at VALADDR, if it is non-null, or is at memory address
6528 static struct value
*
6529 value_tag_from_contents_and_address (struct type
*type
,
6530 const gdb_byte
*valaddr
,
6533 int tag_byte_offset
;
6534 struct type
*tag_type
;
6536 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6539 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6541 : valaddr
+ tag_byte_offset
);
6542 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6544 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6549 static struct type
*
6550 type_from_tag (struct value
*tag
)
6552 const char *type_name
= ada_tag_name (tag
);
6554 if (type_name
!= NULL
)
6555 return ada_find_any_type (ada_encode (type_name
));
6559 /* Given a value OBJ of a tagged type, return a value of this
6560 type at the base address of the object. The base address, as
6561 defined in Ada.Tags, it is the address of the primary tag of
6562 the object, and therefore where the field values of its full
6563 view can be fetched. */
6566 ada_tag_value_at_base_address (struct value
*obj
)
6569 LONGEST offset_to_top
= 0;
6570 struct type
*ptr_type
, *obj_type
;
6572 CORE_ADDR base_address
;
6574 obj_type
= value_type (obj
);
6576 /* It is the responsability of the caller to deref pointers. */
6578 if (TYPE_CODE (obj_type
) == TYPE_CODE_PTR
6579 || TYPE_CODE (obj_type
) == TYPE_CODE_REF
)
6582 tag
= ada_value_tag (obj
);
6586 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6588 if (is_ada95_tag (tag
))
6591 ptr_type
= language_lookup_primitive_type
6592 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6593 ptr_type
= lookup_pointer_type (ptr_type
);
6594 val
= value_cast (ptr_type
, tag
);
6598 /* It is perfectly possible that an exception be raised while
6599 trying to determine the base address, just like for the tag;
6600 see ada_tag_name for more details. We do not print the error
6601 message for the same reason. */
6605 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6608 catch (const gdb_exception_error
&e
)
6613 /* If offset is null, nothing to do. */
6615 if (offset_to_top
== 0)
6618 /* -1 is a special case in Ada.Tags; however, what should be done
6619 is not quite clear from the documentation. So do nothing for
6622 if (offset_to_top
== -1)
6625 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6626 from the base address. This was however incompatible with
6627 C++ dispatch table: C++ uses a *negative* value to *add*
6628 to the base address. Ada's convention has therefore been
6629 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6630 use the same convention. Here, we support both cases by
6631 checking the sign of OFFSET_TO_TOP. */
6633 if (offset_to_top
> 0)
6634 offset_to_top
= -offset_to_top
;
6636 base_address
= value_address (obj
) + offset_to_top
;
6637 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6639 /* Make sure that we have a proper tag at the new address.
6640 Otherwise, offset_to_top is bogus (which can happen when
6641 the object is not initialized yet). */
6646 obj_type
= type_from_tag (tag
);
6651 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6654 /* Return the "ada__tags__type_specific_data" type. */
6656 static struct type
*
6657 ada_get_tsd_type (struct inferior
*inf
)
6659 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6661 if (data
->tsd_type
== 0)
6662 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6663 return data
->tsd_type
;
6666 /* Return the TSD (type-specific data) associated to the given TAG.
6667 TAG is assumed to be the tag of a tagged-type entity.
6669 May return NULL if we are unable to get the TSD. */
6671 static struct value
*
6672 ada_get_tsd_from_tag (struct value
*tag
)
6677 /* First option: The TSD is simply stored as a field of our TAG.
6678 Only older versions of GNAT would use this format, but we have
6679 to test it first, because there are no visible markers for
6680 the current approach except the absence of that field. */
6682 val
= ada_value_struct_elt (tag
, "tsd", 1);
6686 /* Try the second representation for the dispatch table (in which
6687 there is no explicit 'tsd' field in the referent of the tag pointer,
6688 and instead the tsd pointer is stored just before the dispatch
6691 type
= ada_get_tsd_type (current_inferior());
6694 type
= lookup_pointer_type (lookup_pointer_type (type
));
6695 val
= value_cast (type
, tag
);
6698 return value_ind (value_ptradd (val
, -1));
6701 /* Given the TSD of a tag (type-specific data), return a string
6702 containing the name of the associated type.
6704 The returned value is good until the next call. May return NULL
6705 if we are unable to determine the tag name. */
6708 ada_tag_name_from_tsd (struct value
*tsd
)
6710 static char name
[1024];
6714 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6717 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
6718 for (p
= name
; *p
!= '\0'; p
+= 1)
6724 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6727 Return NULL if the TAG is not an Ada tag, or if we were unable to
6728 determine the name of that tag. The result is good until the next
6732 ada_tag_name (struct value
*tag
)
6736 if (!ada_is_tag_type (value_type (tag
)))
6739 /* It is perfectly possible that an exception be raised while trying
6740 to determine the TAG's name, even under normal circumstances:
6741 The associated variable may be uninitialized or corrupted, for
6742 instance. We do not let any exception propagate past this point.
6743 instead we return NULL.
6745 We also do not print the error message either (which often is very
6746 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6747 the caller print a more meaningful message if necessary. */
6750 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6753 name
= ada_tag_name_from_tsd (tsd
);
6755 catch (const gdb_exception_error
&e
)
6762 /* The parent type of TYPE, or NULL if none. */
6765 ada_parent_type (struct type
*type
)
6769 type
= ada_check_typedef (type
);
6771 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6774 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6775 if (ada_is_parent_field (type
, i
))
6777 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
6779 /* If the _parent field is a pointer, then dereference it. */
6780 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
6781 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6782 /* If there is a parallel XVS type, get the actual base type. */
6783 parent_type
= ada_get_base_type (parent_type
);
6785 return ada_check_typedef (parent_type
);
6791 /* True iff field number FIELD_NUM of structure type TYPE contains the
6792 parent-type (inherited) fields of a derived type. Assumes TYPE is
6793 a structure type with at least FIELD_NUM+1 fields. */
6796 ada_is_parent_field (struct type
*type
, int field_num
)
6798 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6800 return (name
!= NULL
6801 && (startswith (name
, "PARENT")
6802 || startswith (name
, "_parent")));
6805 /* True iff field number FIELD_NUM of structure type TYPE is a
6806 transparent wrapper field (which should be silently traversed when doing
6807 field selection and flattened when printing). Assumes TYPE is a
6808 structure type with at least FIELD_NUM+1 fields. Such fields are always
6812 ada_is_wrapper_field (struct type
*type
, int field_num
)
6814 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6816 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6818 /* This happens in functions with "out" or "in out" parameters
6819 which are passed by copy. For such functions, GNAT describes
6820 the function's return type as being a struct where the return
6821 value is in a field called RETVAL, and where the other "out"
6822 or "in out" parameters are fields of that struct. This is not
6827 return (name
!= NULL
6828 && (startswith (name
, "PARENT")
6829 || strcmp (name
, "REP") == 0
6830 || startswith (name
, "_parent")
6831 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6834 /* True iff field number FIELD_NUM of structure or union type TYPE
6835 is a variant wrapper. Assumes TYPE is a structure type with at least
6836 FIELD_NUM+1 fields. */
6839 ada_is_variant_part (struct type
*type
, int field_num
)
6841 /* Only Ada types are eligible. */
6842 if (!ADA_TYPE_P (type
))
6845 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
6847 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
6848 || (is_dynamic_field (type
, field_num
)
6849 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
6850 == TYPE_CODE_UNION
)));
6853 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6854 whose discriminants are contained in the record type OUTER_TYPE,
6855 returns the type of the controlling discriminant for the variant.
6856 May return NULL if the type could not be found. */
6859 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6861 const char *name
= ada_variant_discrim_name (var_type
);
6863 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6866 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6867 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6868 represents a 'when others' clause; otherwise 0. */
6871 ada_is_others_clause (struct type
*type
, int field_num
)
6873 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6875 return (name
!= NULL
&& name
[0] == 'O');
6878 /* Assuming that TYPE0 is the type of the variant part of a record,
6879 returns the name of the discriminant controlling the variant.
6880 The value is valid until the next call to ada_variant_discrim_name. */
6883 ada_variant_discrim_name (struct type
*type0
)
6885 static char *result
= NULL
;
6886 static size_t result_len
= 0;
6889 const char *discrim_end
;
6890 const char *discrim_start
;
6892 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
6893 type
= TYPE_TARGET_TYPE (type0
);
6897 name
= ada_type_name (type
);
6899 if (name
== NULL
|| name
[0] == '\000')
6902 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6905 if (startswith (discrim_end
, "___XVN"))
6908 if (discrim_end
== name
)
6911 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6914 if (discrim_start
== name
+ 1)
6916 if ((discrim_start
> name
+ 3
6917 && startswith (discrim_start
- 3, "___"))
6918 || discrim_start
[-1] == '.')
6922 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6923 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6924 result
[discrim_end
- discrim_start
] = '\0';
6928 /* Scan STR for a subtype-encoded number, beginning at position K.
6929 Put the position of the character just past the number scanned in
6930 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6931 Return 1 if there was a valid number at the given position, and 0
6932 otherwise. A "subtype-encoded" number consists of the absolute value
6933 in decimal, followed by the letter 'm' to indicate a negative number.
6934 Assumes 0m does not occur. */
6937 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6941 if (!isdigit (str
[k
]))
6944 /* Do it the hard way so as not to make any assumption about
6945 the relationship of unsigned long (%lu scan format code) and
6948 while (isdigit (str
[k
]))
6950 RU
= RU
* 10 + (str
[k
] - '0');
6957 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6963 /* NOTE on the above: Technically, C does not say what the results of
6964 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6965 number representable as a LONGEST (although either would probably work
6966 in most implementations). When RU>0, the locution in the then branch
6967 above is always equivalent to the negative of RU. */
6974 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6975 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6976 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6979 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6981 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6995 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
7005 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
7006 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
7008 if (val
>= L
&& val
<= U
)
7020 /* FIXME: Lots of redundancy below. Try to consolidate. */
7022 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7023 ARG_TYPE, extract and return the value of one of its (non-static)
7024 fields. FIELDNO says which field. Differs from value_primitive_field
7025 only in that it can handle packed values of arbitrary type. */
7027 static struct value
*
7028 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
7029 struct type
*arg_type
)
7033 arg_type
= ada_check_typedef (arg_type
);
7034 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
7036 /* Handle packed fields. It might be that the field is not packed
7037 relative to its containing structure, but the structure itself is
7038 packed; in this case we must take the bit-field path. */
7039 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
7041 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
7042 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
7044 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
7045 offset
+ bit_pos
/ 8,
7046 bit_pos
% 8, bit_size
, type
);
7049 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
7052 /* Find field with name NAME in object of type TYPE. If found,
7053 set the following for each argument that is non-null:
7054 - *FIELD_TYPE_P to the field's type;
7055 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7056 an object of that type;
7057 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7058 - *BIT_SIZE_P to its size in bits if the field is packed, and
7060 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7061 fields up to but not including the desired field, or by the total
7062 number of fields if not found. A NULL value of NAME never
7063 matches; the function just counts visible fields in this case.
7065 Notice that we need to handle when a tagged record hierarchy
7066 has some components with the same name, like in this scenario:
7068 type Top_T is tagged record
7074 type Middle_T is new Top.Top_T with record
7075 N : Character := 'a';
7079 type Bottom_T is new Middle.Middle_T with record
7081 C : Character := '5';
7083 A : Character := 'J';
7086 Let's say we now have a variable declared and initialized as follow:
7088 TC : Top_A := new Bottom_T;
7090 And then we use this variable to call this function
7092 procedure Assign (Obj: in out Top_T; TV : Integer);
7096 Assign (Top_T (B), 12);
7098 Now, we're in the debugger, and we're inside that procedure
7099 then and we want to print the value of obj.c:
7101 Usually, the tagged record or one of the parent type owns the
7102 component to print and there's no issue but in this particular
7103 case, what does it mean to ask for Obj.C? Since the actual
7104 type for object is type Bottom_T, it could mean two things: type
7105 component C from the Middle_T view, but also component C from
7106 Bottom_T. So in that "undefined" case, when the component is
7107 not found in the non-resolved type (which includes all the
7108 components of the parent type), then resolve it and see if we
7109 get better luck once expanded.
7111 In the case of homonyms in the derived tagged type, we don't
7112 guaranty anything, and pick the one that's easiest for us
7115 Returns 1 if found, 0 otherwise. */
7118 find_struct_field (const char *name
, struct type
*type
, int offset
,
7119 struct type
**field_type_p
,
7120 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
7124 int parent_offset
= -1;
7126 type
= ada_check_typedef (type
);
7128 if (field_type_p
!= NULL
)
7129 *field_type_p
= NULL
;
7130 if (byte_offset_p
!= NULL
)
7132 if (bit_offset_p
!= NULL
)
7134 if (bit_size_p
!= NULL
)
7137 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7139 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
7140 int fld_offset
= offset
+ bit_pos
/ 8;
7141 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7143 if (t_field_name
== NULL
)
7146 else if (ada_is_parent_field (type
, i
))
7148 /* This is a field pointing us to the parent type of a tagged
7149 type. As hinted in this function's documentation, we give
7150 preference to fields in the current record first, so what
7151 we do here is just record the index of this field before
7152 we skip it. If it turns out we couldn't find our field
7153 in the current record, then we'll get back to it and search
7154 inside it whether the field might exist in the parent. */
7160 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7162 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7164 if (field_type_p
!= NULL
)
7165 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
7166 if (byte_offset_p
!= NULL
)
7167 *byte_offset_p
= fld_offset
;
7168 if (bit_offset_p
!= NULL
)
7169 *bit_offset_p
= bit_pos
% 8;
7170 if (bit_size_p
!= NULL
)
7171 *bit_size_p
= bit_size
;
7174 else if (ada_is_wrapper_field (type
, i
))
7176 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
7177 field_type_p
, byte_offset_p
, bit_offset_p
,
7178 bit_size_p
, index_p
))
7181 else if (ada_is_variant_part (type
, i
))
7183 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7186 struct type
*field_type
7187 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
7189 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
7191 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
7193 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7194 field_type_p
, byte_offset_p
,
7195 bit_offset_p
, bit_size_p
, index_p
))
7199 else if (index_p
!= NULL
)
7203 /* Field not found so far. If this is a tagged type which
7204 has a parent, try finding that field in the parent now. */
7206 if (parent_offset
!= -1)
7208 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
7209 int fld_offset
= offset
+ bit_pos
/ 8;
7211 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, parent_offset
),
7212 fld_offset
, field_type_p
, byte_offset_p
,
7213 bit_offset_p
, bit_size_p
, index_p
))
7220 /* Number of user-visible fields in record type TYPE. */
7223 num_visible_fields (struct type
*type
)
7228 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7232 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7233 and search in it assuming it has (class) type TYPE.
7234 If found, return value, else return NULL.
7236 Searches recursively through wrapper fields (e.g., '_parent').
7238 In the case of homonyms in the tagged types, please refer to the
7239 long explanation in find_struct_field's function documentation. */
7241 static struct value
*
7242 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7246 int parent_offset
= -1;
7248 type
= ada_check_typedef (type
);
7249 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7251 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7253 if (t_field_name
== NULL
)
7256 else if (ada_is_parent_field (type
, i
))
7258 /* This is a field pointing us to the parent type of a tagged
7259 type. As hinted in this function's documentation, we give
7260 preference to fields in the current record first, so what
7261 we do here is just record the index of this field before
7262 we skip it. If it turns out we couldn't find our field
7263 in the current record, then we'll get back to it and search
7264 inside it whether the field might exist in the parent. */
7270 else if (field_name_match (t_field_name
, name
))
7271 return ada_value_primitive_field (arg
, offset
, i
, type
);
7273 else if (ada_is_wrapper_field (type
, i
))
7275 struct value
*v
= /* Do not let indent join lines here. */
7276 ada_search_struct_field (name
, arg
,
7277 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7278 TYPE_FIELD_TYPE (type
, i
));
7284 else if (ada_is_variant_part (type
, i
))
7286 /* PNH: Do we ever get here? See find_struct_field. */
7288 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7290 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7292 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
7294 struct value
*v
= ada_search_struct_field
/* Force line
7297 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7298 TYPE_FIELD_TYPE (field_type
, j
));
7306 /* Field not found so far. If this is a tagged type which
7307 has a parent, try finding that field in the parent now. */
7309 if (parent_offset
!= -1)
7311 struct value
*v
= ada_search_struct_field (
7312 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7313 TYPE_FIELD_TYPE (type
, parent_offset
));
7322 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7323 int, struct type
*);
7326 /* Return field #INDEX in ARG, where the index is that returned by
7327 * find_struct_field through its INDEX_P argument. Adjust the address
7328 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7329 * If found, return value, else return NULL. */
7331 static struct value
*
7332 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7335 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7339 /* Auxiliary function for ada_index_struct_field. Like
7340 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7343 static struct value
*
7344 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7348 type
= ada_check_typedef (type
);
7350 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7352 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7354 else if (ada_is_wrapper_field (type
, i
))
7356 struct value
*v
= /* Do not let indent join lines here. */
7357 ada_index_struct_field_1 (index_p
, arg
,
7358 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7359 TYPE_FIELD_TYPE (type
, i
));
7365 else if (ada_is_variant_part (type
, i
))
7367 /* PNH: Do we ever get here? See ada_search_struct_field,
7368 find_struct_field. */
7369 error (_("Cannot assign this kind of variant record"));
7371 else if (*index_p
== 0)
7372 return ada_value_primitive_field (arg
, offset
, i
, type
);
7379 /* Given ARG, a value of type (pointer or reference to a)*
7380 structure/union, extract the component named NAME from the ultimate
7381 target structure/union and return it as a value with its
7384 The routine searches for NAME among all members of the structure itself
7385 and (recursively) among all members of any wrapper members
7388 If NO_ERR, then simply return NULL in case of error, rather than
7392 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
7394 struct type
*t
, *t1
;
7399 t1
= t
= ada_check_typedef (value_type (arg
));
7400 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7402 t1
= TYPE_TARGET_TYPE (t
);
7405 t1
= ada_check_typedef (t1
);
7406 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7408 arg
= coerce_ref (arg
);
7413 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7415 t1
= TYPE_TARGET_TYPE (t
);
7418 t1
= ada_check_typedef (t1
);
7419 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7421 arg
= value_ind (arg
);
7428 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
7432 v
= ada_search_struct_field (name
, arg
, 0, t
);
7435 int bit_offset
, bit_size
, byte_offset
;
7436 struct type
*field_type
;
7439 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7440 address
= value_address (ada_value_ind (arg
));
7442 address
= value_address (ada_coerce_ref (arg
));
7444 /* Check to see if this is a tagged type. We also need to handle
7445 the case where the type is a reference to a tagged type, but
7446 we have to be careful to exclude pointers to tagged types.
7447 The latter should be shown as usual (as a pointer), whereas
7448 a reference should mostly be transparent to the user. */
7450 if (ada_is_tagged_type (t1
, 0)
7451 || (TYPE_CODE (t1
) == TYPE_CODE_REF
7452 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1
), 0)))
7454 /* We first try to find the searched field in the current type.
7455 If not found then let's look in the fixed type. */
7457 if (!find_struct_field (name
, t1
, 0,
7458 &field_type
, &byte_offset
, &bit_offset
,
7467 /* Convert to fixed type in all cases, so that we have proper
7468 offsets to each field in unconstrained record types. */
7469 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
7470 address
, NULL
, check_tag
);
7472 if (find_struct_field (name
, t1
, 0,
7473 &field_type
, &byte_offset
, &bit_offset
,
7478 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7479 arg
= ada_coerce_ref (arg
);
7481 arg
= ada_value_ind (arg
);
7482 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
7483 bit_offset
, bit_size
,
7487 v
= value_at_lazy (field_type
, address
+ byte_offset
);
7491 if (v
!= NULL
|| no_err
)
7494 error (_("There is no member named %s."), name
);
7500 error (_("Attempt to extract a component of "
7501 "a value that is not a record."));
7504 /* Return a string representation of type TYPE. */
7507 type_as_string (struct type
*type
)
7509 string_file tmp_stream
;
7511 type_print (type
, "", &tmp_stream
, -1);
7513 return std::move (tmp_stream
.string ());
7516 /* Given a type TYPE, look up the type of the component of type named NAME.
7517 If DISPP is non-null, add its byte displacement from the beginning of a
7518 structure (pointed to by a value) of type TYPE to *DISPP (does not
7519 work for packed fields).
7521 Matches any field whose name has NAME as a prefix, possibly
7524 TYPE can be either a struct or union. If REFOK, TYPE may also
7525 be a (pointer or reference)+ to a struct or union, and the
7526 ultimate target type will be searched.
7528 Looks recursively into variant clauses and parent types.
7530 In the case of homonyms in the tagged types, please refer to the
7531 long explanation in find_struct_field's function documentation.
7533 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7534 TYPE is not a type of the right kind. */
7536 static struct type
*
7537 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7541 int parent_offset
= -1;
7546 if (refok
&& type
!= NULL
)
7549 type
= ada_check_typedef (type
);
7550 if (TYPE_CODE (type
) != TYPE_CODE_PTR
7551 && TYPE_CODE (type
) != TYPE_CODE_REF
)
7553 type
= TYPE_TARGET_TYPE (type
);
7557 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
7558 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
7563 error (_("Type %s is not a structure or union type"),
7564 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7567 type
= to_static_fixed_type (type
);
7569 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7571 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7574 if (t_field_name
== NULL
)
7577 else if (ada_is_parent_field (type
, i
))
7579 /* This is a field pointing us to the parent type of a tagged
7580 type. As hinted in this function's documentation, we give
7581 preference to fields in the current record first, so what
7582 we do here is just record the index of this field before
7583 we skip it. If it turns out we couldn't find our field
7584 in the current record, then we'll get back to it and search
7585 inside it whether the field might exist in the parent. */
7591 else if (field_name_match (t_field_name
, name
))
7592 return TYPE_FIELD_TYPE (type
, i
);
7594 else if (ada_is_wrapper_field (type
, i
))
7596 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
7602 else if (ada_is_variant_part (type
, i
))
7605 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7608 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7610 /* FIXME pnh 2008/01/26: We check for a field that is
7611 NOT wrapped in a struct, since the compiler sometimes
7612 generates these for unchecked variant types. Revisit
7613 if the compiler changes this practice. */
7614 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7616 if (v_field_name
!= NULL
7617 && field_name_match (v_field_name
, name
))
7618 t
= TYPE_FIELD_TYPE (field_type
, j
);
7620 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
,
7631 /* Field not found so far. If this is a tagged type which
7632 has a parent, try finding that field in the parent now. */
7634 if (parent_offset
!= -1)
7638 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, parent_offset
),
7647 const char *name_str
= name
!= NULL
? name
: _("<null>");
7649 error (_("Type %s has no component named %s"),
7650 type_as_string (type
).c_str (), name_str
);
7656 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7657 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7658 represents an unchecked union (that is, the variant part of a
7659 record that is named in an Unchecked_Union pragma). */
7662 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7664 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7666 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7670 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7671 within a value of type OUTER_TYPE that is stored in GDB at
7672 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7673 numbering from 0) is applicable. Returns -1 if none are. */
7676 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
7677 const gdb_byte
*outer_valaddr
)
7681 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7682 struct value
*outer
;
7683 struct value
*discrim
;
7684 LONGEST discrim_val
;
7686 /* Using plain value_from_contents_and_address here causes problems
7687 because we will end up trying to resolve a type that is currently
7688 being constructed. */
7689 outer
= value_from_contents_and_address_unresolved (outer_type
,
7691 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7692 if (discrim
== NULL
)
7694 discrim_val
= value_as_long (discrim
);
7697 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
7699 if (ada_is_others_clause (var_type
, i
))
7701 else if (ada_in_variant (discrim_val
, var_type
, i
))
7705 return others_clause
;
7710 /* Dynamic-Sized Records */
7712 /* Strategy: The type ostensibly attached to a value with dynamic size
7713 (i.e., a size that is not statically recorded in the debugging
7714 data) does not accurately reflect the size or layout of the value.
7715 Our strategy is to convert these values to values with accurate,
7716 conventional types that are constructed on the fly. */
7718 /* There is a subtle and tricky problem here. In general, we cannot
7719 determine the size of dynamic records without its data. However,
7720 the 'struct value' data structure, which GDB uses to represent
7721 quantities in the inferior process (the target), requires the size
7722 of the type at the time of its allocation in order to reserve space
7723 for GDB's internal copy of the data. That's why the
7724 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7725 rather than struct value*s.
7727 However, GDB's internal history variables ($1, $2, etc.) are
7728 struct value*s containing internal copies of the data that are not, in
7729 general, the same as the data at their corresponding addresses in
7730 the target. Fortunately, the types we give to these values are all
7731 conventional, fixed-size types (as per the strategy described
7732 above), so that we don't usually have to perform the
7733 'to_fixed_xxx_type' conversions to look at their values.
7734 Unfortunately, there is one exception: if one of the internal
7735 history variables is an array whose elements are unconstrained
7736 records, then we will need to create distinct fixed types for each
7737 element selected. */
7739 /* The upshot of all of this is that many routines take a (type, host
7740 address, target address) triple as arguments to represent a value.
7741 The host address, if non-null, is supposed to contain an internal
7742 copy of the relevant data; otherwise, the program is to consult the
7743 target at the target address. */
7745 /* Assuming that VAL0 represents a pointer value, the result of
7746 dereferencing it. Differs from value_ind in its treatment of
7747 dynamic-sized types. */
7750 ada_value_ind (struct value
*val0
)
7752 struct value
*val
= value_ind (val0
);
7754 if (ada_is_tagged_type (value_type (val
), 0))
7755 val
= ada_tag_value_at_base_address (val
);
7757 return ada_to_fixed_value (val
);
7760 /* The value resulting from dereferencing any "reference to"
7761 qualifiers on VAL0. */
7763 static struct value
*
7764 ada_coerce_ref (struct value
*val0
)
7766 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
7768 struct value
*val
= val0
;
7770 val
= coerce_ref (val
);
7772 if (ada_is_tagged_type (value_type (val
), 0))
7773 val
= ada_tag_value_at_base_address (val
);
7775 return ada_to_fixed_value (val
);
7781 /* Return OFF rounded upward if necessary to a multiple of
7782 ALIGNMENT (a power of 2). */
7785 align_value (unsigned int off
, unsigned int alignment
)
7787 return (off
+ alignment
- 1) & ~(alignment
- 1);
7790 /* Return the bit alignment required for field #F of template type TYPE. */
7793 field_alignment (struct type
*type
, int f
)
7795 const char *name
= TYPE_FIELD_NAME (type
, f
);
7799 /* The field name should never be null, unless the debugging information
7800 is somehow malformed. In this case, we assume the field does not
7801 require any alignment. */
7805 len
= strlen (name
);
7807 if (!isdigit (name
[len
- 1]))
7810 if (isdigit (name
[len
- 2]))
7811 align_offset
= len
- 2;
7813 align_offset
= len
- 1;
7815 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7816 return TARGET_CHAR_BIT
;
7818 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7821 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7823 static struct symbol
*
7824 ada_find_any_type_symbol (const char *name
)
7828 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7829 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7832 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7836 /* Find a type named NAME. Ignores ambiguity. This routine will look
7837 solely for types defined by debug info, it will not search the GDB
7840 static struct type
*
7841 ada_find_any_type (const char *name
)
7843 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7846 return SYMBOL_TYPE (sym
);
7851 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7852 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7853 symbol, in which case it is returned. Otherwise, this looks for
7854 symbols whose name is that of NAME_SYM suffixed with "___XR".
7855 Return symbol if found, and NULL otherwise. */
7858 ada_is_renaming_symbol (struct symbol
*name_sym
)
7860 const char *name
= SYMBOL_LINKAGE_NAME (name_sym
);
7861 return strstr (name
, "___XR") != NULL
;
7864 /* Because of GNAT encoding conventions, several GDB symbols may match a
7865 given type name. If the type denoted by TYPE0 is to be preferred to
7866 that of TYPE1 for purposes of type printing, return non-zero;
7867 otherwise return 0. */
7870 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7874 else if (type0
== NULL
)
7876 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
7878 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
7880 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
7882 else if (ada_is_constrained_packed_array_type (type0
))
7884 else if (ada_is_array_descriptor_type (type0
)
7885 && !ada_is_array_descriptor_type (type1
))
7889 const char *type0_name
= TYPE_NAME (type0
);
7890 const char *type1_name
= TYPE_NAME (type1
);
7892 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7893 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7899 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7903 ada_type_name (struct type
*type
)
7907 return TYPE_NAME (type
);
7910 /* Search the list of "descriptive" types associated to TYPE for a type
7911 whose name is NAME. */
7913 static struct type
*
7914 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7916 struct type
*result
, *tmp
;
7918 if (ada_ignore_descriptive_types_p
)
7921 /* If there no descriptive-type info, then there is no parallel type
7923 if (!HAVE_GNAT_AUX_INFO (type
))
7926 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7927 while (result
!= NULL
)
7929 const char *result_name
= ada_type_name (result
);
7931 if (result_name
== NULL
)
7933 warning (_("unexpected null name on descriptive type"));
7937 /* If the names match, stop. */
7938 if (strcmp (result_name
, name
) == 0)
7941 /* Otherwise, look at the next item on the list, if any. */
7942 if (HAVE_GNAT_AUX_INFO (result
))
7943 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7947 /* If not found either, try after having resolved the typedef. */
7952 result
= check_typedef (result
);
7953 if (HAVE_GNAT_AUX_INFO (result
))
7954 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7960 /* If we didn't find a match, see whether this is a packed array. With
7961 older compilers, the descriptive type information is either absent or
7962 irrelevant when it comes to packed arrays so the above lookup fails.
7963 Fall back to using a parallel lookup by name in this case. */
7964 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7965 return ada_find_any_type (name
);
7970 /* Find a parallel type to TYPE with the specified NAME, using the
7971 descriptive type taken from the debugging information, if available,
7972 and otherwise using the (slower) name-based method. */
7974 static struct type
*
7975 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7977 struct type
*result
= NULL
;
7979 if (HAVE_GNAT_AUX_INFO (type
))
7980 result
= find_parallel_type_by_descriptive_type (type
, name
);
7982 result
= ada_find_any_type (name
);
7987 /* Same as above, but specify the name of the parallel type by appending
7988 SUFFIX to the name of TYPE. */
7991 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7994 const char *type_name
= ada_type_name (type
);
7997 if (type_name
== NULL
)
8000 len
= strlen (type_name
);
8002 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
8004 strcpy (name
, type_name
);
8005 strcpy (name
+ len
, suffix
);
8007 return ada_find_parallel_type_with_name (type
, name
);
8010 /* If TYPE is a variable-size record type, return the corresponding template
8011 type describing its fields. Otherwise, return NULL. */
8013 static struct type
*
8014 dynamic_template_type (struct type
*type
)
8016 type
= ada_check_typedef (type
);
8018 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
8019 || ada_type_name (type
) == NULL
)
8023 int len
= strlen (ada_type_name (type
));
8025 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
8028 return ada_find_parallel_type (type
, "___XVE");
8032 /* Assuming that TEMPL_TYPE is a union or struct type, returns
8033 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
8036 is_dynamic_field (struct type
*templ_type
, int field_num
)
8038 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
8041 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
8042 && strstr (name
, "___XVL") != NULL
;
8045 /* The index of the variant field of TYPE, or -1 if TYPE does not
8046 represent a variant record type. */
8049 variant_field_index (struct type
*type
)
8053 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
8056 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
8058 if (ada_is_variant_part (type
, f
))
8064 /* A record type with no fields. */
8066 static struct type
*
8067 empty_record (struct type
*templ
)
8069 struct type
*type
= alloc_type_copy (templ
);
8071 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
8072 TYPE_NFIELDS (type
) = 0;
8073 TYPE_FIELDS (type
) = NULL
;
8074 INIT_NONE_SPECIFIC (type
);
8075 TYPE_NAME (type
) = "<empty>";
8076 TYPE_LENGTH (type
) = 0;
8080 /* An ordinary record type (with fixed-length fields) that describes
8081 the value of type TYPE at VALADDR or ADDRESS (see comments at
8082 the beginning of this section) VAL according to GNAT conventions.
8083 DVAL0 should describe the (portion of a) record that contains any
8084 necessary discriminants. It should be NULL if value_type (VAL) is
8085 an outer-level type (i.e., as opposed to a branch of a variant.) A
8086 variant field (unless unchecked) is replaced by a particular branch
8089 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8090 length are not statically known are discarded. As a consequence,
8091 VALADDR, ADDRESS and DVAL0 are ignored.
8093 NOTE: Limitations: For now, we assume that dynamic fields and
8094 variants occupy whole numbers of bytes. However, they need not be
8098 ada_template_to_fixed_record_type_1 (struct type
*type
,
8099 const gdb_byte
*valaddr
,
8100 CORE_ADDR address
, struct value
*dval0
,
8101 int keep_dynamic_fields
)
8103 struct value
*mark
= value_mark ();
8106 int nfields
, bit_len
;
8112 /* Compute the number of fields in this record type that are going
8113 to be processed: unless keep_dynamic_fields, this includes only
8114 fields whose position and length are static will be processed. */
8115 if (keep_dynamic_fields
)
8116 nfields
= TYPE_NFIELDS (type
);
8120 while (nfields
< TYPE_NFIELDS (type
)
8121 && !ada_is_variant_part (type
, nfields
)
8122 && !is_dynamic_field (type
, nfields
))
8126 rtype
= alloc_type_copy (type
);
8127 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
8128 INIT_NONE_SPECIFIC (rtype
);
8129 TYPE_NFIELDS (rtype
) = nfields
;
8130 TYPE_FIELDS (rtype
) = (struct field
*)
8131 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8132 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
8133 TYPE_NAME (rtype
) = ada_type_name (type
);
8134 TYPE_FIXED_INSTANCE (rtype
) = 1;
8140 for (f
= 0; f
< nfields
; f
+= 1)
8142 off
= align_value (off
, field_alignment (type
, f
))
8143 + TYPE_FIELD_BITPOS (type
, f
);
8144 SET_FIELD_BITPOS (TYPE_FIELD (rtype
, f
), off
);
8145 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
8147 if (ada_is_variant_part (type
, f
))
8152 else if (is_dynamic_field (type
, f
))
8154 const gdb_byte
*field_valaddr
= valaddr
;
8155 CORE_ADDR field_address
= address
;
8156 struct type
*field_type
=
8157 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
));
8161 /* rtype's length is computed based on the run-time
8162 value of discriminants. If the discriminants are not
8163 initialized, the type size may be completely bogus and
8164 GDB may fail to allocate a value for it. So check the
8165 size first before creating the value. */
8166 ada_ensure_varsize_limit (rtype
);
8167 /* Using plain value_from_contents_and_address here
8168 causes problems because we will end up trying to
8169 resolve a type that is currently being
8171 dval
= value_from_contents_and_address_unresolved (rtype
,
8174 rtype
= value_type (dval
);
8179 /* If the type referenced by this field is an aligner type, we need
8180 to unwrap that aligner type, because its size might not be set.
8181 Keeping the aligner type would cause us to compute the wrong
8182 size for this field, impacting the offset of the all the fields
8183 that follow this one. */
8184 if (ada_is_aligner_type (field_type
))
8186 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
8188 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
8189 field_address
= cond_offset_target (field_address
, field_offset
);
8190 field_type
= ada_aligned_type (field_type
);
8193 field_valaddr
= cond_offset_host (field_valaddr
,
8194 off
/ TARGET_CHAR_BIT
);
8195 field_address
= cond_offset_target (field_address
,
8196 off
/ TARGET_CHAR_BIT
);
8198 /* Get the fixed type of the field. Note that, in this case,
8199 we do not want to get the real type out of the tag: if
8200 the current field is the parent part of a tagged record,
8201 we will get the tag of the object. Clearly wrong: the real
8202 type of the parent is not the real type of the child. We
8203 would end up in an infinite loop. */
8204 field_type
= ada_get_base_type (field_type
);
8205 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
8206 field_address
, dval
, 0);
8207 /* If the field size is already larger than the maximum
8208 object size, then the record itself will necessarily
8209 be larger than the maximum object size. We need to make
8210 this check now, because the size might be so ridiculously
8211 large (due to an uninitialized variable in the inferior)
8212 that it would cause an overflow when adding it to the
8214 ada_ensure_varsize_limit (field_type
);
8216 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
8217 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8218 /* The multiplication can potentially overflow. But because
8219 the field length has been size-checked just above, and
8220 assuming that the maximum size is a reasonable value,
8221 an overflow should not happen in practice. So rather than
8222 adding overflow recovery code to this already complex code,
8223 we just assume that it's not going to happen. */
8225 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
8229 /* Note: If this field's type is a typedef, it is important
8230 to preserve the typedef layer.
8232 Otherwise, we might be transforming a typedef to a fat
8233 pointer (encoding a pointer to an unconstrained array),
8234 into a basic fat pointer (encoding an unconstrained
8235 array). As both types are implemented using the same
8236 structure, the typedef is the only clue which allows us
8237 to distinguish between the two options. Stripping it
8238 would prevent us from printing this field appropriately. */
8239 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
8240 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8241 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
8243 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
8246 struct type
*field_type
= TYPE_FIELD_TYPE (type
, f
);
8248 /* We need to be careful of typedefs when computing
8249 the length of our field. If this is a typedef,
8250 get the length of the target type, not the length
8252 if (TYPE_CODE (field_type
) == TYPE_CODE_TYPEDEF
)
8253 field_type
= ada_typedef_target_type (field_type
);
8256 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
8259 if (off
+ fld_bit_len
> bit_len
)
8260 bit_len
= off
+ fld_bit_len
;
8262 TYPE_LENGTH (rtype
) =
8263 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8266 /* We handle the variant part, if any, at the end because of certain
8267 odd cases in which it is re-ordered so as NOT to be the last field of
8268 the record. This can happen in the presence of representation
8270 if (variant_field
>= 0)
8272 struct type
*branch_type
;
8274 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8278 /* Using plain value_from_contents_and_address here causes
8279 problems because we will end up trying to resolve a type
8280 that is currently being constructed. */
8281 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8283 rtype
= value_type (dval
);
8289 to_fixed_variant_branch_type
8290 (TYPE_FIELD_TYPE (type
, variant_field
),
8291 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8292 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8293 if (branch_type
== NULL
)
8295 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
8296 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
8297 TYPE_NFIELDS (rtype
) -= 1;
8301 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8302 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8304 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
8306 if (off
+ fld_bit_len
> bit_len
)
8307 bit_len
= off
+ fld_bit_len
;
8308 TYPE_LENGTH (rtype
) =
8309 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8313 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8314 should contain the alignment of that record, which should be a strictly
8315 positive value. If null or negative, then something is wrong, most
8316 probably in the debug info. In that case, we don't round up the size
8317 of the resulting type. If this record is not part of another structure,
8318 the current RTYPE length might be good enough for our purposes. */
8319 if (TYPE_LENGTH (type
) <= 0)
8321 if (TYPE_NAME (rtype
))
8322 warning (_("Invalid type size for `%s' detected: %s."),
8323 TYPE_NAME (rtype
), pulongest (TYPE_LENGTH (type
)));
8325 warning (_("Invalid type size for <unnamed> detected: %s."),
8326 pulongest (TYPE_LENGTH (type
)));
8330 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
8331 TYPE_LENGTH (type
));
8334 value_free_to_mark (mark
);
8335 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8336 error (_("record type with dynamic size is larger than varsize-limit"));
8340 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8343 static struct type
*
8344 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8345 CORE_ADDR address
, struct value
*dval0
)
8347 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8351 /* An ordinary record type in which ___XVL-convention fields and
8352 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8353 static approximations, containing all possible fields. Uses
8354 no runtime values. Useless for use in values, but that's OK,
8355 since the results are used only for type determinations. Works on both
8356 structs and unions. Representation note: to save space, we memorize
8357 the result of this function in the TYPE_TARGET_TYPE of the
8360 static struct type
*
8361 template_to_static_fixed_type (struct type
*type0
)
8367 /* No need no do anything if the input type is already fixed. */
8368 if (TYPE_FIXED_INSTANCE (type0
))
8371 /* Likewise if we already have computed the static approximation. */
8372 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8373 return TYPE_TARGET_TYPE (type0
);
8375 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8377 nfields
= TYPE_NFIELDS (type0
);
8379 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8380 recompute all over next time. */
8381 TYPE_TARGET_TYPE (type0
) = type
;
8383 for (f
= 0; f
< nfields
; f
+= 1)
8385 struct type
*field_type
= TYPE_FIELD_TYPE (type0
, f
);
8386 struct type
*new_type
;
8388 if (is_dynamic_field (type0
, f
))
8390 field_type
= ada_check_typedef (field_type
);
8391 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8394 new_type
= static_unwrap_type (field_type
);
8396 if (new_type
!= field_type
)
8398 /* Clone TYPE0 only the first time we get a new field type. */
8401 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8402 TYPE_CODE (type
) = TYPE_CODE (type0
);
8403 INIT_NONE_SPECIFIC (type
);
8404 TYPE_NFIELDS (type
) = nfields
;
8405 TYPE_FIELDS (type
) = (struct field
*)
8406 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
8407 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
8408 sizeof (struct field
) * nfields
);
8409 TYPE_NAME (type
) = ada_type_name (type0
);
8410 TYPE_FIXED_INSTANCE (type
) = 1;
8411 TYPE_LENGTH (type
) = 0;
8413 TYPE_FIELD_TYPE (type
, f
) = new_type
;
8414 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8421 /* Given an object of type TYPE whose contents are at VALADDR and
8422 whose address in memory is ADDRESS, returns a revision of TYPE,
8423 which should be a non-dynamic-sized record, in which the variant
8424 part, if any, is replaced with the appropriate branch. Looks
8425 for discriminant values in DVAL0, which can be NULL if the record
8426 contains the necessary discriminant values. */
8428 static struct type
*
8429 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8430 CORE_ADDR address
, struct value
*dval0
)
8432 struct value
*mark
= value_mark ();
8435 struct type
*branch_type
;
8436 int nfields
= TYPE_NFIELDS (type
);
8437 int variant_field
= variant_field_index (type
);
8439 if (variant_field
== -1)
8444 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8445 type
= value_type (dval
);
8450 rtype
= alloc_type_copy (type
);
8451 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
8452 INIT_NONE_SPECIFIC (rtype
);
8453 TYPE_NFIELDS (rtype
) = nfields
;
8454 TYPE_FIELDS (rtype
) =
8455 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8456 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
8457 sizeof (struct field
) * nfields
);
8458 TYPE_NAME (rtype
) = ada_type_name (type
);
8459 TYPE_FIXED_INSTANCE (rtype
) = 1;
8460 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8462 branch_type
= to_fixed_variant_branch_type
8463 (TYPE_FIELD_TYPE (type
, variant_field
),
8464 cond_offset_host (valaddr
,
8465 TYPE_FIELD_BITPOS (type
, variant_field
)
8467 cond_offset_target (address
,
8468 TYPE_FIELD_BITPOS (type
, variant_field
)
8469 / TARGET_CHAR_BIT
), dval
);
8470 if (branch_type
== NULL
)
8474 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8475 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
8476 TYPE_NFIELDS (rtype
) -= 1;
8480 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8481 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8482 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8483 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8485 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
8487 value_free_to_mark (mark
);
8491 /* An ordinary record type (with fixed-length fields) that describes
8492 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8493 beginning of this section]. Any necessary discriminants' values
8494 should be in DVAL, a record value; it may be NULL if the object
8495 at ADDR itself contains any necessary discriminant values.
8496 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8497 values from the record are needed. Except in the case that DVAL,
8498 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8499 unchecked) is replaced by a particular branch of the variant.
8501 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8502 is questionable and may be removed. It can arise during the
8503 processing of an unconstrained-array-of-record type where all the
8504 variant branches have exactly the same size. This is because in
8505 such cases, the compiler does not bother to use the XVS convention
8506 when encoding the record. I am currently dubious of this
8507 shortcut and suspect the compiler should be altered. FIXME. */
8509 static struct type
*
8510 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8511 CORE_ADDR address
, struct value
*dval
)
8513 struct type
*templ_type
;
8515 if (TYPE_FIXED_INSTANCE (type0
))
8518 templ_type
= dynamic_template_type (type0
);
8520 if (templ_type
!= NULL
)
8521 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8522 else if (variant_field_index (type0
) >= 0)
8524 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8526 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8531 TYPE_FIXED_INSTANCE (type0
) = 1;
8537 /* An ordinary record type (with fixed-length fields) that describes
8538 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8539 union type. Any necessary discriminants' values should be in DVAL,
8540 a record value. That is, this routine selects the appropriate
8541 branch of the union at ADDR according to the discriminant value
8542 indicated in the union's type name. Returns VAR_TYPE0 itself if
8543 it represents a variant subject to a pragma Unchecked_Union. */
8545 static struct type
*
8546 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8547 CORE_ADDR address
, struct value
*dval
)
8550 struct type
*templ_type
;
8551 struct type
*var_type
;
8553 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
8554 var_type
= TYPE_TARGET_TYPE (var_type0
);
8556 var_type
= var_type0
;
8558 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8560 if (templ_type
!= NULL
)
8561 var_type
= templ_type
;
8563 if (is_unchecked_variant (var_type
, value_type (dval
)))
8566 ada_which_variant_applies (var_type
,
8567 value_type (dval
), value_contents (dval
));
8570 return empty_record (var_type
);
8571 else if (is_dynamic_field (var_type
, which
))
8572 return to_fixed_record_type
8573 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
8574 valaddr
, address
, dval
);
8575 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
8577 to_fixed_record_type
8578 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
8580 return TYPE_FIELD_TYPE (var_type
, which
);
8583 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8584 ENCODING_TYPE, a type following the GNAT conventions for discrete
8585 type encodings, only carries redundant information. */
8588 ada_is_redundant_range_encoding (struct type
*range_type
,
8589 struct type
*encoding_type
)
8591 const char *bounds_str
;
8595 gdb_assert (TYPE_CODE (range_type
) == TYPE_CODE_RANGE
);
8597 if (TYPE_CODE (get_base_type (range_type
))
8598 != TYPE_CODE (get_base_type (encoding_type
)))
8600 /* The compiler probably used a simple base type to describe
8601 the range type instead of the range's actual base type,
8602 expecting us to get the real base type from the encoding
8603 anyway. In this situation, the encoding cannot be ignored
8608 if (is_dynamic_type (range_type
))
8611 if (TYPE_NAME (encoding_type
) == NULL
)
8614 bounds_str
= strstr (TYPE_NAME (encoding_type
), "___XDLU_");
8615 if (bounds_str
== NULL
)
8618 n
= 8; /* Skip "___XDLU_". */
8619 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8621 if (TYPE_LOW_BOUND (range_type
) != lo
)
8624 n
+= 2; /* Skip the "__" separator between the two bounds. */
8625 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8627 if (TYPE_HIGH_BOUND (range_type
) != hi
)
8633 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8634 a type following the GNAT encoding for describing array type
8635 indices, only carries redundant information. */
8638 ada_is_redundant_index_type_desc (struct type
*array_type
,
8639 struct type
*desc_type
)
8641 struct type
*this_layer
= check_typedef (array_type
);
8644 for (i
= 0; i
< TYPE_NFIELDS (desc_type
); i
++)
8646 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer
),
8647 TYPE_FIELD_TYPE (desc_type
, i
)))
8649 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8655 /* Assuming that TYPE0 is an array type describing the type of a value
8656 at ADDR, and that DVAL describes a record containing any
8657 discriminants used in TYPE0, returns a type for the value that
8658 contains no dynamic components (that is, no components whose sizes
8659 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8660 true, gives an error message if the resulting type's size is over
8663 static struct type
*
8664 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8667 struct type
*index_type_desc
;
8668 struct type
*result
;
8669 int constrained_packed_array_p
;
8670 static const char *xa_suffix
= "___XA";
8672 type0
= ada_check_typedef (type0
);
8673 if (TYPE_FIXED_INSTANCE (type0
))
8676 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8677 if (constrained_packed_array_p
)
8678 type0
= decode_constrained_packed_array_type (type0
);
8680 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8682 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8683 encoding suffixed with 'P' may still be generated. If so,
8684 it should be used to find the XA type. */
8686 if (index_type_desc
== NULL
)
8688 const char *type_name
= ada_type_name (type0
);
8690 if (type_name
!= NULL
)
8692 const int len
= strlen (type_name
);
8693 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8695 if (type_name
[len
- 1] == 'P')
8697 strcpy (name
, type_name
);
8698 strcpy (name
+ len
- 1, xa_suffix
);
8699 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8704 ada_fixup_array_indexes_type (index_type_desc
);
8705 if (index_type_desc
!= NULL
8706 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8708 /* Ignore this ___XA parallel type, as it does not bring any
8709 useful information. This allows us to avoid creating fixed
8710 versions of the array's index types, which would be identical
8711 to the original ones. This, in turn, can also help avoid
8712 the creation of fixed versions of the array itself. */
8713 index_type_desc
= NULL
;
8716 if (index_type_desc
== NULL
)
8718 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8720 /* NOTE: elt_type---the fixed version of elt_type0---should never
8721 depend on the contents of the array in properly constructed
8723 /* Create a fixed version of the array element type.
8724 We're not providing the address of an element here,
8725 and thus the actual object value cannot be inspected to do
8726 the conversion. This should not be a problem, since arrays of
8727 unconstrained objects are not allowed. In particular, all
8728 the elements of an array of a tagged type should all be of
8729 the same type specified in the debugging info. No need to
8730 consult the object tag. */
8731 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8733 /* Make sure we always create a new array type when dealing with
8734 packed array types, since we're going to fix-up the array
8735 type length and element bitsize a little further down. */
8736 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8739 result
= create_array_type (alloc_type_copy (type0
),
8740 elt_type
, TYPE_INDEX_TYPE (type0
));
8745 struct type
*elt_type0
;
8748 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
8749 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8751 /* NOTE: result---the fixed version of elt_type0---should never
8752 depend on the contents of the array in properly constructed
8754 /* Create a fixed version of the array element type.
8755 We're not providing the address of an element here,
8756 and thus the actual object value cannot be inspected to do
8757 the conversion. This should not be a problem, since arrays of
8758 unconstrained objects are not allowed. In particular, all
8759 the elements of an array of a tagged type should all be of
8760 the same type specified in the debugging info. No need to
8761 consult the object tag. */
8763 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8766 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
8768 struct type
*range_type
=
8769 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, i
), dval
);
8771 result
= create_array_type (alloc_type_copy (elt_type0
),
8772 result
, range_type
);
8773 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8775 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8776 error (_("array type with dynamic size is larger than varsize-limit"));
8779 /* We want to preserve the type name. This can be useful when
8780 trying to get the type name of a value that has already been
8781 printed (for instance, if the user did "print VAR; whatis $". */
8782 TYPE_NAME (result
) = TYPE_NAME (type0
);
8784 if (constrained_packed_array_p
)
8786 /* So far, the resulting type has been created as if the original
8787 type was a regular (non-packed) array type. As a result, the
8788 bitsize of the array elements needs to be set again, and the array
8789 length needs to be recomputed based on that bitsize. */
8790 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8791 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8793 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8794 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8795 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8796 TYPE_LENGTH (result
)++;
8799 TYPE_FIXED_INSTANCE (result
) = 1;
8804 /* A standard type (containing no dynamically sized components)
8805 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8806 DVAL describes a record containing any discriminants used in TYPE0,
8807 and may be NULL if there are none, or if the object of type TYPE at
8808 ADDRESS or in VALADDR contains these discriminants.
8810 If CHECK_TAG is not null, in the case of tagged types, this function
8811 attempts to locate the object's tag and use it to compute the actual
8812 type. However, when ADDRESS is null, we cannot use it to determine the
8813 location of the tag, and therefore compute the tagged type's actual type.
8814 So we return the tagged type without consulting the tag. */
8816 static struct type
*
8817 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8818 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8820 type
= ada_check_typedef (type
);
8822 /* Only un-fixed types need to be handled here. */
8823 if (!HAVE_GNAT_AUX_INFO (type
))
8826 switch (TYPE_CODE (type
))
8830 case TYPE_CODE_STRUCT
:
8832 struct type
*static_type
= to_static_fixed_type (type
);
8833 struct type
*fixed_record_type
=
8834 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8836 /* If STATIC_TYPE is a tagged type and we know the object's address,
8837 then we can determine its tag, and compute the object's actual
8838 type from there. Note that we have to use the fixed record
8839 type (the parent part of the record may have dynamic fields
8840 and the way the location of _tag is expressed may depend on
8843 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8846 value_tag_from_contents_and_address
8850 struct type
*real_type
= type_from_tag (tag
);
8852 value_from_contents_and_address (fixed_record_type
,
8855 fixed_record_type
= value_type (obj
);
8856 if (real_type
!= NULL
)
8857 return to_fixed_record_type
8859 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8862 /* Check to see if there is a parallel ___XVZ variable.
8863 If there is, then it provides the actual size of our type. */
8864 else if (ada_type_name (fixed_record_type
) != NULL
)
8866 const char *name
= ada_type_name (fixed_record_type
);
8868 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8869 bool xvz_found
= false;
8872 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8875 xvz_found
= get_int_var_value (xvz_name
, size
);
8877 catch (const gdb_exception_error
&except
)
8879 /* We found the variable, but somehow failed to read
8880 its value. Rethrow the same error, but with a little
8881 bit more information, to help the user understand
8882 what went wrong (Eg: the variable might have been
8884 throw_error (except
.error
,
8885 _("unable to read value of %s (%s)"),
8886 xvz_name
, except
.what ());
8889 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8891 fixed_record_type
= copy_type (fixed_record_type
);
8892 TYPE_LENGTH (fixed_record_type
) = size
;
8894 /* The FIXED_RECORD_TYPE may have be a stub. We have
8895 observed this when the debugging info is STABS, and
8896 apparently it is something that is hard to fix.
8898 In practice, we don't need the actual type definition
8899 at all, because the presence of the XVZ variable allows us
8900 to assume that there must be a XVS type as well, which we
8901 should be able to use later, when we need the actual type
8904 In the meantime, pretend that the "fixed" type we are
8905 returning is NOT a stub, because this can cause trouble
8906 when using this type to create new types targeting it.
8907 Indeed, the associated creation routines often check
8908 whether the target type is a stub and will try to replace
8909 it, thus using a type with the wrong size. This, in turn,
8910 might cause the new type to have the wrong size too.
8911 Consider the case of an array, for instance, where the size
8912 of the array is computed from the number of elements in
8913 our array multiplied by the size of its element. */
8914 TYPE_STUB (fixed_record_type
) = 0;
8917 return fixed_record_type
;
8919 case TYPE_CODE_ARRAY
:
8920 return to_fixed_array_type (type
, dval
, 1);
8921 case TYPE_CODE_UNION
:
8925 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8929 /* The same as ada_to_fixed_type_1, except that it preserves the type
8930 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8932 The typedef layer needs be preserved in order to differentiate between
8933 arrays and array pointers when both types are implemented using the same
8934 fat pointer. In the array pointer case, the pointer is encoded as
8935 a typedef of the pointer type. For instance, considering:
8937 type String_Access is access String;
8938 S1 : String_Access := null;
8940 To the debugger, S1 is defined as a typedef of type String. But
8941 to the user, it is a pointer. So if the user tries to print S1,
8942 we should not dereference the array, but print the array address
8945 If we didn't preserve the typedef layer, we would lose the fact that
8946 the type is to be presented as a pointer (needs de-reference before
8947 being printed). And we would also use the source-level type name. */
8950 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8951 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8954 struct type
*fixed_type
=
8955 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8957 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8958 then preserve the typedef layer.
8960 Implementation note: We can only check the main-type portion of
8961 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8962 from TYPE now returns a type that has the same instance flags
8963 as TYPE. For instance, if TYPE is a "typedef const", and its
8964 target type is a "struct", then the typedef elimination will return
8965 a "const" version of the target type. See check_typedef for more
8966 details about how the typedef layer elimination is done.
8968 brobecker/2010-11-19: It seems to me that the only case where it is
8969 useful to preserve the typedef layer is when dealing with fat pointers.
8970 Perhaps, we could add a check for that and preserve the typedef layer
8971 only in that situation. But this seems unnecessary so far, probably
8972 because we call check_typedef/ada_check_typedef pretty much everywhere.
8974 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
8975 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8976 == TYPE_MAIN_TYPE (fixed_type
)))
8982 /* A standard (static-sized) type corresponding as well as possible to
8983 TYPE0, but based on no runtime data. */
8985 static struct type
*
8986 to_static_fixed_type (struct type
*type0
)
8993 if (TYPE_FIXED_INSTANCE (type0
))
8996 type0
= ada_check_typedef (type0
);
8998 switch (TYPE_CODE (type0
))
9002 case TYPE_CODE_STRUCT
:
9003 type
= dynamic_template_type (type0
);
9005 return template_to_static_fixed_type (type
);
9007 return template_to_static_fixed_type (type0
);
9008 case TYPE_CODE_UNION
:
9009 type
= ada_find_parallel_type (type0
, "___XVU");
9011 return template_to_static_fixed_type (type
);
9013 return template_to_static_fixed_type (type0
);
9017 /* A static approximation of TYPE with all type wrappers removed. */
9019 static struct type
*
9020 static_unwrap_type (struct type
*type
)
9022 if (ada_is_aligner_type (type
))
9024 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
9025 if (ada_type_name (type1
) == NULL
)
9026 TYPE_NAME (type1
) = ada_type_name (type
);
9028 return static_unwrap_type (type1
);
9032 struct type
*raw_real_type
= ada_get_base_type (type
);
9034 if (raw_real_type
== type
)
9037 return to_static_fixed_type (raw_real_type
);
9041 /* In some cases, incomplete and private types require
9042 cross-references that are not resolved as records (for example,
9044 type FooP is access Foo;
9046 type Foo is array ...;
9047 ). In these cases, since there is no mechanism for producing
9048 cross-references to such types, we instead substitute for FooP a
9049 stub enumeration type that is nowhere resolved, and whose tag is
9050 the name of the actual type. Call these types "non-record stubs". */
9052 /* A type equivalent to TYPE that is not a non-record stub, if one
9053 exists, otherwise TYPE. */
9056 ada_check_typedef (struct type
*type
)
9061 /* If our type is an access to an unconstrained array, which is encoded
9062 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
9063 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9064 what allows us to distinguish between fat pointers that represent
9065 array types, and fat pointers that represent array access types
9066 (in both cases, the compiler implements them as fat pointers). */
9067 if (ada_is_access_to_unconstrained_array (type
))
9070 type
= check_typedef (type
);
9071 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
9072 || !TYPE_STUB (type
)
9073 || TYPE_NAME (type
) == NULL
)
9077 const char *name
= TYPE_NAME (type
);
9078 struct type
*type1
= ada_find_any_type (name
);
9083 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9084 stubs pointing to arrays, as we don't create symbols for array
9085 types, only for the typedef-to-array types). If that's the case,
9086 strip the typedef layer. */
9087 if (TYPE_CODE (type1
) == TYPE_CODE_TYPEDEF
)
9088 type1
= ada_check_typedef (type1
);
9094 /* A value representing the data at VALADDR/ADDRESS as described by
9095 type TYPE0, but with a standard (static-sized) type that correctly
9096 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9097 type, then return VAL0 [this feature is simply to avoid redundant
9098 creation of struct values]. */
9100 static struct value
*
9101 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
9104 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
9106 if (type
== type0
&& val0
!= NULL
)
9109 if (VALUE_LVAL (val0
) != lval_memory
)
9111 /* Our value does not live in memory; it could be a convenience
9112 variable, for instance. Create a not_lval value using val0's
9114 return value_from_contents (type
, value_contents (val0
));
9117 return value_from_contents_and_address (type
, 0, address
);
9120 /* A value representing VAL, but with a standard (static-sized) type
9121 that correctly describes it. Does not necessarily create a new
9125 ada_to_fixed_value (struct value
*val
)
9127 val
= unwrap_value (val
);
9128 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
9135 /* Table mapping attribute numbers to names.
9136 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
9138 static const char *attribute_names
[] = {
9156 ada_attribute_name (enum exp_opcode n
)
9158 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
9159 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
9161 return attribute_names
[0];
9164 /* Evaluate the 'POS attribute applied to ARG. */
9167 pos_atr (struct value
*arg
)
9169 struct value
*val
= coerce_ref (arg
);
9170 struct type
*type
= value_type (val
);
9173 if (!discrete_type_p (type
))
9174 error (_("'POS only defined on discrete types"));
9176 if (!discrete_position (type
, value_as_long (val
), &result
))
9177 error (_("enumeration value is invalid: can't find 'POS"));
9182 static struct value
*
9183 value_pos_atr (struct type
*type
, struct value
*arg
)
9185 return value_from_longest (type
, pos_atr (arg
));
9188 /* Evaluate the TYPE'VAL attribute applied to ARG. */
9190 static struct value
*
9191 value_val_atr (struct type
*type
, struct value
*arg
)
9193 if (!discrete_type_p (type
))
9194 error (_("'VAL only defined on discrete types"));
9195 if (!integer_type_p (value_type (arg
)))
9196 error (_("'VAL requires integral argument"));
9198 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
9200 long pos
= value_as_long (arg
);
9202 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
9203 error (_("argument to 'VAL out of range"));
9204 return value_from_longest (type
, TYPE_FIELD_ENUMVAL (type
, pos
));
9207 return value_from_longest (type
, value_as_long (arg
));
9213 /* True if TYPE appears to be an Ada character type.
9214 [At the moment, this is true only for Character and Wide_Character;
9215 It is a heuristic test that could stand improvement]. */
9218 ada_is_character_type (struct type
*type
)
9222 /* If the type code says it's a character, then assume it really is,
9223 and don't check any further. */
9224 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
9227 /* Otherwise, assume it's a character type iff it is a discrete type
9228 with a known character type name. */
9229 name
= ada_type_name (type
);
9230 return (name
!= NULL
9231 && (TYPE_CODE (type
) == TYPE_CODE_INT
9232 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
9233 && (strcmp (name
, "character") == 0
9234 || strcmp (name
, "wide_character") == 0
9235 || strcmp (name
, "wide_wide_character") == 0
9236 || strcmp (name
, "unsigned char") == 0));
9239 /* True if TYPE appears to be an Ada string type. */
9242 ada_is_string_type (struct type
*type
)
9244 type
= ada_check_typedef (type
);
9246 && TYPE_CODE (type
) != TYPE_CODE_PTR
9247 && (ada_is_simple_array_type (type
)
9248 || ada_is_array_descriptor_type (type
))
9249 && ada_array_arity (type
) == 1)
9251 struct type
*elttype
= ada_array_element_type (type
, 1);
9253 return ada_is_character_type (elttype
);
9259 /* The compiler sometimes provides a parallel XVS type for a given
9260 PAD type. Normally, it is safe to follow the PAD type directly,
9261 but older versions of the compiler have a bug that causes the offset
9262 of its "F" field to be wrong. Following that field in that case
9263 would lead to incorrect results, but this can be worked around
9264 by ignoring the PAD type and using the associated XVS type instead.
9266 Set to True if the debugger should trust the contents of PAD types.
9267 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9268 static bool trust_pad_over_xvs
= true;
9270 /* True if TYPE is a struct type introduced by the compiler to force the
9271 alignment of a value. Such types have a single field with a
9272 distinctive name. */
9275 ada_is_aligner_type (struct type
*type
)
9277 type
= ada_check_typedef (type
);
9279 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9282 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
9283 && TYPE_NFIELDS (type
) == 1
9284 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9287 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9288 the parallel type. */
9291 ada_get_base_type (struct type
*raw_type
)
9293 struct type
*real_type_namer
;
9294 struct type
*raw_real_type
;
9296 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
9299 if (ada_is_aligner_type (raw_type
))
9300 /* The encoding specifies that we should always use the aligner type.
9301 So, even if this aligner type has an associated XVS type, we should
9304 According to the compiler gurus, an XVS type parallel to an aligner
9305 type may exist because of a stabs limitation. In stabs, aligner
9306 types are empty because the field has a variable-sized type, and
9307 thus cannot actually be used as an aligner type. As a result,
9308 we need the associated parallel XVS type to decode the type.
9309 Since the policy in the compiler is to not change the internal
9310 representation based on the debugging info format, we sometimes
9311 end up having a redundant XVS type parallel to the aligner type. */
9314 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9315 if (real_type_namer
== NULL
9316 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
9317 || TYPE_NFIELDS (real_type_namer
) != 1)
9320 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer
, 0)) != TYPE_CODE_REF
)
9322 /* This is an older encoding form where the base type needs to be
9323 looked up by name. We prefer the newer encoding because it is
9325 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9326 if (raw_real_type
== NULL
)
9329 return raw_real_type
;
9332 /* The field in our XVS type is a reference to the base type. */
9333 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer
, 0));
9336 /* The type of value designated by TYPE, with all aligners removed. */
9339 ada_aligned_type (struct type
*type
)
9341 if (ada_is_aligner_type (type
))
9342 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
9344 return ada_get_base_type (type
);
9348 /* The address of the aligned value in an object at address VALADDR
9349 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9352 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9354 if (ada_is_aligner_type (type
))
9355 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
9357 TYPE_FIELD_BITPOS (type
,
9358 0) / TARGET_CHAR_BIT
);
9365 /* The printed representation of an enumeration literal with encoded
9366 name NAME. The value is good to the next call of ada_enum_name. */
9368 ada_enum_name (const char *name
)
9370 static char *result
;
9371 static size_t result_len
= 0;
9374 /* First, unqualify the enumeration name:
9375 1. Search for the last '.' character. If we find one, then skip
9376 all the preceding characters, the unqualified name starts
9377 right after that dot.
9378 2. Otherwise, we may be debugging on a target where the compiler
9379 translates dots into "__". Search forward for double underscores,
9380 but stop searching when we hit an overloading suffix, which is
9381 of the form "__" followed by digits. */
9383 tmp
= strrchr (name
, '.');
9388 while ((tmp
= strstr (name
, "__")) != NULL
)
9390 if (isdigit (tmp
[2]))
9401 if (name
[1] == 'U' || name
[1] == 'W')
9403 if (sscanf (name
+ 2, "%x", &v
) != 1)
9406 else if (((name
[1] >= '0' && name
[1] <= '9')
9407 || (name
[1] >= 'a' && name
[1] <= 'z'))
9410 GROW_VECT (result
, result_len
, 4);
9411 xsnprintf (result
, result_len
, "'%c'", name
[1]);
9417 GROW_VECT (result
, result_len
, 16);
9418 if (isascii (v
) && isprint (v
))
9419 xsnprintf (result
, result_len
, "'%c'", v
);
9420 else if (name
[1] == 'U')
9421 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9423 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9429 tmp
= strstr (name
, "__");
9431 tmp
= strstr (name
, "$");
9434 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9435 strncpy (result
, name
, tmp
- name
);
9436 result
[tmp
- name
] = '\0';
9444 /* Evaluate the subexpression of EXP starting at *POS as for
9445 evaluate_type, updating *POS to point just past the evaluated
9448 static struct value
*
9449 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9451 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9454 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9457 static struct value
*
9458 unwrap_value (struct value
*val
)
9460 struct type
*type
= ada_check_typedef (value_type (val
));
9462 if (ada_is_aligner_type (type
))
9464 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9465 struct type
*val_type
= ada_check_typedef (value_type (v
));
9467 if (ada_type_name (val_type
) == NULL
)
9468 TYPE_NAME (val_type
) = ada_type_name (type
);
9470 return unwrap_value (v
);
9474 struct type
*raw_real_type
=
9475 ada_check_typedef (ada_get_base_type (type
));
9477 /* If there is no parallel XVS or XVE type, then the value is
9478 already unwrapped. Return it without further modification. */
9479 if ((type
== raw_real_type
)
9480 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9484 coerce_unspec_val_to_type
9485 (val
, ada_to_fixed_type (raw_real_type
, 0,
9486 value_address (val
),
9491 static struct value
*
9492 cast_from_fixed (struct type
*type
, struct value
*arg
)
9494 struct value
*scale
= ada_scaling_factor (value_type (arg
));
9495 arg
= value_cast (value_type (scale
), arg
);
9497 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9498 return value_cast (type
, arg
);
9501 static struct value
*
9502 cast_to_fixed (struct type
*type
, struct value
*arg
)
9504 if (type
== value_type (arg
))
9507 struct value
*scale
= ada_scaling_factor (type
);
9508 if (ada_is_fixed_point_type (value_type (arg
)))
9509 arg
= cast_from_fixed (value_type (scale
), arg
);
9511 arg
= value_cast (value_type (scale
), arg
);
9513 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9514 return value_cast (type
, arg
);
9517 /* Given two array types T1 and T2, return nonzero iff both arrays
9518 contain the same number of elements. */
9521 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9523 LONGEST lo1
, hi1
, lo2
, hi2
;
9525 /* Get the array bounds in order to verify that the size of
9526 the two arrays match. */
9527 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9528 || !get_array_bounds (t2
, &lo2
, &hi2
))
9529 error (_("unable to determine array bounds"));
9531 /* To make things easier for size comparison, normalize a bit
9532 the case of empty arrays by making sure that the difference
9533 between upper bound and lower bound is always -1. */
9539 return (hi1
- lo1
== hi2
- lo2
);
9542 /* Assuming that VAL is an array of integrals, and TYPE represents
9543 an array with the same number of elements, but with wider integral
9544 elements, return an array "casted" to TYPE. In practice, this
9545 means that the returned array is built by casting each element
9546 of the original array into TYPE's (wider) element type. */
9548 static struct value
*
9549 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9551 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9556 /* Verify that both val and type are arrays of scalars, and
9557 that the size of val's elements is smaller than the size
9558 of type's element. */
9559 gdb_assert (TYPE_CODE (type
) == TYPE_CODE_ARRAY
);
9560 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9561 gdb_assert (TYPE_CODE (value_type (val
)) == TYPE_CODE_ARRAY
);
9562 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9563 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9564 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9566 if (!get_array_bounds (type
, &lo
, &hi
))
9567 error (_("unable to determine array bounds"));
9569 res
= allocate_value (type
);
9571 /* Promote each array element. */
9572 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9574 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9576 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9577 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9583 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9584 return the converted value. */
9586 static struct value
*
9587 coerce_for_assign (struct type
*type
, struct value
*val
)
9589 struct type
*type2
= value_type (val
);
9594 type2
= ada_check_typedef (type2
);
9595 type
= ada_check_typedef (type
);
9597 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
9598 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9600 val
= ada_value_ind (val
);
9601 type2
= value_type (val
);
9604 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
9605 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9607 if (!ada_same_array_size_p (type
, type2
))
9608 error (_("cannot assign arrays of different length"));
9610 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9611 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9612 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9613 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9615 /* Allow implicit promotion of the array elements to
9617 return ada_promote_array_of_integrals (type
, val
);
9620 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9621 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9622 error (_("Incompatible types in assignment"));
9623 deprecated_set_value_type (val
, type
);
9628 static struct value
*
9629 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9632 struct type
*type1
, *type2
;
9635 arg1
= coerce_ref (arg1
);
9636 arg2
= coerce_ref (arg2
);
9637 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9638 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9640 if (TYPE_CODE (type1
) != TYPE_CODE_INT
9641 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
9642 return value_binop (arg1
, arg2
, op
);
9651 return value_binop (arg1
, arg2
, op
);
9654 v2
= value_as_long (arg2
);
9656 error (_("second operand of %s must not be zero."), op_string (op
));
9658 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
9659 return value_binop (arg1
, arg2
, op
);
9661 v1
= value_as_long (arg1
);
9666 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9667 v
+= v
> 0 ? -1 : 1;
9675 /* Should not reach this point. */
9679 val
= allocate_value (type1
);
9680 store_unsigned_integer (value_contents_raw (val
),
9681 TYPE_LENGTH (value_type (val
)),
9682 gdbarch_byte_order (get_type_arch (type1
)), v
);
9687 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9689 if (ada_is_direct_array_type (value_type (arg1
))
9690 || ada_is_direct_array_type (value_type (arg2
)))
9692 struct type
*arg1_type
, *arg2_type
;
9694 /* Automatically dereference any array reference before
9695 we attempt to perform the comparison. */
9696 arg1
= ada_coerce_ref (arg1
);
9697 arg2
= ada_coerce_ref (arg2
);
9699 arg1
= ada_coerce_to_simple_array (arg1
);
9700 arg2
= ada_coerce_to_simple_array (arg2
);
9702 arg1_type
= ada_check_typedef (value_type (arg1
));
9703 arg2_type
= ada_check_typedef (value_type (arg2
));
9705 if (TYPE_CODE (arg1_type
) != TYPE_CODE_ARRAY
9706 || TYPE_CODE (arg2_type
) != TYPE_CODE_ARRAY
)
9707 error (_("Attempt to compare array with non-array"));
9708 /* FIXME: The following works only for types whose
9709 representations use all bits (no padding or undefined bits)
9710 and do not have user-defined equality. */
9711 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9712 && memcmp (value_contents (arg1
), value_contents (arg2
),
9713 TYPE_LENGTH (arg1_type
)) == 0);
9715 return value_equal (arg1
, arg2
);
9718 /* Total number of component associations in the aggregate starting at
9719 index PC in EXP. Assumes that index PC is the start of an
9723 num_component_specs (struct expression
*exp
, int pc
)
9727 m
= exp
->elts
[pc
+ 1].longconst
;
9730 for (i
= 0; i
< m
; i
+= 1)
9732 switch (exp
->elts
[pc
].opcode
)
9738 n
+= exp
->elts
[pc
+ 1].longconst
;
9741 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9746 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9747 component of LHS (a simple array or a record), updating *POS past
9748 the expression, assuming that LHS is contained in CONTAINER. Does
9749 not modify the inferior's memory, nor does it modify LHS (unless
9750 LHS == CONTAINER). */
9753 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9754 struct expression
*exp
, int *pos
)
9756 struct value
*mark
= value_mark ();
9758 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9760 if (TYPE_CODE (lhs_type
) == TYPE_CODE_ARRAY
)
9762 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9763 struct value
*index_val
= value_from_longest (index_type
, index
);
9765 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9769 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9770 elt
= ada_to_fixed_value (elt
);
9773 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9774 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9776 value_assign_to_component (container
, elt
,
9777 ada_evaluate_subexp (NULL
, exp
, pos
,
9780 value_free_to_mark (mark
);
9783 /* Assuming that LHS represents an lvalue having a record or array
9784 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9785 of that aggregate's value to LHS, advancing *POS past the
9786 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9787 lvalue containing LHS (possibly LHS itself). Does not modify
9788 the inferior's memory, nor does it modify the contents of
9789 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9791 static struct value
*
9792 assign_aggregate (struct value
*container
,
9793 struct value
*lhs
, struct expression
*exp
,
9794 int *pos
, enum noside noside
)
9796 struct type
*lhs_type
;
9797 int n
= exp
->elts
[*pos
+1].longconst
;
9798 LONGEST low_index
, high_index
;
9801 int max_indices
, num_indices
;
9805 if (noside
!= EVAL_NORMAL
)
9807 for (i
= 0; i
< n
; i
+= 1)
9808 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9812 container
= ada_coerce_ref (container
);
9813 if (ada_is_direct_array_type (value_type (container
)))
9814 container
= ada_coerce_to_simple_array (container
);
9815 lhs
= ada_coerce_ref (lhs
);
9816 if (!deprecated_value_modifiable (lhs
))
9817 error (_("Left operand of assignment is not a modifiable lvalue."));
9819 lhs_type
= check_typedef (value_type (lhs
));
9820 if (ada_is_direct_array_type (lhs_type
))
9822 lhs
= ada_coerce_to_simple_array (lhs
);
9823 lhs_type
= check_typedef (value_type (lhs
));
9824 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
9825 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
9827 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
9830 high_index
= num_visible_fields (lhs_type
) - 1;
9833 error (_("Left-hand side must be array or record."));
9835 num_specs
= num_component_specs (exp
, *pos
- 3);
9836 max_indices
= 4 * num_specs
+ 4;
9837 indices
= XALLOCAVEC (LONGEST
, max_indices
);
9838 indices
[0] = indices
[1] = low_index
- 1;
9839 indices
[2] = indices
[3] = high_index
+ 1;
9842 for (i
= 0; i
< n
; i
+= 1)
9844 switch (exp
->elts
[*pos
].opcode
)
9847 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9848 &num_indices
, max_indices
,
9849 low_index
, high_index
);
9852 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9853 &num_indices
, max_indices
,
9854 low_index
, high_index
);
9858 error (_("Misplaced 'others' clause"));
9859 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9860 num_indices
, low_index
, high_index
);
9863 error (_("Internal error: bad aggregate clause"));
9870 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9871 construct at *POS, updating *POS past the construct, given that
9872 the positions are relative to lower bound LOW, where HIGH is the
9873 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9874 updating *NUM_INDICES as needed. CONTAINER is as for
9875 assign_aggregate. */
9877 aggregate_assign_positional (struct value
*container
,
9878 struct value
*lhs
, struct expression
*exp
,
9879 int *pos
, LONGEST
*indices
, int *num_indices
,
9880 int max_indices
, LONGEST low
, LONGEST high
)
9882 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9884 if (ind
- 1 == high
)
9885 warning (_("Extra components in aggregate ignored."));
9888 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
9890 assign_component (container
, lhs
, ind
, exp
, pos
);
9893 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9896 /* Assign into the components of LHS indexed by the OP_CHOICES
9897 construct at *POS, updating *POS past the construct, given that
9898 the allowable indices are LOW..HIGH. Record the indices assigned
9899 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9900 needed. CONTAINER is as for assign_aggregate. */
9902 aggregate_assign_from_choices (struct value
*container
,
9903 struct value
*lhs
, struct expression
*exp
,
9904 int *pos
, LONGEST
*indices
, int *num_indices
,
9905 int max_indices
, LONGEST low
, LONGEST high
)
9908 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9909 int choice_pos
, expr_pc
;
9910 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9912 choice_pos
= *pos
+= 3;
9914 for (j
= 0; j
< n_choices
; j
+= 1)
9915 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9917 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9919 for (j
= 0; j
< n_choices
; j
+= 1)
9921 LONGEST lower
, upper
;
9922 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9924 if (op
== OP_DISCRETE_RANGE
)
9927 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9929 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9934 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9946 name
= &exp
->elts
[choice_pos
+ 2].string
;
9949 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
9952 error (_("Invalid record component association."));
9954 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9956 if (! find_struct_field (name
, value_type (lhs
), 0,
9957 NULL
, NULL
, NULL
, NULL
, &ind
))
9958 error (_("Unknown component name: %s."), name
);
9959 lower
= upper
= ind
;
9962 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9963 error (_("Index in component association out of bounds."));
9965 add_component_interval (lower
, upper
, indices
, num_indices
,
9967 while (lower
<= upper
)
9972 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9978 /* Assign the value of the expression in the OP_OTHERS construct in
9979 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9980 have not been previously assigned. The index intervals already assigned
9981 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9982 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9984 aggregate_assign_others (struct value
*container
,
9985 struct value
*lhs
, struct expression
*exp
,
9986 int *pos
, LONGEST
*indices
, int num_indices
,
9987 LONGEST low
, LONGEST high
)
9990 int expr_pc
= *pos
+ 1;
9992 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9996 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
10000 localpos
= expr_pc
;
10001 assign_component (container
, lhs
, ind
, exp
, &localpos
);
10004 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
10007 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
10008 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10009 modifying *SIZE as needed. It is an error if *SIZE exceeds
10010 MAX_SIZE. The resulting intervals do not overlap. */
10012 add_component_interval (LONGEST low
, LONGEST high
,
10013 LONGEST
* indices
, int *size
, int max_size
)
10017 for (i
= 0; i
< *size
; i
+= 2) {
10018 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
10022 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
10023 if (high
< indices
[kh
])
10025 if (low
< indices
[i
])
10027 indices
[i
+ 1] = indices
[kh
- 1];
10028 if (high
> indices
[i
+ 1])
10029 indices
[i
+ 1] = high
;
10030 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
10031 *size
-= kh
- i
- 2;
10034 else if (high
< indices
[i
])
10038 if (*size
== max_size
)
10039 error (_("Internal error: miscounted aggregate components."));
10041 for (j
= *size
-1; j
>= i
+2; j
-= 1)
10042 indices
[j
] = indices
[j
- 2];
10044 indices
[i
+ 1] = high
;
10047 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10050 static struct value
*
10051 ada_value_cast (struct type
*type
, struct value
*arg2
)
10053 if (type
== ada_check_typedef (value_type (arg2
)))
10056 if (ada_is_fixed_point_type (type
))
10057 return cast_to_fixed (type
, arg2
);
10059 if (ada_is_fixed_point_type (value_type (arg2
)))
10060 return cast_from_fixed (type
, arg2
);
10062 return value_cast (type
, arg2
);
10065 /* Evaluating Ada expressions, and printing their result.
10066 ------------------------------------------------------
10071 We usually evaluate an Ada expression in order to print its value.
10072 We also evaluate an expression in order to print its type, which
10073 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10074 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10075 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10076 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10079 Evaluating expressions is a little more complicated for Ada entities
10080 than it is for entities in languages such as C. The main reason for
10081 this is that Ada provides types whose definition might be dynamic.
10082 One example of such types is variant records. Or another example
10083 would be an array whose bounds can only be known at run time.
10085 The following description is a general guide as to what should be
10086 done (and what should NOT be done) in order to evaluate an expression
10087 involving such types, and when. This does not cover how the semantic
10088 information is encoded by GNAT as this is covered separatly. For the
10089 document used as the reference for the GNAT encoding, see exp_dbug.ads
10090 in the GNAT sources.
10092 Ideally, we should embed each part of this description next to its
10093 associated code. Unfortunately, the amount of code is so vast right
10094 now that it's hard to see whether the code handling a particular
10095 situation might be duplicated or not. One day, when the code is
10096 cleaned up, this guide might become redundant with the comments
10097 inserted in the code, and we might want to remove it.
10099 2. ``Fixing'' an Entity, the Simple Case:
10100 -----------------------------------------
10102 When evaluating Ada expressions, the tricky issue is that they may
10103 reference entities whose type contents and size are not statically
10104 known. Consider for instance a variant record:
10106 type Rec (Empty : Boolean := True) is record
10109 when False => Value : Integer;
10112 Yes : Rec := (Empty => False, Value => 1);
10113 No : Rec := (empty => True);
10115 The size and contents of that record depends on the value of the
10116 descriminant (Rec.Empty). At this point, neither the debugging
10117 information nor the associated type structure in GDB are able to
10118 express such dynamic types. So what the debugger does is to create
10119 "fixed" versions of the type that applies to the specific object.
10120 We also informally refer to this opperation as "fixing" an object,
10121 which means creating its associated fixed type.
10123 Example: when printing the value of variable "Yes" above, its fixed
10124 type would look like this:
10131 On the other hand, if we printed the value of "No", its fixed type
10138 Things become a little more complicated when trying to fix an entity
10139 with a dynamic type that directly contains another dynamic type,
10140 such as an array of variant records, for instance. There are
10141 two possible cases: Arrays, and records.
10143 3. ``Fixing'' Arrays:
10144 ---------------------
10146 The type structure in GDB describes an array in terms of its bounds,
10147 and the type of its elements. By design, all elements in the array
10148 have the same type and we cannot represent an array of variant elements
10149 using the current type structure in GDB. When fixing an array,
10150 we cannot fix the array element, as we would potentially need one
10151 fixed type per element of the array. As a result, the best we can do
10152 when fixing an array is to produce an array whose bounds and size
10153 are correct (allowing us to read it from memory), but without having
10154 touched its element type. Fixing each element will be done later,
10155 when (if) necessary.
10157 Arrays are a little simpler to handle than records, because the same
10158 amount of memory is allocated for each element of the array, even if
10159 the amount of space actually used by each element differs from element
10160 to element. Consider for instance the following array of type Rec:
10162 type Rec_Array is array (1 .. 2) of Rec;
10164 The actual amount of memory occupied by each element might be different
10165 from element to element, depending on the value of their discriminant.
10166 But the amount of space reserved for each element in the array remains
10167 fixed regardless. So we simply need to compute that size using
10168 the debugging information available, from which we can then determine
10169 the array size (we multiply the number of elements of the array by
10170 the size of each element).
10172 The simplest case is when we have an array of a constrained element
10173 type. For instance, consider the following type declarations:
10175 type Bounded_String (Max_Size : Integer) is
10177 Buffer : String (1 .. Max_Size);
10179 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10181 In this case, the compiler describes the array as an array of
10182 variable-size elements (identified by its XVS suffix) for which
10183 the size can be read in the parallel XVZ variable.
10185 In the case of an array of an unconstrained element type, the compiler
10186 wraps the array element inside a private PAD type. This type should not
10187 be shown to the user, and must be "unwrap"'ed before printing. Note
10188 that we also use the adjective "aligner" in our code to designate
10189 these wrapper types.
10191 In some cases, the size allocated for each element is statically
10192 known. In that case, the PAD type already has the correct size,
10193 and the array element should remain unfixed.
10195 But there are cases when this size is not statically known.
10196 For instance, assuming that "Five" is an integer variable:
10198 type Dynamic is array (1 .. Five) of Integer;
10199 type Wrapper (Has_Length : Boolean := False) is record
10202 when True => Length : Integer;
10203 when False => null;
10206 type Wrapper_Array is array (1 .. 2) of Wrapper;
10208 Hello : Wrapper_Array := (others => (Has_Length => True,
10209 Data => (others => 17),
10213 The debugging info would describe variable Hello as being an
10214 array of a PAD type. The size of that PAD type is not statically
10215 known, but can be determined using a parallel XVZ variable.
10216 In that case, a copy of the PAD type with the correct size should
10217 be used for the fixed array.
10219 3. ``Fixing'' record type objects:
10220 ----------------------------------
10222 Things are slightly different from arrays in the case of dynamic
10223 record types. In this case, in order to compute the associated
10224 fixed type, we need to determine the size and offset of each of
10225 its components. This, in turn, requires us to compute the fixed
10226 type of each of these components.
10228 Consider for instance the example:
10230 type Bounded_String (Max_Size : Natural) is record
10231 Str : String (1 .. Max_Size);
10234 My_String : Bounded_String (Max_Size => 10);
10236 In that case, the position of field "Length" depends on the size
10237 of field Str, which itself depends on the value of the Max_Size
10238 discriminant. In order to fix the type of variable My_String,
10239 we need to fix the type of field Str. Therefore, fixing a variant
10240 record requires us to fix each of its components.
10242 However, if a component does not have a dynamic size, the component
10243 should not be fixed. In particular, fields that use a PAD type
10244 should not fixed. Here is an example where this might happen
10245 (assuming type Rec above):
10247 type Container (Big : Boolean) is record
10251 when True => Another : Integer;
10252 when False => null;
10255 My_Container : Container := (Big => False,
10256 First => (Empty => True),
10259 In that example, the compiler creates a PAD type for component First,
10260 whose size is constant, and then positions the component After just
10261 right after it. The offset of component After is therefore constant
10264 The debugger computes the position of each field based on an algorithm
10265 that uses, among other things, the actual position and size of the field
10266 preceding it. Let's now imagine that the user is trying to print
10267 the value of My_Container. If the type fixing was recursive, we would
10268 end up computing the offset of field After based on the size of the
10269 fixed version of field First. And since in our example First has
10270 only one actual field, the size of the fixed type is actually smaller
10271 than the amount of space allocated to that field, and thus we would
10272 compute the wrong offset of field After.
10274 To make things more complicated, we need to watch out for dynamic
10275 components of variant records (identified by the ___XVL suffix in
10276 the component name). Even if the target type is a PAD type, the size
10277 of that type might not be statically known. So the PAD type needs
10278 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10279 we might end up with the wrong size for our component. This can be
10280 observed with the following type declarations:
10282 type Octal is new Integer range 0 .. 7;
10283 type Octal_Array is array (Positive range <>) of Octal;
10284 pragma Pack (Octal_Array);
10286 type Octal_Buffer (Size : Positive) is record
10287 Buffer : Octal_Array (1 .. Size);
10291 In that case, Buffer is a PAD type whose size is unset and needs
10292 to be computed by fixing the unwrapped type.
10294 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10295 ----------------------------------------------------------
10297 Lastly, when should the sub-elements of an entity that remained unfixed
10298 thus far, be actually fixed?
10300 The answer is: Only when referencing that element. For instance
10301 when selecting one component of a record, this specific component
10302 should be fixed at that point in time. Or when printing the value
10303 of a record, each component should be fixed before its value gets
10304 printed. Similarly for arrays, the element of the array should be
10305 fixed when printing each element of the array, or when extracting
10306 one element out of that array. On the other hand, fixing should
10307 not be performed on the elements when taking a slice of an array!
10309 Note that one of the side effects of miscomputing the offset and
10310 size of each field is that we end up also miscomputing the size
10311 of the containing type. This can have adverse results when computing
10312 the value of an entity. GDB fetches the value of an entity based
10313 on the size of its type, and thus a wrong size causes GDB to fetch
10314 the wrong amount of memory. In the case where the computed size is
10315 too small, GDB fetches too little data to print the value of our
10316 entity. Results in this case are unpredictable, as we usually read
10317 past the buffer containing the data =:-o. */
10319 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10320 for that subexpression cast to TO_TYPE. Advance *POS over the
10324 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
10325 enum noside noside
, struct type
*to_type
)
10329 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
10330 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
10335 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
10337 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10338 return value_zero (to_type
, not_lval
);
10340 val
= evaluate_var_msym_value (noside
,
10341 exp
->elts
[pc
+ 1].objfile
,
10342 exp
->elts
[pc
+ 2].msymbol
);
10345 val
= evaluate_var_value (noside
,
10346 exp
->elts
[pc
+ 1].block
,
10347 exp
->elts
[pc
+ 2].symbol
);
10349 if (noside
== EVAL_SKIP
)
10350 return eval_skip_value (exp
);
10352 val
= ada_value_cast (to_type
, val
);
10354 /* Follow the Ada language semantics that do not allow taking
10355 an address of the result of a cast (view conversion in Ada). */
10356 if (VALUE_LVAL (val
) == lval_memory
)
10358 if (value_lazy (val
))
10359 value_fetch_lazy (val
);
10360 VALUE_LVAL (val
) = not_lval
;
10365 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
10366 if (noside
== EVAL_SKIP
)
10367 return eval_skip_value (exp
);
10368 return ada_value_cast (to_type
, val
);
10371 /* Implement the evaluate_exp routine in the exp_descriptor structure
10372 for the Ada language. */
10374 static struct value
*
10375 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10376 int *pos
, enum noside noside
)
10378 enum exp_opcode op
;
10382 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10385 struct value
**argvec
;
10389 op
= exp
->elts
[pc
].opcode
;
10395 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10397 if (noside
== EVAL_NORMAL
)
10398 arg1
= unwrap_value (arg1
);
10400 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10401 then we need to perform the conversion manually, because
10402 evaluate_subexp_standard doesn't do it. This conversion is
10403 necessary in Ada because the different kinds of float/fixed
10404 types in Ada have different representations.
10406 Similarly, we need to perform the conversion from OP_LONG
10408 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10409 arg1
= ada_value_cast (expect_type
, arg1
);
10415 struct value
*result
;
10418 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10419 /* The result type will have code OP_STRING, bashed there from
10420 OP_ARRAY. Bash it back. */
10421 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
10422 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
10428 type
= exp
->elts
[pc
+ 1].type
;
10429 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10433 type
= exp
->elts
[pc
+ 1].type
;
10434 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10437 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10438 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10440 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10441 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10443 return ada_value_assign (arg1
, arg1
);
10445 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10446 except if the lhs of our assignment is a convenience variable.
10447 In the case of assigning to a convenience variable, the lhs
10448 should be exactly the result of the evaluation of the rhs. */
10449 type
= value_type (arg1
);
10450 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10452 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10453 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10455 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10459 else if (ada_is_fixed_point_type (value_type (arg1
)))
10460 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
10461 else if (ada_is_fixed_point_type (value_type (arg2
)))
10463 (_("Fixed-point values must be assigned to fixed-point variables"));
10465 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10466 return ada_value_assign (arg1
, arg2
);
10469 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10470 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10471 if (noside
== EVAL_SKIP
)
10473 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
10474 return (value_from_longest
10475 (value_type (arg1
),
10476 value_as_long (arg1
) + value_as_long (arg2
)));
10477 if (TYPE_CODE (value_type (arg2
)) == TYPE_CODE_PTR
)
10478 return (value_from_longest
10479 (value_type (arg2
),
10480 value_as_long (arg1
) + value_as_long (arg2
)));
10481 if ((ada_is_fixed_point_type (value_type (arg1
))
10482 || ada_is_fixed_point_type (value_type (arg2
)))
10483 && value_type (arg1
) != value_type (arg2
))
10484 error (_("Operands of fixed-point addition must have the same type"));
10485 /* Do the addition, and cast the result to the type of the first
10486 argument. We cannot cast the result to a reference type, so if
10487 ARG1 is a reference type, find its underlying type. */
10488 type
= value_type (arg1
);
10489 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
10490 type
= TYPE_TARGET_TYPE (type
);
10491 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10492 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10495 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10496 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10497 if (noside
== EVAL_SKIP
)
10499 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
10500 return (value_from_longest
10501 (value_type (arg1
),
10502 value_as_long (arg1
) - value_as_long (arg2
)));
10503 if (TYPE_CODE (value_type (arg2
)) == TYPE_CODE_PTR
)
10504 return (value_from_longest
10505 (value_type (arg2
),
10506 value_as_long (arg1
) - value_as_long (arg2
)));
10507 if ((ada_is_fixed_point_type (value_type (arg1
))
10508 || ada_is_fixed_point_type (value_type (arg2
)))
10509 && value_type (arg1
) != value_type (arg2
))
10510 error (_("Operands of fixed-point subtraction "
10511 "must have the same type"));
10512 /* Do the substraction, and cast the result to the type of the first
10513 argument. We cannot cast the result to a reference type, so if
10514 ARG1 is a reference type, find its underlying type. */
10515 type
= value_type (arg1
);
10516 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
10517 type
= TYPE_TARGET_TYPE (type
);
10518 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10519 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10525 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10526 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10527 if (noside
== EVAL_SKIP
)
10529 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10531 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10532 return value_zero (value_type (arg1
), not_lval
);
10536 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10537 if (ada_is_fixed_point_type (value_type (arg1
)))
10538 arg1
= cast_from_fixed (type
, arg1
);
10539 if (ada_is_fixed_point_type (value_type (arg2
)))
10540 arg2
= cast_from_fixed (type
, arg2
);
10541 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10542 return ada_value_binop (arg1
, arg2
, op
);
10546 case BINOP_NOTEQUAL
:
10547 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10548 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10549 if (noside
== EVAL_SKIP
)
10551 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10555 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10556 tem
= ada_value_equal (arg1
, arg2
);
10558 if (op
== BINOP_NOTEQUAL
)
10560 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10561 return value_from_longest (type
, (LONGEST
) tem
);
10564 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10565 if (noside
== EVAL_SKIP
)
10567 else if (ada_is_fixed_point_type (value_type (arg1
)))
10568 return value_cast (value_type (arg1
), value_neg (arg1
));
10571 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10572 return value_neg (arg1
);
10575 case BINOP_LOGICAL_AND
:
10576 case BINOP_LOGICAL_OR
:
10577 case UNOP_LOGICAL_NOT
:
10582 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10583 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10584 return value_cast (type
, val
);
10587 case BINOP_BITWISE_AND
:
10588 case BINOP_BITWISE_IOR
:
10589 case BINOP_BITWISE_XOR
:
10593 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10595 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10597 return value_cast (value_type (arg1
), val
);
10603 if (noside
== EVAL_SKIP
)
10609 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10610 /* Only encountered when an unresolved symbol occurs in a
10611 context other than a function call, in which case, it is
10613 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10614 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
10616 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10618 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10619 /* Check to see if this is a tagged type. We also need to handle
10620 the case where the type is a reference to a tagged type, but
10621 we have to be careful to exclude pointers to tagged types.
10622 The latter should be shown as usual (as a pointer), whereas
10623 a reference should mostly be transparent to the user. */
10624 if (ada_is_tagged_type (type
, 0)
10625 || (TYPE_CODE (type
) == TYPE_CODE_REF
10626 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10628 /* Tagged types are a little special in the fact that the real
10629 type is dynamic and can only be determined by inspecting the
10630 object's tag. This means that we need to get the object's
10631 value first (EVAL_NORMAL) and then extract the actual object
10634 Note that we cannot skip the final step where we extract
10635 the object type from its tag, because the EVAL_NORMAL phase
10636 results in dynamic components being resolved into fixed ones.
10637 This can cause problems when trying to print the type
10638 description of tagged types whose parent has a dynamic size:
10639 We use the type name of the "_parent" component in order
10640 to print the name of the ancestor type in the type description.
10641 If that component had a dynamic size, the resolution into
10642 a fixed type would result in the loss of that type name,
10643 thus preventing us from printing the name of the ancestor
10644 type in the type description. */
10645 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
10647 if (TYPE_CODE (type
) != TYPE_CODE_REF
)
10649 struct type
*actual_type
;
10651 actual_type
= type_from_tag (ada_value_tag (arg1
));
10652 if (actual_type
== NULL
)
10653 /* If, for some reason, we were unable to determine
10654 the actual type from the tag, then use the static
10655 approximation that we just computed as a fallback.
10656 This can happen if the debugging information is
10657 incomplete, for instance. */
10658 actual_type
= type
;
10659 return value_zero (actual_type
, not_lval
);
10663 /* In the case of a ref, ada_coerce_ref takes care
10664 of determining the actual type. But the evaluation
10665 should return a ref as it should be valid to ask
10666 for its address; so rebuild a ref after coerce. */
10667 arg1
= ada_coerce_ref (arg1
);
10668 return value_ref (arg1
, TYPE_CODE_REF
);
10672 /* Records and unions for which GNAT encodings have been
10673 generated need to be statically fixed as well.
10674 Otherwise, non-static fixing produces a type where
10675 all dynamic properties are removed, which prevents "ptype"
10676 from being able to completely describe the type.
10677 For instance, a case statement in a variant record would be
10678 replaced by the relevant components based on the actual
10679 value of the discriminants. */
10680 if ((TYPE_CODE (type
) == TYPE_CODE_STRUCT
10681 && dynamic_template_type (type
) != NULL
)
10682 || (TYPE_CODE (type
) == TYPE_CODE_UNION
10683 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10686 return value_zero (to_static_fixed_type (type
), not_lval
);
10690 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10691 return ada_to_fixed_value (arg1
);
10696 /* Allocate arg vector, including space for the function to be
10697 called in argvec[0] and a terminating NULL. */
10698 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10699 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10701 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10702 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10703 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10704 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
10707 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10708 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10711 if (noside
== EVAL_SKIP
)
10715 if (ada_is_constrained_packed_array_type
10716 (desc_base_type (value_type (argvec
[0]))))
10717 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10718 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
10719 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10720 /* This is a packed array that has already been fixed, and
10721 therefore already coerced to a simple array. Nothing further
10724 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
)
10726 /* Make sure we dereference references so that all the code below
10727 feels like it's really handling the referenced value. Wrapping
10728 types (for alignment) may be there, so make sure we strip them as
10730 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10732 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
10733 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10734 argvec
[0] = value_addr (argvec
[0]);
10736 type
= ada_check_typedef (value_type (argvec
[0]));
10738 /* Ada allows us to implicitly dereference arrays when subscripting
10739 them. So, if this is an array typedef (encoding use for array
10740 access types encoded as fat pointers), strip it now. */
10741 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
10742 type
= ada_typedef_target_type (type
);
10744 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
10746 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
10748 case TYPE_CODE_FUNC
:
10749 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10751 case TYPE_CODE_ARRAY
:
10753 case TYPE_CODE_STRUCT
:
10754 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10755 argvec
[0] = ada_value_ind (argvec
[0]);
10756 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10759 error (_("cannot subscript or call something of type `%s'"),
10760 ada_type_name (value_type (argvec
[0])));
10765 switch (TYPE_CODE (type
))
10767 case TYPE_CODE_FUNC
:
10768 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10770 if (TYPE_TARGET_TYPE (type
) == NULL
)
10771 error_call_unknown_return_type (NULL
);
10772 return allocate_value (TYPE_TARGET_TYPE (type
));
10774 return call_function_by_hand (argvec
[0], NULL
,
10775 gdb::make_array_view (argvec
+ 1,
10777 case TYPE_CODE_INTERNAL_FUNCTION
:
10778 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10779 /* We don't know anything about what the internal
10780 function might return, but we have to return
10782 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10785 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10786 argvec
[0], nargs
, argvec
+ 1);
10788 case TYPE_CODE_STRUCT
:
10792 arity
= ada_array_arity (type
);
10793 type
= ada_array_element_type (type
, nargs
);
10795 error (_("cannot subscript or call a record"));
10796 if (arity
!= nargs
)
10797 error (_("wrong number of subscripts; expecting %d"), arity
);
10798 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10799 return value_zero (ada_aligned_type (type
), lval_memory
);
10801 unwrap_value (ada_value_subscript
10802 (argvec
[0], nargs
, argvec
+ 1));
10804 case TYPE_CODE_ARRAY
:
10805 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10807 type
= ada_array_element_type (type
, nargs
);
10809 error (_("element type of array unknown"));
10811 return value_zero (ada_aligned_type (type
), lval_memory
);
10814 unwrap_value (ada_value_subscript
10815 (ada_coerce_to_simple_array (argvec
[0]),
10816 nargs
, argvec
+ 1));
10817 case TYPE_CODE_PTR
: /* Pointer to array */
10818 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10820 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10821 type
= ada_array_element_type (type
, nargs
);
10823 error (_("element type of array unknown"));
10825 return value_zero (ada_aligned_type (type
), lval_memory
);
10828 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10829 nargs
, argvec
+ 1));
10832 error (_("Attempt to index or call something other than an "
10833 "array or function"));
10838 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10839 struct value
*low_bound_val
=
10840 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10841 struct value
*high_bound_val
=
10842 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10844 LONGEST high_bound
;
10846 low_bound_val
= coerce_ref (low_bound_val
);
10847 high_bound_val
= coerce_ref (high_bound_val
);
10848 low_bound
= value_as_long (low_bound_val
);
10849 high_bound
= value_as_long (high_bound_val
);
10851 if (noside
== EVAL_SKIP
)
10854 /* If this is a reference to an aligner type, then remove all
10856 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
10857 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10858 TYPE_TARGET_TYPE (value_type (array
)) =
10859 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10861 if (ada_is_constrained_packed_array_type (value_type (array
)))
10862 error (_("cannot slice a packed array"));
10864 /* If this is a reference to an array or an array lvalue,
10865 convert to a pointer. */
10866 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
10867 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
10868 && VALUE_LVAL (array
) == lval_memory
))
10869 array
= value_addr (array
);
10871 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10872 && ada_is_array_descriptor_type (ada_check_typedef
10873 (value_type (array
))))
10874 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10877 array
= ada_coerce_to_simple_array_ptr (array
);
10879 /* If we have more than one level of pointer indirection,
10880 dereference the value until we get only one level. */
10881 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
10882 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
10884 array
= value_ind (array
);
10886 /* Make sure we really do have an array type before going further,
10887 to avoid a SEGV when trying to get the index type or the target
10888 type later down the road if the debug info generated by
10889 the compiler is incorrect or incomplete. */
10890 if (!ada_is_simple_array_type (value_type (array
)))
10891 error (_("cannot take slice of non-array"));
10893 if (TYPE_CODE (ada_check_typedef (value_type (array
)))
10896 struct type
*type0
= ada_check_typedef (value_type (array
));
10898 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10899 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10902 struct type
*arr_type0
=
10903 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10905 return ada_value_slice_from_ptr (array
, arr_type0
,
10906 longest_to_int (low_bound
),
10907 longest_to_int (high_bound
));
10910 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10912 else if (high_bound
< low_bound
)
10913 return empty_array (value_type (array
), low_bound
, high_bound
);
10915 return ada_value_slice (array
, longest_to_int (low_bound
),
10916 longest_to_int (high_bound
));
10919 case UNOP_IN_RANGE
:
10921 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10922 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10924 if (noside
== EVAL_SKIP
)
10927 switch (TYPE_CODE (type
))
10930 lim_warning (_("Membership test incompletely implemented; "
10931 "always returns true"));
10932 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10933 return value_from_longest (type
, (LONGEST
) 1);
10935 case TYPE_CODE_RANGE
:
10936 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
10937 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
10938 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10939 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10940 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10942 value_from_longest (type
,
10943 (value_less (arg1
, arg3
)
10944 || value_equal (arg1
, arg3
))
10945 && (value_less (arg2
, arg1
)
10946 || value_equal (arg2
, arg1
)));
10949 case BINOP_IN_BOUNDS
:
10951 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10952 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10954 if (noside
== EVAL_SKIP
)
10957 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10959 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10960 return value_zero (type
, not_lval
);
10963 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10965 type
= ada_index_type (value_type (arg2
), tem
, "range");
10967 type
= value_type (arg1
);
10969 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10970 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10972 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10973 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10974 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10976 value_from_longest (type
,
10977 (value_less (arg1
, arg3
)
10978 || value_equal (arg1
, arg3
))
10979 && (value_less (arg2
, arg1
)
10980 || value_equal (arg2
, arg1
)));
10982 case TERNOP_IN_RANGE
:
10983 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10984 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10985 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10987 if (noside
== EVAL_SKIP
)
10990 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10991 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10992 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10994 value_from_longest (type
,
10995 (value_less (arg1
, arg3
)
10996 || value_equal (arg1
, arg3
))
10997 && (value_less (arg2
, arg1
)
10998 || value_equal (arg2
, arg1
)));
11002 case OP_ATR_LENGTH
:
11004 struct type
*type_arg
;
11006 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
11008 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11010 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
11014 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11018 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
11019 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
11020 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
11023 if (noside
== EVAL_SKIP
)
11025 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11027 if (type_arg
== NULL
)
11028 type_arg
= value_type (arg1
);
11030 if (ada_is_constrained_packed_array_type (type_arg
))
11031 type_arg
= decode_constrained_packed_array_type (type_arg
);
11033 if (!discrete_type_p (type_arg
))
11037 default: /* Should never happen. */
11038 error (_("unexpected attribute encountered"));
11041 type_arg
= ada_index_type (type_arg
, tem
,
11042 ada_attribute_name (op
));
11044 case OP_ATR_LENGTH
:
11045 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
11050 return value_zero (type_arg
, not_lval
);
11052 else if (type_arg
== NULL
)
11054 arg1
= ada_coerce_ref (arg1
);
11056 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
11057 arg1
= ada_coerce_to_simple_array (arg1
);
11059 if (op
== OP_ATR_LENGTH
)
11060 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11063 type
= ada_index_type (value_type (arg1
), tem
,
11064 ada_attribute_name (op
));
11066 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11071 default: /* Should never happen. */
11072 error (_("unexpected attribute encountered"));
11074 return value_from_longest
11075 (type
, ada_array_bound (arg1
, tem
, 0));
11077 return value_from_longest
11078 (type
, ada_array_bound (arg1
, tem
, 1));
11079 case OP_ATR_LENGTH
:
11080 return value_from_longest
11081 (type
, ada_array_length (arg1
, tem
));
11084 else if (discrete_type_p (type_arg
))
11086 struct type
*range_type
;
11087 const char *name
= ada_type_name (type_arg
);
11090 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
11091 range_type
= to_fixed_range_type (type_arg
, NULL
);
11092 if (range_type
== NULL
)
11093 range_type
= type_arg
;
11097 error (_("unexpected attribute encountered"));
11099 return value_from_longest
11100 (range_type
, ada_discrete_type_low_bound (range_type
));
11102 return value_from_longest
11103 (range_type
, ada_discrete_type_high_bound (range_type
));
11104 case OP_ATR_LENGTH
:
11105 error (_("the 'length attribute applies only to array types"));
11108 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
11109 error (_("unimplemented type attribute"));
11114 if (ada_is_constrained_packed_array_type (type_arg
))
11115 type_arg
= decode_constrained_packed_array_type (type_arg
);
11117 if (op
== OP_ATR_LENGTH
)
11118 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11121 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
11123 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11129 error (_("unexpected attribute encountered"));
11131 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
11132 return value_from_longest (type
, low
);
11134 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
11135 return value_from_longest (type
, high
);
11136 case OP_ATR_LENGTH
:
11137 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
11138 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
11139 return value_from_longest (type
, high
- low
+ 1);
11145 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11146 if (noside
== EVAL_SKIP
)
11149 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11150 return value_zero (ada_tag_type (arg1
), not_lval
);
11152 return ada_value_tag (arg1
);
11156 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11157 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11158 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11159 if (noside
== EVAL_SKIP
)
11161 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11162 return value_zero (value_type (arg1
), not_lval
);
11165 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11166 return value_binop (arg1
, arg2
,
11167 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
11170 case OP_ATR_MODULUS
:
11172 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
11174 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11175 if (noside
== EVAL_SKIP
)
11178 if (!ada_is_modular_type (type_arg
))
11179 error (_("'modulus must be applied to modular type"));
11181 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
11182 ada_modulus (type_arg
));
11187 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11188 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11189 if (noside
== EVAL_SKIP
)
11191 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11192 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11193 return value_zero (type
, not_lval
);
11195 return value_pos_atr (type
, arg1
);
11198 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11199 type
= value_type (arg1
);
11201 /* If the argument is a reference, then dereference its type, since
11202 the user is really asking for the size of the actual object,
11203 not the size of the pointer. */
11204 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
11205 type
= TYPE_TARGET_TYPE (type
);
11207 if (noside
== EVAL_SKIP
)
11209 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11210 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
11212 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
11213 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
11216 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11217 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11218 type
= exp
->elts
[pc
+ 2].type
;
11219 if (noside
== EVAL_SKIP
)
11221 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11222 return value_zero (type
, not_lval
);
11224 return value_val_atr (type
, arg1
);
11227 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11228 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11229 if (noside
== EVAL_SKIP
)
11231 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11232 return value_zero (value_type (arg1
), not_lval
);
11235 /* For integer exponentiation operations,
11236 only promote the first argument. */
11237 if (is_integral_type (value_type (arg2
)))
11238 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11240 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11242 return value_binop (arg1
, arg2
, op
);
11246 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11247 if (noside
== EVAL_SKIP
)
11253 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11254 if (noside
== EVAL_SKIP
)
11256 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11257 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
11258 return value_neg (arg1
);
11263 preeval_pos
= *pos
;
11264 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11265 if (noside
== EVAL_SKIP
)
11267 type
= ada_check_typedef (value_type (arg1
));
11268 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11270 if (ada_is_array_descriptor_type (type
))
11271 /* GDB allows dereferencing GNAT array descriptors. */
11273 struct type
*arrType
= ada_type_of_array (arg1
, 0);
11275 if (arrType
== NULL
)
11276 error (_("Attempt to dereference null array pointer."));
11277 return value_at_lazy (arrType
, 0);
11279 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
11280 || TYPE_CODE (type
) == TYPE_CODE_REF
11281 /* In C you can dereference an array to get the 1st elt. */
11282 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
11284 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11285 only be determined by inspecting the object's tag.
11286 This means that we need to evaluate completely the
11287 expression in order to get its type. */
11289 if ((TYPE_CODE (type
) == TYPE_CODE_REF
11290 || TYPE_CODE (type
) == TYPE_CODE_PTR
)
11291 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
11293 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11295 type
= value_type (ada_value_ind (arg1
));
11299 type
= to_static_fixed_type
11301 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
11303 ada_ensure_varsize_limit (type
);
11304 return value_zero (type
, lval_memory
);
11306 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
11308 /* GDB allows dereferencing an int. */
11309 if (expect_type
== NULL
)
11310 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11315 to_static_fixed_type (ada_aligned_type (expect_type
));
11316 return value_zero (expect_type
, lval_memory
);
11320 error (_("Attempt to take contents of a non-pointer value."));
11322 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11323 type
= ada_check_typedef (value_type (arg1
));
11325 if (TYPE_CODE (type
) == TYPE_CODE_INT
)
11326 /* GDB allows dereferencing an int. If we were given
11327 the expect_type, then use that as the target type.
11328 Otherwise, assume that the target type is an int. */
11330 if (expect_type
!= NULL
)
11331 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11334 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11335 (CORE_ADDR
) value_as_address (arg1
));
11338 if (ada_is_array_descriptor_type (type
))
11339 /* GDB allows dereferencing GNAT array descriptors. */
11340 return ada_coerce_to_simple_array (arg1
);
11342 return ada_value_ind (arg1
);
11344 case STRUCTOP_STRUCT
:
11345 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11346 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11347 preeval_pos
= *pos
;
11348 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11349 if (noside
== EVAL_SKIP
)
11351 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11353 struct type
*type1
= value_type (arg1
);
11355 if (ada_is_tagged_type (type1
, 1))
11357 type
= ada_lookup_struct_elt_type (type1
,
11358 &exp
->elts
[pc
+ 2].string
,
11361 /* If the field is not found, check if it exists in the
11362 extension of this object's type. This means that we
11363 need to evaluate completely the expression. */
11367 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11369 arg1
= ada_value_struct_elt (arg1
,
11370 &exp
->elts
[pc
+ 2].string
,
11372 arg1
= unwrap_value (arg1
);
11373 type
= value_type (ada_to_fixed_value (arg1
));
11378 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11381 return value_zero (ada_aligned_type (type
), lval_memory
);
11385 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11386 arg1
= unwrap_value (arg1
);
11387 return ada_to_fixed_value (arg1
);
11391 /* The value is not supposed to be used. This is here to make it
11392 easier to accommodate expressions that contain types. */
11394 if (noside
== EVAL_SKIP
)
11396 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11397 return allocate_value (exp
->elts
[pc
+ 1].type
);
11399 error (_("Attempt to use a type name as an expression"));
11404 case OP_DISCRETE_RANGE
:
11405 case OP_POSITIONAL
:
11407 if (noside
== EVAL_NORMAL
)
11411 error (_("Undefined name, ambiguous name, or renaming used in "
11412 "component association: %s."), &exp
->elts
[pc
+2].string
);
11414 error (_("Aggregates only allowed on the right of an assignment"));
11416 internal_error (__FILE__
, __LINE__
,
11417 _("aggregate apparently mangled"));
11420 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11422 for (tem
= 0; tem
< nargs
; tem
+= 1)
11423 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11428 return eval_skip_value (exp
);
11434 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11435 type name that encodes the 'small and 'delta information.
11436 Otherwise, return NULL. */
11438 static const char *
11439 fixed_type_info (struct type
*type
)
11441 const char *name
= ada_type_name (type
);
11442 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
11444 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11446 const char *tail
= strstr (name
, "___XF_");
11453 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11454 return fixed_type_info (TYPE_TARGET_TYPE (type
));
11459 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11462 ada_is_fixed_point_type (struct type
*type
)
11464 return fixed_type_info (type
) != NULL
;
11467 /* Return non-zero iff TYPE represents a System.Address type. */
11470 ada_is_system_address_type (struct type
*type
)
11472 return (TYPE_NAME (type
)
11473 && strcmp (TYPE_NAME (type
), "system__address") == 0);
11476 /* Assuming that TYPE is the representation of an Ada fixed-point
11477 type, return the target floating-point type to be used to represent
11478 of this type during internal computation. */
11480 static struct type
*
11481 ada_scaling_type (struct type
*type
)
11483 return builtin_type (get_type_arch (type
))->builtin_long_double
;
11486 /* Assuming that TYPE is the representation of an Ada fixed-point
11487 type, return its delta, or NULL if the type is malformed and the
11488 delta cannot be determined. */
11491 ada_delta (struct type
*type
)
11493 const char *encoding
= fixed_type_info (type
);
11494 struct type
*scale_type
= ada_scaling_type (type
);
11496 long long num
, den
;
11498 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11501 return value_binop (value_from_longest (scale_type
, num
),
11502 value_from_longest (scale_type
, den
), BINOP_DIV
);
11505 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11506 factor ('SMALL value) associated with the type. */
11509 ada_scaling_factor (struct type
*type
)
11511 const char *encoding
= fixed_type_info (type
);
11512 struct type
*scale_type
= ada_scaling_type (type
);
11514 long long num0
, den0
, num1
, den1
;
11517 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11518 &num0
, &den0
, &num1
, &den1
);
11521 return value_from_longest (scale_type
, 1);
11523 return value_binop (value_from_longest (scale_type
, num1
),
11524 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11526 return value_binop (value_from_longest (scale_type
, num0
),
11527 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11534 /* Scan STR beginning at position K for a discriminant name, and
11535 return the value of that discriminant field of DVAL in *PX. If
11536 PNEW_K is not null, put the position of the character beyond the
11537 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11538 not alter *PX and *PNEW_K if unsuccessful. */
11541 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11544 static char *bound_buffer
= NULL
;
11545 static size_t bound_buffer_len
= 0;
11546 const char *pstart
, *pend
, *bound
;
11547 struct value
*bound_val
;
11549 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11553 pend
= strstr (pstart
, "__");
11557 k
+= strlen (bound
);
11561 int len
= pend
- pstart
;
11563 /* Strip __ and beyond. */
11564 GROW_VECT (bound_buffer
, bound_buffer_len
, len
+ 1);
11565 strncpy (bound_buffer
, pstart
, len
);
11566 bound_buffer
[len
] = '\0';
11568 bound
= bound_buffer
;
11572 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11573 if (bound_val
== NULL
)
11576 *px
= value_as_long (bound_val
);
11577 if (pnew_k
!= NULL
)
11582 /* Value of variable named NAME in the current environment. If
11583 no such variable found, then if ERR_MSG is null, returns 0, and
11584 otherwise causes an error with message ERR_MSG. */
11586 static struct value
*
11587 get_var_value (const char *name
, const char *err_msg
)
11589 lookup_name_info
lookup_name (name
, symbol_name_match_type::FULL
);
11591 std::vector
<struct block_symbol
> syms
;
11592 int nsyms
= ada_lookup_symbol_list_worker (lookup_name
,
11593 get_selected_block (0),
11594 VAR_DOMAIN
, &syms
, 1);
11598 if (err_msg
== NULL
)
11601 error (("%s"), err_msg
);
11604 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11607 /* Value of integer variable named NAME in the current environment.
11608 If no such variable is found, returns false. Otherwise, sets VALUE
11609 to the variable's value and returns true. */
11612 get_int_var_value (const char *name
, LONGEST
&value
)
11614 struct value
*var_val
= get_var_value (name
, 0);
11619 value
= value_as_long (var_val
);
11624 /* Return a range type whose base type is that of the range type named
11625 NAME in the current environment, and whose bounds are calculated
11626 from NAME according to the GNAT range encoding conventions.
11627 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11628 corresponding range type from debug information; fall back to using it
11629 if symbol lookup fails. If a new type must be created, allocate it
11630 like ORIG_TYPE was. The bounds information, in general, is encoded
11631 in NAME, the base type given in the named range type. */
11633 static struct type
*
11634 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11637 struct type
*base_type
;
11638 const char *subtype_info
;
11640 gdb_assert (raw_type
!= NULL
);
11641 gdb_assert (TYPE_NAME (raw_type
) != NULL
);
11643 if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
11644 base_type
= TYPE_TARGET_TYPE (raw_type
);
11646 base_type
= raw_type
;
11648 name
= TYPE_NAME (raw_type
);
11649 subtype_info
= strstr (name
, "___XD");
11650 if (subtype_info
== NULL
)
11652 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11653 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11655 if (L
< INT_MIN
|| U
> INT_MAX
)
11658 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11663 static char *name_buf
= NULL
;
11664 static size_t name_len
= 0;
11665 int prefix_len
= subtype_info
- name
;
11668 const char *bounds_str
;
11671 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11672 strncpy (name_buf
, name
, prefix_len
);
11673 name_buf
[prefix_len
] = '\0';
11676 bounds_str
= strchr (subtype_info
, '_');
11679 if (*subtype_info
== 'L')
11681 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11682 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11684 if (bounds_str
[n
] == '_')
11686 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11692 strcpy (name_buf
+ prefix_len
, "___L");
11693 if (!get_int_var_value (name_buf
, L
))
11695 lim_warning (_("Unknown lower bound, using 1."));
11700 if (*subtype_info
== 'U')
11702 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11703 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11708 strcpy (name_buf
+ prefix_len
, "___U");
11709 if (!get_int_var_value (name_buf
, U
))
11711 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11716 type
= create_static_range_type (alloc_type_copy (raw_type
),
11718 /* create_static_range_type alters the resulting type's length
11719 to match the size of the base_type, which is not what we want.
11720 Set it back to the original range type's length. */
11721 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11722 TYPE_NAME (type
) = name
;
11727 /* True iff NAME is the name of a range type. */
11730 ada_is_range_type_name (const char *name
)
11732 return (name
!= NULL
&& strstr (name
, "___XD"));
11736 /* Modular types */
11738 /* True iff TYPE is an Ada modular type. */
11741 ada_is_modular_type (struct type
*type
)
11743 struct type
*subranged_type
= get_base_type (type
);
11745 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
11746 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
11747 && TYPE_UNSIGNED (subranged_type
));
11750 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11753 ada_modulus (struct type
*type
)
11755 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
11759 /* Ada exception catchpoint support:
11760 ---------------------------------
11762 We support 3 kinds of exception catchpoints:
11763 . catchpoints on Ada exceptions
11764 . catchpoints on unhandled Ada exceptions
11765 . catchpoints on failed assertions
11767 Exceptions raised during failed assertions, or unhandled exceptions
11768 could perfectly be caught with the general catchpoint on Ada exceptions.
11769 However, we can easily differentiate these two special cases, and having
11770 the option to distinguish these two cases from the rest can be useful
11771 to zero-in on certain situations.
11773 Exception catchpoints are a specialized form of breakpoint,
11774 since they rely on inserting breakpoints inside known routines
11775 of the GNAT runtime. The implementation therefore uses a standard
11776 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11779 Support in the runtime for exception catchpoints have been changed
11780 a few times already, and these changes affect the implementation
11781 of these catchpoints. In order to be able to support several
11782 variants of the runtime, we use a sniffer that will determine
11783 the runtime variant used by the program being debugged. */
11785 /* Ada's standard exceptions.
11787 The Ada 83 standard also defined Numeric_Error. But there so many
11788 situations where it was unclear from the Ada 83 Reference Manual
11789 (RM) whether Constraint_Error or Numeric_Error should be raised,
11790 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11791 Interpretation saying that anytime the RM says that Numeric_Error
11792 should be raised, the implementation may raise Constraint_Error.
11793 Ada 95 went one step further and pretty much removed Numeric_Error
11794 from the list of standard exceptions (it made it a renaming of
11795 Constraint_Error, to help preserve compatibility when compiling
11796 an Ada83 compiler). As such, we do not include Numeric_Error from
11797 this list of standard exceptions. */
11799 static const char *standard_exc
[] = {
11800 "constraint_error",
11806 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11808 /* A structure that describes how to support exception catchpoints
11809 for a given executable. */
11811 struct exception_support_info
11813 /* The name of the symbol to break on in order to insert
11814 a catchpoint on exceptions. */
11815 const char *catch_exception_sym
;
11817 /* The name of the symbol to break on in order to insert
11818 a catchpoint on unhandled exceptions. */
11819 const char *catch_exception_unhandled_sym
;
11821 /* The name of the symbol to break on in order to insert
11822 a catchpoint on failed assertions. */
11823 const char *catch_assert_sym
;
11825 /* The name of the symbol to break on in order to insert
11826 a catchpoint on exception handling. */
11827 const char *catch_handlers_sym
;
11829 /* Assuming that the inferior just triggered an unhandled exception
11830 catchpoint, this function is responsible for returning the address
11831 in inferior memory where the name of that exception is stored.
11832 Return zero if the address could not be computed. */
11833 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11836 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11837 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11839 /* The following exception support info structure describes how to
11840 implement exception catchpoints with the latest version of the
11841 Ada runtime (as of 2019-08-??). */
11843 static const struct exception_support_info default_exception_support_info
=
11845 "__gnat_debug_raise_exception", /* catch_exception_sym */
11846 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11847 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11848 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11849 ada_unhandled_exception_name_addr
11852 /* The following exception support info structure describes how to
11853 implement exception catchpoints with an earlier version of the
11854 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11856 static const struct exception_support_info exception_support_info_v0
=
11858 "__gnat_debug_raise_exception", /* catch_exception_sym */
11859 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11860 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11861 "__gnat_begin_handler", /* catch_handlers_sym */
11862 ada_unhandled_exception_name_addr
11865 /* The following exception support info structure describes how to
11866 implement exception catchpoints with a slightly older version
11867 of the Ada runtime. */
11869 static const struct exception_support_info exception_support_info_fallback
=
11871 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11872 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11873 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11874 "__gnat_begin_handler", /* catch_handlers_sym */
11875 ada_unhandled_exception_name_addr_from_raise
11878 /* Return nonzero if we can detect the exception support routines
11879 described in EINFO.
11881 This function errors out if an abnormal situation is detected
11882 (for instance, if we find the exception support routines, but
11883 that support is found to be incomplete). */
11886 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11888 struct symbol
*sym
;
11890 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11891 that should be compiled with debugging information. As a result, we
11892 expect to find that symbol in the symtabs. */
11894 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11897 /* Perhaps we did not find our symbol because the Ada runtime was
11898 compiled without debugging info, or simply stripped of it.
11899 It happens on some GNU/Linux distributions for instance, where
11900 users have to install a separate debug package in order to get
11901 the runtime's debugging info. In that situation, let the user
11902 know why we cannot insert an Ada exception catchpoint.
11904 Note: Just for the purpose of inserting our Ada exception
11905 catchpoint, we could rely purely on the associated minimal symbol.
11906 But we would be operating in degraded mode anyway, since we are
11907 still lacking the debugging info needed later on to extract
11908 the name of the exception being raised (this name is printed in
11909 the catchpoint message, and is also used when trying to catch
11910 a specific exception). We do not handle this case for now. */
11911 struct bound_minimal_symbol msym
11912 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11914 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11915 error (_("Your Ada runtime appears to be missing some debugging "
11916 "information.\nCannot insert Ada exception catchpoint "
11917 "in this configuration."));
11922 /* Make sure that the symbol we found corresponds to a function. */
11924 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11926 error (_("Symbol \"%s\" is not a function (class = %d)"),
11927 SYMBOL_LINKAGE_NAME (sym
), SYMBOL_CLASS (sym
));
11931 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11934 struct bound_minimal_symbol msym
11935 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11937 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11938 error (_("Your Ada runtime appears to be missing some debugging "
11939 "information.\nCannot insert Ada exception catchpoint "
11940 "in this configuration."));
11945 /* Make sure that the symbol we found corresponds to a function. */
11947 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11949 error (_("Symbol \"%s\" is not a function (class = %d)"),
11950 SYMBOL_LINKAGE_NAME (sym
), SYMBOL_CLASS (sym
));
11957 /* Inspect the Ada runtime and determine which exception info structure
11958 should be used to provide support for exception catchpoints.
11960 This function will always set the per-inferior exception_info,
11961 or raise an error. */
11964 ada_exception_support_info_sniffer (void)
11966 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11968 /* If the exception info is already known, then no need to recompute it. */
11969 if (data
->exception_info
!= NULL
)
11972 /* Check the latest (default) exception support info. */
11973 if (ada_has_this_exception_support (&default_exception_support_info
))
11975 data
->exception_info
= &default_exception_support_info
;
11979 /* Try the v0 exception suport info. */
11980 if (ada_has_this_exception_support (&exception_support_info_v0
))
11982 data
->exception_info
= &exception_support_info_v0
;
11986 /* Try our fallback exception suport info. */
11987 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11989 data
->exception_info
= &exception_support_info_fallback
;
11993 /* Sometimes, it is normal for us to not be able to find the routine
11994 we are looking for. This happens when the program is linked with
11995 the shared version of the GNAT runtime, and the program has not been
11996 started yet. Inform the user of these two possible causes if
11999 if (ada_update_initial_language (language_unknown
) != language_ada
)
12000 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
12002 /* If the symbol does not exist, then check that the program is
12003 already started, to make sure that shared libraries have been
12004 loaded. If it is not started, this may mean that the symbol is
12005 in a shared library. */
12007 if (inferior_ptid
.pid () == 0)
12008 error (_("Unable to insert catchpoint. Try to start the program first."));
12010 /* At this point, we know that we are debugging an Ada program and
12011 that the inferior has been started, but we still are not able to
12012 find the run-time symbols. That can mean that we are in
12013 configurable run time mode, or that a-except as been optimized
12014 out by the linker... In any case, at this point it is not worth
12015 supporting this feature. */
12017 error (_("Cannot insert Ada exception catchpoints in this configuration."));
12020 /* True iff FRAME is very likely to be that of a function that is
12021 part of the runtime system. This is all very heuristic, but is
12022 intended to be used as advice as to what frames are uninteresting
12026 is_known_support_routine (struct frame_info
*frame
)
12028 enum language func_lang
;
12030 const char *fullname
;
12032 /* If this code does not have any debugging information (no symtab),
12033 This cannot be any user code. */
12035 symtab_and_line sal
= find_frame_sal (frame
);
12036 if (sal
.symtab
== NULL
)
12039 /* If there is a symtab, but the associated source file cannot be
12040 located, then assume this is not user code: Selecting a frame
12041 for which we cannot display the code would not be very helpful
12042 for the user. This should also take care of case such as VxWorks
12043 where the kernel has some debugging info provided for a few units. */
12045 fullname
= symtab_to_fullname (sal
.symtab
);
12046 if (access (fullname
, R_OK
) != 0)
12049 /* Check the unit filename against the Ada runtime file naming.
12050 We also check the name of the objfile against the name of some
12051 known system libraries that sometimes come with debugging info
12054 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
12056 re_comp (known_runtime_file_name_patterns
[i
]);
12057 if (re_exec (lbasename (sal
.symtab
->filename
)))
12059 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
12060 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
12064 /* Check whether the function is a GNAT-generated entity. */
12066 gdb::unique_xmalloc_ptr
<char> func_name
12067 = find_frame_funname (frame
, &func_lang
, NULL
);
12068 if (func_name
== NULL
)
12071 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
12073 re_comp (known_auxiliary_function_name_patterns
[i
]);
12074 if (re_exec (func_name
.get ()))
12081 /* Find the first frame that contains debugging information and that is not
12082 part of the Ada run-time, starting from FI and moving upward. */
12085 ada_find_printable_frame (struct frame_info
*fi
)
12087 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
12089 if (!is_known_support_routine (fi
))
12098 /* Assuming that the inferior just triggered an unhandled exception
12099 catchpoint, return the address in inferior memory where the name
12100 of the exception is stored.
12102 Return zero if the address could not be computed. */
12105 ada_unhandled_exception_name_addr (void)
12107 return parse_and_eval_address ("e.full_name");
12110 /* Same as ada_unhandled_exception_name_addr, except that this function
12111 should be used when the inferior uses an older version of the runtime,
12112 where the exception name needs to be extracted from a specific frame
12113 several frames up in the callstack. */
12116 ada_unhandled_exception_name_addr_from_raise (void)
12119 struct frame_info
*fi
;
12120 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12122 /* To determine the name of this exception, we need to select
12123 the frame corresponding to RAISE_SYM_NAME. This frame is
12124 at least 3 levels up, so we simply skip the first 3 frames
12125 without checking the name of their associated function. */
12126 fi
= get_current_frame ();
12127 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
12129 fi
= get_prev_frame (fi
);
12133 enum language func_lang
;
12135 gdb::unique_xmalloc_ptr
<char> func_name
12136 = find_frame_funname (fi
, &func_lang
, NULL
);
12137 if (func_name
!= NULL
)
12139 if (strcmp (func_name
.get (),
12140 data
->exception_info
->catch_exception_sym
) == 0)
12141 break; /* We found the frame we were looking for... */
12143 fi
= get_prev_frame (fi
);
12150 return parse_and_eval_address ("id.full_name");
12153 /* Assuming the inferior just triggered an Ada exception catchpoint
12154 (of any type), return the address in inferior memory where the name
12155 of the exception is stored, if applicable.
12157 Assumes the selected frame is the current frame.
12159 Return zero if the address could not be computed, or if not relevant. */
12162 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
12163 struct breakpoint
*b
)
12165 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12169 case ada_catch_exception
:
12170 return (parse_and_eval_address ("e.full_name"));
12173 case ada_catch_exception_unhandled
:
12174 return data
->exception_info
->unhandled_exception_name_addr ();
12177 case ada_catch_handlers
:
12178 return 0; /* The runtimes does not provide access to the exception
12182 case ada_catch_assert
:
12183 return 0; /* Exception name is not relevant in this case. */
12187 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12191 return 0; /* Should never be reached. */
12194 /* Assuming the inferior is stopped at an exception catchpoint,
12195 return the message which was associated to the exception, if
12196 available. Return NULL if the message could not be retrieved.
12198 Note: The exception message can be associated to an exception
12199 either through the use of the Raise_Exception function, or
12200 more simply (Ada 2005 and later), via:
12202 raise Exception_Name with "exception message";
12206 static gdb::unique_xmalloc_ptr
<char>
12207 ada_exception_message_1 (void)
12209 struct value
*e_msg_val
;
12212 /* For runtimes that support this feature, the exception message
12213 is passed as an unbounded string argument called "message". */
12214 e_msg_val
= parse_and_eval ("message");
12215 if (e_msg_val
== NULL
)
12216 return NULL
; /* Exception message not supported. */
12218 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
12219 gdb_assert (e_msg_val
!= NULL
);
12220 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
12222 /* If the message string is empty, then treat it as if there was
12223 no exception message. */
12224 if (e_msg_len
<= 0)
12227 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
12228 read_memory_string (value_address (e_msg_val
), e_msg
.get (), e_msg_len
+ 1);
12229 e_msg
.get ()[e_msg_len
] = '\0';
12234 /* Same as ada_exception_message_1, except that all exceptions are
12235 contained here (returning NULL instead). */
12237 static gdb::unique_xmalloc_ptr
<char>
12238 ada_exception_message (void)
12240 gdb::unique_xmalloc_ptr
<char> e_msg
;
12244 e_msg
= ada_exception_message_1 ();
12246 catch (const gdb_exception_error
&e
)
12248 e_msg
.reset (nullptr);
12254 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12255 any error that ada_exception_name_addr_1 might cause to be thrown.
12256 When an error is intercepted, a warning with the error message is printed,
12257 and zero is returned. */
12260 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
12261 struct breakpoint
*b
)
12263 CORE_ADDR result
= 0;
12267 result
= ada_exception_name_addr_1 (ex
, b
);
12270 catch (const gdb_exception_error
&e
)
12272 warning (_("failed to get exception name: %s"), e
.what ());
12279 static std::string ada_exception_catchpoint_cond_string
12280 (const char *excep_string
,
12281 enum ada_exception_catchpoint_kind ex
);
12283 /* Ada catchpoints.
12285 In the case of catchpoints on Ada exceptions, the catchpoint will
12286 stop the target on every exception the program throws. When a user
12287 specifies the name of a specific exception, we translate this
12288 request into a condition expression (in text form), and then parse
12289 it into an expression stored in each of the catchpoint's locations.
12290 We then use this condition to check whether the exception that was
12291 raised is the one the user is interested in. If not, then the
12292 target is resumed again. We store the name of the requested
12293 exception, in order to be able to re-set the condition expression
12294 when symbols change. */
12296 /* An instance of this type is used to represent an Ada catchpoint
12297 breakpoint location. */
12299 class ada_catchpoint_location
: public bp_location
12302 ada_catchpoint_location (breakpoint
*owner
)
12303 : bp_location (owner
, bp_loc_software_breakpoint
)
12306 /* The condition that checks whether the exception that was raised
12307 is the specific exception the user specified on catchpoint
12309 expression_up excep_cond_expr
;
12312 /* An instance of this type is used to represent an Ada catchpoint. */
12314 struct ada_catchpoint
: public breakpoint
12316 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
12321 /* The name of the specific exception the user specified. */
12322 std::string excep_string
;
12324 /* What kind of catchpoint this is. */
12325 enum ada_exception_catchpoint_kind m_kind
;
12328 /* Parse the exception condition string in the context of each of the
12329 catchpoint's locations, and store them for later evaluation. */
12332 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12333 enum ada_exception_catchpoint_kind ex
)
12335 struct bp_location
*bl
;
12337 /* Nothing to do if there's no specific exception to catch. */
12338 if (c
->excep_string
.empty ())
12341 /* Same if there are no locations... */
12342 if (c
->loc
== NULL
)
12345 /* Compute the condition expression in text form, from the specific
12346 expection we want to catch. */
12347 std::string cond_string
12348 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
12350 /* Iterate over all the catchpoint's locations, and parse an
12351 expression for each. */
12352 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
12354 struct ada_catchpoint_location
*ada_loc
12355 = (struct ada_catchpoint_location
*) bl
;
12358 if (!bl
->shlib_disabled
)
12362 s
= cond_string
.c_str ();
12365 exp
= parse_exp_1 (&s
, bl
->address
,
12366 block_for_pc (bl
->address
),
12369 catch (const gdb_exception_error
&e
)
12371 warning (_("failed to reevaluate internal exception condition "
12372 "for catchpoint %d: %s"),
12373 c
->number
, e
.what ());
12377 ada_loc
->excep_cond_expr
= std::move (exp
);
12381 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12382 structure for all exception catchpoint kinds. */
12384 static struct bp_location
*
12385 allocate_location_exception (struct breakpoint
*self
)
12387 return new ada_catchpoint_location (self
);
12390 /* Implement the RE_SET method in the breakpoint_ops structure for all
12391 exception catchpoint kinds. */
12394 re_set_exception (struct breakpoint
*b
)
12396 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12398 /* Call the base class's method. This updates the catchpoint's
12400 bkpt_breakpoint_ops
.re_set (b
);
12402 /* Reparse the exception conditional expressions. One for each
12404 create_excep_cond_exprs (c
, c
->m_kind
);
12407 /* Returns true if we should stop for this breakpoint hit. If the
12408 user specified a specific exception, we only want to cause a stop
12409 if the program thrown that exception. */
12412 should_stop_exception (const struct bp_location
*bl
)
12414 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12415 const struct ada_catchpoint_location
*ada_loc
12416 = (const struct ada_catchpoint_location
*) bl
;
12419 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12420 if (c
->m_kind
== ada_catch_assert
)
12421 clear_internalvar (var
);
12428 if (c
->m_kind
== ada_catch_handlers
)
12429 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12430 ".all.occurrence.id");
12434 struct value
*exc
= parse_and_eval (expr
);
12435 set_internalvar (var
, exc
);
12437 catch (const gdb_exception_error
&ex
)
12439 clear_internalvar (var
);
12443 /* With no specific exception, should always stop. */
12444 if (c
->excep_string
.empty ())
12447 if (ada_loc
->excep_cond_expr
== NULL
)
12449 /* We will have a NULL expression if back when we were creating
12450 the expressions, this location's had failed to parse. */
12457 struct value
*mark
;
12459 mark
= value_mark ();
12460 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12461 value_free_to_mark (mark
);
12463 catch (const gdb_exception
&ex
)
12465 exception_fprintf (gdb_stderr
, ex
,
12466 _("Error in testing exception condition:\n"));
12472 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12473 for all exception catchpoint kinds. */
12476 check_status_exception (bpstat bs
)
12478 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
12481 /* Implement the PRINT_IT method in the breakpoint_ops structure
12482 for all exception catchpoint kinds. */
12484 static enum print_stop_action
12485 print_it_exception (bpstat bs
)
12487 struct ui_out
*uiout
= current_uiout
;
12488 struct breakpoint
*b
= bs
->breakpoint_at
;
12490 annotate_catchpoint (b
->number
);
12492 if (uiout
->is_mi_like_p ())
12494 uiout
->field_string ("reason",
12495 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12496 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12499 uiout
->text (b
->disposition
== disp_del
12500 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12501 uiout
->field_signed ("bkptno", b
->number
);
12502 uiout
->text (", ");
12504 /* ada_exception_name_addr relies on the selected frame being the
12505 current frame. Need to do this here because this function may be
12506 called more than once when printing a stop, and below, we'll
12507 select the first frame past the Ada run-time (see
12508 ada_find_printable_frame). */
12509 select_frame (get_current_frame ());
12511 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12514 case ada_catch_exception
:
12515 case ada_catch_exception_unhandled
:
12516 case ada_catch_handlers
:
12518 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12519 char exception_name
[256];
12523 read_memory (addr
, (gdb_byte
*) exception_name
,
12524 sizeof (exception_name
) - 1);
12525 exception_name
[sizeof (exception_name
) - 1] = '\0';
12529 /* For some reason, we were unable to read the exception
12530 name. This could happen if the Runtime was compiled
12531 without debugging info, for instance. In that case,
12532 just replace the exception name by the generic string
12533 "exception" - it will read as "an exception" in the
12534 notification we are about to print. */
12535 memcpy (exception_name
, "exception", sizeof ("exception"));
12537 /* In the case of unhandled exception breakpoints, we print
12538 the exception name as "unhandled EXCEPTION_NAME", to make
12539 it clearer to the user which kind of catchpoint just got
12540 hit. We used ui_out_text to make sure that this extra
12541 info does not pollute the exception name in the MI case. */
12542 if (c
->m_kind
== ada_catch_exception_unhandled
)
12543 uiout
->text ("unhandled ");
12544 uiout
->field_string ("exception-name", exception_name
);
12547 case ada_catch_assert
:
12548 /* In this case, the name of the exception is not really
12549 important. Just print "failed assertion" to make it clearer
12550 that his program just hit an assertion-failure catchpoint.
12551 We used ui_out_text because this info does not belong in
12553 uiout
->text ("failed assertion");
12557 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12558 if (exception_message
!= NULL
)
12560 uiout
->text (" (");
12561 uiout
->field_string ("exception-message", exception_message
.get ());
12565 uiout
->text (" at ");
12566 ada_find_printable_frame (get_current_frame ());
12568 return PRINT_SRC_AND_LOC
;
12571 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12572 for all exception catchpoint kinds. */
12575 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12577 struct ui_out
*uiout
= current_uiout
;
12578 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12579 struct value_print_options opts
;
12581 get_user_print_options (&opts
);
12583 if (opts
.addressprint
)
12584 uiout
->field_skip ("addr");
12586 annotate_field (5);
12589 case ada_catch_exception
:
12590 if (!c
->excep_string
.empty ())
12592 std::string msg
= string_printf (_("`%s' Ada exception"),
12593 c
->excep_string
.c_str ());
12595 uiout
->field_string ("what", msg
);
12598 uiout
->field_string ("what", "all Ada exceptions");
12602 case ada_catch_exception_unhandled
:
12603 uiout
->field_string ("what", "unhandled Ada exceptions");
12606 case ada_catch_handlers
:
12607 if (!c
->excep_string
.empty ())
12609 uiout
->field_fmt ("what",
12610 _("`%s' Ada exception handlers"),
12611 c
->excep_string
.c_str ());
12614 uiout
->field_string ("what", "all Ada exceptions handlers");
12617 case ada_catch_assert
:
12618 uiout
->field_string ("what", "failed Ada assertions");
12622 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12627 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12628 for all exception catchpoint kinds. */
12631 print_mention_exception (struct breakpoint
*b
)
12633 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12634 struct ui_out
*uiout
= current_uiout
;
12636 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12637 : _("Catchpoint "));
12638 uiout
->field_signed ("bkptno", b
->number
);
12639 uiout
->text (": ");
12643 case ada_catch_exception
:
12644 if (!c
->excep_string
.empty ())
12646 std::string info
= string_printf (_("`%s' Ada exception"),
12647 c
->excep_string
.c_str ());
12648 uiout
->text (info
.c_str ());
12651 uiout
->text (_("all Ada exceptions"));
12654 case ada_catch_exception_unhandled
:
12655 uiout
->text (_("unhandled Ada exceptions"));
12658 case ada_catch_handlers
:
12659 if (!c
->excep_string
.empty ())
12662 = string_printf (_("`%s' Ada exception handlers"),
12663 c
->excep_string
.c_str ());
12664 uiout
->text (info
.c_str ());
12667 uiout
->text (_("all Ada exceptions handlers"));
12670 case ada_catch_assert
:
12671 uiout
->text (_("failed Ada assertions"));
12675 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12680 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12681 for all exception catchpoint kinds. */
12684 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12686 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12690 case ada_catch_exception
:
12691 fprintf_filtered (fp
, "catch exception");
12692 if (!c
->excep_string
.empty ())
12693 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12696 case ada_catch_exception_unhandled
:
12697 fprintf_filtered (fp
, "catch exception unhandled");
12700 case ada_catch_handlers
:
12701 fprintf_filtered (fp
, "catch handlers");
12704 case ada_catch_assert
:
12705 fprintf_filtered (fp
, "catch assert");
12709 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12711 print_recreate_thread (b
, fp
);
12714 /* Virtual tables for various breakpoint types. */
12715 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12716 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12717 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12718 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12720 /* See ada-lang.h. */
12723 is_ada_exception_catchpoint (breakpoint
*bp
)
12725 return (bp
->ops
== &catch_exception_breakpoint_ops
12726 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12727 || bp
->ops
== &catch_assert_breakpoint_ops
12728 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12731 /* Split the arguments specified in a "catch exception" command.
12732 Set EX to the appropriate catchpoint type.
12733 Set EXCEP_STRING to the name of the specific exception if
12734 specified by the user.
12735 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12736 "catch handlers" command. False otherwise.
12737 If a condition is found at the end of the arguments, the condition
12738 expression is stored in COND_STRING (memory must be deallocated
12739 after use). Otherwise COND_STRING is set to NULL. */
12742 catch_ada_exception_command_split (const char *args
,
12743 bool is_catch_handlers_cmd
,
12744 enum ada_exception_catchpoint_kind
*ex
,
12745 std::string
*excep_string
,
12746 std::string
*cond_string
)
12748 std::string exception_name
;
12750 exception_name
= extract_arg (&args
);
12751 if (exception_name
== "if")
12753 /* This is not an exception name; this is the start of a condition
12754 expression for a catchpoint on all exceptions. So, "un-get"
12755 this token, and set exception_name to NULL. */
12756 exception_name
.clear ();
12760 /* Check to see if we have a condition. */
12762 args
= skip_spaces (args
);
12763 if (startswith (args
, "if")
12764 && (isspace (args
[2]) || args
[2] == '\0'))
12767 args
= skip_spaces (args
);
12769 if (args
[0] == '\0')
12770 error (_("Condition missing after `if' keyword"));
12771 *cond_string
= args
;
12773 args
+= strlen (args
);
12776 /* Check that we do not have any more arguments. Anything else
12779 if (args
[0] != '\0')
12780 error (_("Junk at end of expression"));
12782 if (is_catch_handlers_cmd
)
12784 /* Catch handling of exceptions. */
12785 *ex
= ada_catch_handlers
;
12786 *excep_string
= exception_name
;
12788 else if (exception_name
.empty ())
12790 /* Catch all exceptions. */
12791 *ex
= ada_catch_exception
;
12792 excep_string
->clear ();
12794 else if (exception_name
== "unhandled")
12796 /* Catch unhandled exceptions. */
12797 *ex
= ada_catch_exception_unhandled
;
12798 excep_string
->clear ();
12802 /* Catch a specific exception. */
12803 *ex
= ada_catch_exception
;
12804 *excep_string
= exception_name
;
12808 /* Return the name of the symbol on which we should break in order to
12809 implement a catchpoint of the EX kind. */
12811 static const char *
12812 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12814 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12816 gdb_assert (data
->exception_info
!= NULL
);
12820 case ada_catch_exception
:
12821 return (data
->exception_info
->catch_exception_sym
);
12823 case ada_catch_exception_unhandled
:
12824 return (data
->exception_info
->catch_exception_unhandled_sym
);
12826 case ada_catch_assert
:
12827 return (data
->exception_info
->catch_assert_sym
);
12829 case ada_catch_handlers
:
12830 return (data
->exception_info
->catch_handlers_sym
);
12833 internal_error (__FILE__
, __LINE__
,
12834 _("unexpected catchpoint kind (%d)"), ex
);
12838 /* Return the breakpoint ops "virtual table" used for catchpoints
12841 static const struct breakpoint_ops
*
12842 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12846 case ada_catch_exception
:
12847 return (&catch_exception_breakpoint_ops
);
12849 case ada_catch_exception_unhandled
:
12850 return (&catch_exception_unhandled_breakpoint_ops
);
12852 case ada_catch_assert
:
12853 return (&catch_assert_breakpoint_ops
);
12855 case ada_catch_handlers
:
12856 return (&catch_handlers_breakpoint_ops
);
12859 internal_error (__FILE__
, __LINE__
,
12860 _("unexpected catchpoint kind (%d)"), ex
);
12864 /* Return the condition that will be used to match the current exception
12865 being raised with the exception that the user wants to catch. This
12866 assumes that this condition is used when the inferior just triggered
12867 an exception catchpoint.
12868 EX: the type of catchpoints used for catching Ada exceptions. */
12871 ada_exception_catchpoint_cond_string (const char *excep_string
,
12872 enum ada_exception_catchpoint_kind ex
)
12875 bool is_standard_exc
= false;
12876 std::string result
;
12878 if (ex
== ada_catch_handlers
)
12880 /* For exception handlers catchpoints, the condition string does
12881 not use the same parameter as for the other exceptions. */
12882 result
= ("long_integer (GNAT_GCC_exception_Access"
12883 "(gcc_exception).all.occurrence.id)");
12886 result
= "long_integer (e)";
12888 /* The standard exceptions are a special case. They are defined in
12889 runtime units that have been compiled without debugging info; if
12890 EXCEP_STRING is the not-fully-qualified name of a standard
12891 exception (e.g. "constraint_error") then, during the evaluation
12892 of the condition expression, the symbol lookup on this name would
12893 *not* return this standard exception. The catchpoint condition
12894 may then be set only on user-defined exceptions which have the
12895 same not-fully-qualified name (e.g. my_package.constraint_error).
12897 To avoid this unexcepted behavior, these standard exceptions are
12898 systematically prefixed by "standard". This means that "catch
12899 exception constraint_error" is rewritten into "catch exception
12900 standard.constraint_error".
12902 If an exception named constraint_error is defined in another package of
12903 the inferior program, then the only way to specify this exception as a
12904 breakpoint condition is to use its fully-qualified named:
12905 e.g. my_package.constraint_error. */
12907 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12909 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12911 is_standard_exc
= true;
12918 if (is_standard_exc
)
12919 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12921 string_appendf (result
, "long_integer (&%s)", excep_string
);
12926 /* Return the symtab_and_line that should be used to insert an exception
12927 catchpoint of the TYPE kind.
12929 ADDR_STRING returns the name of the function where the real
12930 breakpoint that implements the catchpoints is set, depending on the
12931 type of catchpoint we need to create. */
12933 static struct symtab_and_line
12934 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12935 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12937 const char *sym_name
;
12938 struct symbol
*sym
;
12940 /* First, find out which exception support info to use. */
12941 ada_exception_support_info_sniffer ();
12943 /* Then lookup the function on which we will break in order to catch
12944 the Ada exceptions requested by the user. */
12945 sym_name
= ada_exception_sym_name (ex
);
12946 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12949 error (_("Catchpoint symbol not found: %s"), sym_name
);
12951 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12952 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12954 /* Set ADDR_STRING. */
12955 *addr_string
= sym_name
;
12958 *ops
= ada_exception_breakpoint_ops (ex
);
12960 return find_function_start_sal (sym
, 1);
12963 /* Create an Ada exception catchpoint.
12965 EX_KIND is the kind of exception catchpoint to be created.
12967 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12968 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12969 of the exception to which this catchpoint applies.
12971 COND_STRING, if not empty, is the catchpoint condition.
12973 TEMPFLAG, if nonzero, means that the underlying breakpoint
12974 should be temporary.
12976 FROM_TTY is the usual argument passed to all commands implementations. */
12979 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12980 enum ada_exception_catchpoint_kind ex_kind
,
12981 const std::string
&excep_string
,
12982 const std::string
&cond_string
,
12987 std::string addr_string
;
12988 const struct breakpoint_ops
*ops
= NULL
;
12989 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12991 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12992 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12993 ops
, tempflag
, disabled
, from_tty
);
12994 c
->excep_string
= excep_string
;
12995 create_excep_cond_exprs (c
.get (), ex_kind
);
12996 if (!cond_string
.empty ())
12997 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
);
12998 install_breakpoint (0, std::move (c
), 1);
13001 /* Implement the "catch exception" command. */
13004 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
13005 struct cmd_list_element
*command
)
13007 const char *arg
= arg_entry
;
13008 struct gdbarch
*gdbarch
= get_current_arch ();
13010 enum ada_exception_catchpoint_kind ex_kind
;
13011 std::string excep_string
;
13012 std::string cond_string
;
13014 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
13018 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
13020 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
13021 excep_string
, cond_string
,
13022 tempflag
, 1 /* enabled */,
13026 /* Implement the "catch handlers" command. */
13029 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
13030 struct cmd_list_element
*command
)
13032 const char *arg
= arg_entry
;
13033 struct gdbarch
*gdbarch
= get_current_arch ();
13035 enum ada_exception_catchpoint_kind ex_kind
;
13036 std::string excep_string
;
13037 std::string cond_string
;
13039 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
13043 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
13045 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
13046 excep_string
, cond_string
,
13047 tempflag
, 1 /* enabled */,
13051 /* Completion function for the Ada "catch" commands. */
13054 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
13055 const char *text
, const char *word
)
13057 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
13059 for (const ada_exc_info
&info
: exceptions
)
13061 if (startswith (info
.name
, word
))
13062 tracker
.add_completion (make_unique_xstrdup (info
.name
));
13066 /* Split the arguments specified in a "catch assert" command.
13068 ARGS contains the command's arguments (or the empty string if
13069 no arguments were passed).
13071 If ARGS contains a condition, set COND_STRING to that condition
13072 (the memory needs to be deallocated after use). */
13075 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
13077 args
= skip_spaces (args
);
13079 /* Check whether a condition was provided. */
13080 if (startswith (args
, "if")
13081 && (isspace (args
[2]) || args
[2] == '\0'))
13084 args
= skip_spaces (args
);
13085 if (args
[0] == '\0')
13086 error (_("condition missing after `if' keyword"));
13087 cond_string
.assign (args
);
13090 /* Otherwise, there should be no other argument at the end of
13092 else if (args
[0] != '\0')
13093 error (_("Junk at end of arguments."));
13096 /* Implement the "catch assert" command. */
13099 catch_assert_command (const char *arg_entry
, int from_tty
,
13100 struct cmd_list_element
*command
)
13102 const char *arg
= arg_entry
;
13103 struct gdbarch
*gdbarch
= get_current_arch ();
13105 std::string cond_string
;
13107 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
13111 catch_ada_assert_command_split (arg
, cond_string
);
13112 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
13114 tempflag
, 1 /* enabled */,
13118 /* Return non-zero if the symbol SYM is an Ada exception object. */
13121 ada_is_exception_sym (struct symbol
*sym
)
13123 const char *type_name
= TYPE_NAME (SYMBOL_TYPE (sym
));
13125 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
13126 && SYMBOL_CLASS (sym
) != LOC_BLOCK
13127 && SYMBOL_CLASS (sym
) != LOC_CONST
13128 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
13129 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
13132 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13133 Ada exception object. This matches all exceptions except the ones
13134 defined by the Ada language. */
13137 ada_is_non_standard_exception_sym (struct symbol
*sym
)
13141 if (!ada_is_exception_sym (sym
))
13144 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
13145 if (strcmp (SYMBOL_LINKAGE_NAME (sym
), standard_exc
[i
]) == 0)
13146 return 0; /* A standard exception. */
13148 /* Numeric_Error is also a standard exception, so exclude it.
13149 See the STANDARD_EXC description for more details as to why
13150 this exception is not listed in that array. */
13151 if (strcmp (SYMBOL_LINKAGE_NAME (sym
), "numeric_error") == 0)
13157 /* A helper function for std::sort, comparing two struct ada_exc_info
13160 The comparison is determined first by exception name, and then
13161 by exception address. */
13164 ada_exc_info::operator< (const ada_exc_info
&other
) const
13168 result
= strcmp (name
, other
.name
);
13171 if (result
== 0 && addr
< other
.addr
)
13177 ada_exc_info::operator== (const ada_exc_info
&other
) const
13179 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
13182 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13183 routine, but keeping the first SKIP elements untouched.
13185 All duplicates are also removed. */
13188 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
13191 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
13192 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
13193 exceptions
->end ());
13196 /* Add all exceptions defined by the Ada standard whose name match
13197 a regular expression.
13199 If PREG is not NULL, then this regexp_t object is used to
13200 perform the symbol name matching. Otherwise, no name-based
13201 filtering is performed.
13203 EXCEPTIONS is a vector of exceptions to which matching exceptions
13207 ada_add_standard_exceptions (compiled_regex
*preg
,
13208 std::vector
<ada_exc_info
> *exceptions
)
13212 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
13215 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
13217 struct bound_minimal_symbol msymbol
13218 = ada_lookup_simple_minsym (standard_exc
[i
]);
13220 if (msymbol
.minsym
!= NULL
)
13222 struct ada_exc_info info
13223 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
13225 exceptions
->push_back (info
);
13231 /* Add all Ada exceptions defined locally and accessible from the given
13234 If PREG is not NULL, then this regexp_t object is used to
13235 perform the symbol name matching. Otherwise, no name-based
13236 filtering is performed.
13238 EXCEPTIONS is a vector of exceptions to which matching exceptions
13242 ada_add_exceptions_from_frame (compiled_regex
*preg
,
13243 struct frame_info
*frame
,
13244 std::vector
<ada_exc_info
> *exceptions
)
13246 const struct block
*block
= get_frame_block (frame
, 0);
13250 struct block_iterator iter
;
13251 struct symbol
*sym
;
13253 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
13255 switch (SYMBOL_CLASS (sym
))
13262 if (ada_is_exception_sym (sym
))
13264 struct ada_exc_info info
= {SYMBOL_PRINT_NAME (sym
),
13265 SYMBOL_VALUE_ADDRESS (sym
)};
13267 exceptions
->push_back (info
);
13271 if (BLOCK_FUNCTION (block
) != NULL
)
13273 block
= BLOCK_SUPERBLOCK (block
);
13277 /* Return true if NAME matches PREG or if PREG is NULL. */
13280 name_matches_regex (const char *name
, compiled_regex
*preg
)
13282 return (preg
== NULL
13283 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
13286 /* Add all exceptions defined globally whose name name match
13287 a regular expression, excluding standard exceptions.
13289 The reason we exclude standard exceptions is that they need
13290 to be handled separately: Standard exceptions are defined inside
13291 a runtime unit which is normally not compiled with debugging info,
13292 and thus usually do not show up in our symbol search. However,
13293 if the unit was in fact built with debugging info, we need to
13294 exclude them because they would duplicate the entry we found
13295 during the special loop that specifically searches for those
13296 standard exceptions.
13298 If PREG is not NULL, then this regexp_t object is used to
13299 perform the symbol name matching. Otherwise, no name-based
13300 filtering is performed.
13302 EXCEPTIONS is a vector of exceptions to which matching exceptions
13306 ada_add_global_exceptions (compiled_regex
*preg
,
13307 std::vector
<ada_exc_info
> *exceptions
)
13309 /* In Ada, the symbol "search name" is a linkage name, whereas the
13310 regular expression used to do the matching refers to the natural
13311 name. So match against the decoded name. */
13312 expand_symtabs_matching (NULL
,
13313 lookup_name_info::match_any (),
13314 [&] (const char *search_name
)
13316 std::string decoded
= ada_decode (search_name
);
13317 return name_matches_regex (decoded
.c_str (), preg
);
13322 for (objfile
*objfile
: current_program_space
->objfiles ())
13324 for (compunit_symtab
*s
: objfile
->compunits ())
13326 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13329 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13331 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13332 struct block_iterator iter
;
13333 struct symbol
*sym
;
13335 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13336 if (ada_is_non_standard_exception_sym (sym
)
13337 && name_matches_regex (SYMBOL_NATURAL_NAME (sym
), preg
))
13339 struct ada_exc_info info
13340 = {SYMBOL_PRINT_NAME (sym
), SYMBOL_VALUE_ADDRESS (sym
)};
13342 exceptions
->push_back (info
);
13349 /* Implements ada_exceptions_list with the regular expression passed
13350 as a regex_t, rather than a string.
13352 If not NULL, PREG is used to filter out exceptions whose names
13353 do not match. Otherwise, all exceptions are listed. */
13355 static std::vector
<ada_exc_info
>
13356 ada_exceptions_list_1 (compiled_regex
*preg
)
13358 std::vector
<ada_exc_info
> result
;
13361 /* First, list the known standard exceptions. These exceptions
13362 need to be handled separately, as they are usually defined in
13363 runtime units that have been compiled without debugging info. */
13365 ada_add_standard_exceptions (preg
, &result
);
13367 /* Next, find all exceptions whose scope is local and accessible
13368 from the currently selected frame. */
13370 if (has_stack_frames ())
13372 prev_len
= result
.size ();
13373 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13375 if (result
.size () > prev_len
)
13376 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13379 /* Add all exceptions whose scope is global. */
13381 prev_len
= result
.size ();
13382 ada_add_global_exceptions (preg
, &result
);
13383 if (result
.size () > prev_len
)
13384 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13389 /* Return a vector of ada_exc_info.
13391 If REGEXP is NULL, all exceptions are included in the result.
13392 Otherwise, it should contain a valid regular expression,
13393 and only the exceptions whose names match that regular expression
13394 are included in the result.
13396 The exceptions are sorted in the following order:
13397 - Standard exceptions (defined by the Ada language), in
13398 alphabetical order;
13399 - Exceptions only visible from the current frame, in
13400 alphabetical order;
13401 - Exceptions whose scope is global, in alphabetical order. */
13403 std::vector
<ada_exc_info
>
13404 ada_exceptions_list (const char *regexp
)
13406 if (regexp
== NULL
)
13407 return ada_exceptions_list_1 (NULL
);
13409 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13410 return ada_exceptions_list_1 (®
);
13413 /* Implement the "info exceptions" command. */
13416 info_exceptions_command (const char *regexp
, int from_tty
)
13418 struct gdbarch
*gdbarch
= get_current_arch ();
13420 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13422 if (regexp
!= NULL
)
13424 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13426 printf_filtered (_("All defined Ada exceptions:\n"));
13428 for (const ada_exc_info
&info
: exceptions
)
13429 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13433 /* Information about operators given special treatment in functions
13435 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13437 #define ADA_OPERATORS \
13438 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13439 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13440 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13441 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13442 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13443 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13444 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13445 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13446 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13447 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13448 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13449 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13450 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13451 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13452 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13453 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13454 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13455 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13456 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13459 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13462 switch (exp
->elts
[pc
- 1].opcode
)
13465 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13468 #define OP_DEFN(op, len, args, binop) \
13469 case op: *oplenp = len; *argsp = args; break;
13475 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13480 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13485 /* Implementation of the exp_descriptor method operator_check. */
13488 ada_operator_check (struct expression
*exp
, int pos
,
13489 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13492 const union exp_element
*const elts
= exp
->elts
;
13493 struct type
*type
= NULL
;
13495 switch (elts
[pos
].opcode
)
13497 case UNOP_IN_RANGE
:
13499 type
= elts
[pos
+ 1].type
;
13503 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13506 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13508 if (type
&& TYPE_OBJFILE (type
)
13509 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13515 static const char *
13516 ada_op_name (enum exp_opcode opcode
)
13521 return op_name_standard (opcode
);
13523 #define OP_DEFN(op, len, args, binop) case op: return #op;
13528 return "OP_AGGREGATE";
13530 return "OP_CHOICES";
13536 /* As for operator_length, but assumes PC is pointing at the first
13537 element of the operator, and gives meaningful results only for the
13538 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13541 ada_forward_operator_length (struct expression
*exp
, int pc
,
13542 int *oplenp
, int *argsp
)
13544 switch (exp
->elts
[pc
].opcode
)
13547 *oplenp
= *argsp
= 0;
13550 #define OP_DEFN(op, len, args, binop) \
13551 case op: *oplenp = len; *argsp = args; break;
13557 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13562 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13568 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13570 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13578 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13580 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13585 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13589 /* Ada attributes ('Foo). */
13592 case OP_ATR_LENGTH
:
13596 case OP_ATR_MODULUS
:
13603 case UNOP_IN_RANGE
:
13605 /* XXX: gdb_sprint_host_address, type_sprint */
13606 fprintf_filtered (stream
, _("Type @"));
13607 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13608 fprintf_filtered (stream
, " (");
13609 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13610 fprintf_filtered (stream
, ")");
13612 case BINOP_IN_BOUNDS
:
13613 fprintf_filtered (stream
, " (%d)",
13614 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13616 case TERNOP_IN_RANGE
:
13621 case OP_DISCRETE_RANGE
:
13622 case OP_POSITIONAL
:
13629 char *name
= &exp
->elts
[elt
+ 2].string
;
13630 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13632 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13637 return dump_subexp_body_standard (exp
, stream
, elt
);
13641 for (i
= 0; i
< nargs
; i
+= 1)
13642 elt
= dump_subexp (exp
, stream
, elt
);
13647 /* The Ada extension of print_subexp (q.v.). */
13650 ada_print_subexp (struct expression
*exp
, int *pos
,
13651 struct ui_file
*stream
, enum precedence prec
)
13653 int oplen
, nargs
, i
;
13655 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13657 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13664 print_subexp_standard (exp
, pos
, stream
, prec
);
13668 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
13671 case BINOP_IN_BOUNDS
:
13672 /* XXX: sprint_subexp */
13673 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13674 fputs_filtered (" in ", stream
);
13675 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13676 fputs_filtered ("'range", stream
);
13677 if (exp
->elts
[pc
+ 1].longconst
> 1)
13678 fprintf_filtered (stream
, "(%ld)",
13679 (long) exp
->elts
[pc
+ 1].longconst
);
13682 case TERNOP_IN_RANGE
:
13683 if (prec
>= PREC_EQUAL
)
13684 fputs_filtered ("(", stream
);
13685 /* XXX: sprint_subexp */
13686 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13687 fputs_filtered (" in ", stream
);
13688 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13689 fputs_filtered (" .. ", stream
);
13690 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13691 if (prec
>= PREC_EQUAL
)
13692 fputs_filtered (")", stream
);
13697 case OP_ATR_LENGTH
:
13701 case OP_ATR_MODULUS
:
13706 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13708 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
13709 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13710 &type_print_raw_options
);
13714 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13715 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13720 for (tem
= 1; tem
< nargs
; tem
+= 1)
13722 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13723 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13725 fputs_filtered (")", stream
);
13730 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13731 fputs_filtered ("'(", stream
);
13732 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13733 fputs_filtered (")", stream
);
13736 case UNOP_IN_RANGE
:
13737 /* XXX: sprint_subexp */
13738 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13739 fputs_filtered (" in ", stream
);
13740 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13741 &type_print_raw_options
);
13744 case OP_DISCRETE_RANGE
:
13745 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13746 fputs_filtered ("..", stream
);
13747 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13751 fputs_filtered ("others => ", stream
);
13752 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13756 for (i
= 0; i
< nargs
-1; i
+= 1)
13759 fputs_filtered ("|", stream
);
13760 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13762 fputs_filtered (" => ", stream
);
13763 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13766 case OP_POSITIONAL
:
13767 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13771 fputs_filtered ("(", stream
);
13772 for (i
= 0; i
< nargs
; i
+= 1)
13775 fputs_filtered (", ", stream
);
13776 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13778 fputs_filtered (")", stream
);
13783 /* Table mapping opcodes into strings for printing operators
13784 and precedences of the operators. */
13786 static const struct op_print ada_op_print_tab
[] = {
13787 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13788 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13789 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13790 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13791 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13792 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13793 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13794 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13795 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13796 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13797 {">", BINOP_GTR
, PREC_ORDER
, 0},
13798 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13799 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13800 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13801 {"+", BINOP_ADD
, PREC_ADD
, 0},
13802 {"-", BINOP_SUB
, PREC_ADD
, 0},
13803 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13804 {"*", BINOP_MUL
, PREC_MUL
, 0},
13805 {"/", BINOP_DIV
, PREC_MUL
, 0},
13806 {"rem", BINOP_REM
, PREC_MUL
, 0},
13807 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13808 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13809 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13810 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13811 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13812 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13813 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13814 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13815 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13816 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13817 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13818 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13821 enum ada_primitive_types
{
13822 ada_primitive_type_int
,
13823 ada_primitive_type_long
,
13824 ada_primitive_type_short
,
13825 ada_primitive_type_char
,
13826 ada_primitive_type_float
,
13827 ada_primitive_type_double
,
13828 ada_primitive_type_void
,
13829 ada_primitive_type_long_long
,
13830 ada_primitive_type_long_double
,
13831 ada_primitive_type_natural
,
13832 ada_primitive_type_positive
,
13833 ada_primitive_type_system_address
,
13834 ada_primitive_type_storage_offset
,
13835 nr_ada_primitive_types
13839 ada_language_arch_info (struct gdbarch
*gdbarch
,
13840 struct language_arch_info
*lai
)
13842 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13844 lai
->primitive_type_vector
13845 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
13848 lai
->primitive_type_vector
[ada_primitive_type_int
]
13849 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13851 lai
->primitive_type_vector
[ada_primitive_type_long
]
13852 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13853 0, "long_integer");
13854 lai
->primitive_type_vector
[ada_primitive_type_short
]
13855 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13856 0, "short_integer");
13857 lai
->string_char_type
13858 = lai
->primitive_type_vector
[ada_primitive_type_char
]
13859 = arch_character_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
13860 lai
->primitive_type_vector
[ada_primitive_type_float
]
13861 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13862 "float", gdbarch_float_format (gdbarch
));
13863 lai
->primitive_type_vector
[ada_primitive_type_double
]
13864 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13865 "long_float", gdbarch_double_format (gdbarch
));
13866 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
13867 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13868 0, "long_long_integer");
13869 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
13870 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13871 "long_long_float", gdbarch_long_double_format (gdbarch
));
13872 lai
->primitive_type_vector
[ada_primitive_type_natural
]
13873 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13875 lai
->primitive_type_vector
[ada_primitive_type_positive
]
13876 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13878 lai
->primitive_type_vector
[ada_primitive_type_void
]
13879 = builtin
->builtin_void
;
13881 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
13882 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13884 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
13885 = "system__address";
13887 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13888 type. This is a signed integral type whose size is the same as
13889 the size of addresses. */
13891 unsigned int addr_length
= TYPE_LENGTH
13892 (lai
->primitive_type_vector
[ada_primitive_type_system_address
]);
13894 lai
->primitive_type_vector
[ada_primitive_type_storage_offset
]
13895 = arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13899 lai
->bool_type_symbol
= NULL
;
13900 lai
->bool_type_default
= builtin
->builtin_bool
;
13903 /* Language vector */
13905 /* Not really used, but needed in the ada_language_defn. */
13908 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
13910 ada_emit_char (c
, type
, stream
, quoter
, 1);
13914 parse (struct parser_state
*ps
)
13916 warnings_issued
= 0;
13917 return ada_parse (ps
);
13920 static const struct exp_descriptor ada_exp_descriptor
= {
13922 ada_operator_length
,
13923 ada_operator_check
,
13925 ada_dump_subexp_body
,
13926 ada_evaluate_subexp
13929 /* symbol_name_matcher_ftype adapter for wild_match. */
13932 do_wild_match (const char *symbol_search_name
,
13933 const lookup_name_info
&lookup_name
,
13934 completion_match_result
*comp_match_res
)
13936 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13939 /* symbol_name_matcher_ftype adapter for full_match. */
13942 do_full_match (const char *symbol_search_name
,
13943 const lookup_name_info
&lookup_name
,
13944 completion_match_result
*comp_match_res
)
13946 return full_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13949 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13952 do_exact_match (const char *symbol_search_name
,
13953 const lookup_name_info
&lookup_name
,
13954 completion_match_result
*comp_match_res
)
13956 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13959 /* Build the Ada lookup name for LOOKUP_NAME. */
13961 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13963 const std::string
&user_name
= lookup_name
.name ();
13965 if (user_name
[0] == '<')
13967 if (user_name
.back () == '>')
13968 m_encoded_name
= user_name
.substr (1, user_name
.size () - 2);
13970 m_encoded_name
= user_name
.substr (1, user_name
.size () - 1);
13971 m_encoded_p
= true;
13972 m_verbatim_p
= true;
13973 m_wild_match_p
= false;
13974 m_standard_p
= false;
13978 m_verbatim_p
= false;
13980 m_encoded_p
= user_name
.find ("__") != std::string::npos
;
13984 const char *folded
= ada_fold_name (user_name
.c_str ());
13985 const char *encoded
= ada_encode_1 (folded
, false);
13986 if (encoded
!= NULL
)
13987 m_encoded_name
= encoded
;
13989 m_encoded_name
= user_name
;
13992 m_encoded_name
= user_name
;
13994 /* Handle the 'package Standard' special case. See description
13995 of m_standard_p. */
13996 if (startswith (m_encoded_name
.c_str (), "standard__"))
13998 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13999 m_standard_p
= true;
14002 m_standard_p
= false;
14004 /* If the name contains a ".", then the user is entering a fully
14005 qualified entity name, and the match must not be done in wild
14006 mode. Similarly, if the user wants to complete what looks
14007 like an encoded name, the match must not be done in wild
14008 mode. Also, in the standard__ special case always do
14009 non-wild matching. */
14011 = (lookup_name
.match_type () != symbol_name_match_type::FULL
14014 && user_name
.find ('.') == std::string::npos
);
14018 /* symbol_name_matcher_ftype method for Ada. This only handles
14019 completion mode. */
14022 ada_symbol_name_matches (const char *symbol_search_name
,
14023 const lookup_name_info
&lookup_name
,
14024 completion_match_result
*comp_match_res
)
14026 return lookup_name
.ada ().matches (symbol_search_name
,
14027 lookup_name
.match_type (),
14031 /* A name matcher that matches the symbol name exactly, with
14035 literal_symbol_name_matcher (const char *symbol_search_name
,
14036 const lookup_name_info
&lookup_name
,
14037 completion_match_result
*comp_match_res
)
14039 const std::string
&name
= lookup_name
.name ();
14041 int cmp
= (lookup_name
.completion_mode ()
14042 ? strncmp (symbol_search_name
, name
.c_str (), name
.size ())
14043 : strcmp (symbol_search_name
, name
.c_str ()));
14046 if (comp_match_res
!= NULL
)
14047 comp_match_res
->set_match (symbol_search_name
);
14054 /* Implement the "la_get_symbol_name_matcher" language_defn method for
14057 static symbol_name_matcher_ftype
*
14058 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
14060 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
14061 return literal_symbol_name_matcher
;
14063 if (lookup_name
.completion_mode ())
14064 return ada_symbol_name_matches
;
14067 if (lookup_name
.ada ().wild_match_p ())
14068 return do_wild_match
;
14069 else if (lookup_name
.ada ().verbatim_p ())
14070 return do_exact_match
;
14072 return do_full_match
;
14076 /* Implement the "la_read_var_value" language_defn method for Ada. */
14078 static struct value
*
14079 ada_read_var_value (struct symbol
*var
, const struct block
*var_block
,
14080 struct frame_info
*frame
)
14082 /* The only case where default_read_var_value is not sufficient
14083 is when VAR is a renaming... */
14084 if (frame
!= nullptr)
14086 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
14087 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
14088 return ada_read_renaming_var_value (var
, frame_block
);
14091 /* This is a typical case where we expect the default_read_var_value
14092 function to work. */
14093 return default_read_var_value (var
, var_block
, frame
);
14096 static const char *ada_extensions
[] =
14098 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14101 extern const struct language_defn ada_language_defn
= {
14102 "ada", /* Language name */
14106 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
14107 that's not quite what this means. */
14109 macro_expansion_no
,
14111 &ada_exp_descriptor
,
14114 ada_printchar
, /* Print a character constant */
14115 ada_printstr
, /* Function to print string constant */
14116 emit_char
, /* Function to print single char (not used) */
14117 ada_print_type
, /* Print a type using appropriate syntax */
14118 ada_print_typedef
, /* Print a typedef using appropriate syntax */
14119 ada_val_print
, /* Print a value using appropriate syntax */
14120 ada_value_print
, /* Print a top-level value */
14121 ada_read_var_value
, /* la_read_var_value */
14122 NULL
, /* Language specific skip_trampoline */
14123 NULL
, /* name_of_this */
14124 true, /* la_store_sym_names_in_linkage_form_p */
14125 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
14126 basic_lookup_transparent_type
, /* lookup_transparent_type */
14127 ada_la_decode
, /* Language specific symbol demangler */
14128 ada_sniff_from_mangled_name
,
14129 NULL
, /* Language specific
14130 class_name_from_physname */
14131 ada_op_print_tab
, /* expression operators for printing */
14132 0, /* c-style arrays */
14133 1, /* String lower bound */
14134 ada_get_gdb_completer_word_break_characters
,
14135 ada_collect_symbol_completion_matches
,
14136 ada_language_arch_info
,
14137 ada_print_array_index
,
14138 default_pass_by_reference
,
14140 ada_watch_location_expression
,
14141 ada_get_symbol_name_matcher
, /* la_get_symbol_name_matcher */
14142 ada_iterate_over_symbols
,
14143 default_search_name_hash
,
14147 ada_is_string_type
,
14148 "(...)" /* la_struct_too_deep_ellipsis */
14151 /* Command-list for the "set/show ada" prefix command. */
14152 static struct cmd_list_element
*set_ada_list
;
14153 static struct cmd_list_element
*show_ada_list
;
14155 /* Implement the "set ada" prefix command. */
14158 set_ada_command (const char *arg
, int from_tty
)
14160 printf_unfiltered (_(\
14161 "\"set ada\" must be followed by the name of a setting.\n"));
14162 help_list (set_ada_list
, "set ada ", all_commands
, gdb_stdout
);
14165 /* Implement the "show ada" prefix command. */
14168 show_ada_command (const char *args
, int from_tty
)
14170 cmd_show_list (show_ada_list
, from_tty
, "");
14174 initialize_ada_catchpoint_ops (void)
14176 struct breakpoint_ops
*ops
;
14178 initialize_breakpoint_ops ();
14180 ops
= &catch_exception_breakpoint_ops
;
14181 *ops
= bkpt_breakpoint_ops
;
14182 ops
->allocate_location
= allocate_location_exception
;
14183 ops
->re_set
= re_set_exception
;
14184 ops
->check_status
= check_status_exception
;
14185 ops
->print_it
= print_it_exception
;
14186 ops
->print_one
= print_one_exception
;
14187 ops
->print_mention
= print_mention_exception
;
14188 ops
->print_recreate
= print_recreate_exception
;
14190 ops
= &catch_exception_unhandled_breakpoint_ops
;
14191 *ops
= bkpt_breakpoint_ops
;
14192 ops
->allocate_location
= allocate_location_exception
;
14193 ops
->re_set
= re_set_exception
;
14194 ops
->check_status
= check_status_exception
;
14195 ops
->print_it
= print_it_exception
;
14196 ops
->print_one
= print_one_exception
;
14197 ops
->print_mention
= print_mention_exception
;
14198 ops
->print_recreate
= print_recreate_exception
;
14200 ops
= &catch_assert_breakpoint_ops
;
14201 *ops
= bkpt_breakpoint_ops
;
14202 ops
->allocate_location
= allocate_location_exception
;
14203 ops
->re_set
= re_set_exception
;
14204 ops
->check_status
= check_status_exception
;
14205 ops
->print_it
= print_it_exception
;
14206 ops
->print_one
= print_one_exception
;
14207 ops
->print_mention
= print_mention_exception
;
14208 ops
->print_recreate
= print_recreate_exception
;
14210 ops
= &catch_handlers_breakpoint_ops
;
14211 *ops
= bkpt_breakpoint_ops
;
14212 ops
->allocate_location
= allocate_location_exception
;
14213 ops
->re_set
= re_set_exception
;
14214 ops
->check_status
= check_status_exception
;
14215 ops
->print_it
= print_it_exception
;
14216 ops
->print_one
= print_one_exception
;
14217 ops
->print_mention
= print_mention_exception
;
14218 ops
->print_recreate
= print_recreate_exception
;
14221 /* This module's 'new_objfile' observer. */
14224 ada_new_objfile_observer (struct objfile
*objfile
)
14226 ada_clear_symbol_cache ();
14229 /* This module's 'free_objfile' observer. */
14232 ada_free_objfile_observer (struct objfile
*objfile
)
14234 ada_clear_symbol_cache ();
14238 _initialize_ada_language (void)
14240 initialize_ada_catchpoint_ops ();
14242 add_prefix_cmd ("ada", no_class
, set_ada_command
,
14243 _("Prefix command for changing Ada-specific settings."),
14244 &set_ada_list
, "set ada ", 0, &setlist
);
14246 add_prefix_cmd ("ada", no_class
, show_ada_command
,
14247 _("Generic command for showing Ada-specific settings."),
14248 &show_ada_list
, "show ada ", 0, &showlist
);
14250 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14251 &trust_pad_over_xvs
, _("\
14252 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14253 Show whether an optimization trusting PAD types over XVS types is activated."),
14255 This is related to the encoding used by the GNAT compiler. The debugger\n\
14256 should normally trust the contents of PAD types, but certain older versions\n\
14257 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14258 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14259 work around this bug. It is always safe to turn this option \"off\", but\n\
14260 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14261 this option to \"off\" unless necessary."),
14262 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14264 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14265 &print_signatures
, _("\
14266 Enable or disable the output of formal and return types for functions in the \
14267 overloads selection menu."), _("\
14268 Show whether the output of formal and return types for functions in the \
14269 overloads selection menu is activated."),
14270 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14272 add_catch_command ("exception", _("\
14273 Catch Ada exceptions, when raised.\n\
14274 Usage: catch exception [ARG] [if CONDITION]\n\
14275 Without any argument, stop when any Ada exception is raised.\n\
14276 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14277 being raised does not have a handler (and will therefore lead to the task's\n\
14279 Otherwise, the catchpoint only stops when the name of the exception being\n\
14280 raised is the same as ARG.\n\
14281 CONDITION is a boolean expression that is evaluated to see whether the\n\
14282 exception should cause a stop."),
14283 catch_ada_exception_command
,
14284 catch_ada_completer
,
14288 add_catch_command ("handlers", _("\
14289 Catch Ada exceptions, when handled.\n\
14290 Usage: catch handlers [ARG] [if CONDITION]\n\
14291 Without any argument, stop when any Ada exception is handled.\n\
14292 With an argument, catch only exceptions with the given name.\n\
14293 CONDITION is a boolean expression that is evaluated to see whether the\n\
14294 exception should cause a stop."),
14295 catch_ada_handlers_command
,
14296 catch_ada_completer
,
14299 add_catch_command ("assert", _("\
14300 Catch failed Ada assertions, when raised.\n\
14301 Usage: catch assert [if CONDITION]\n\
14302 CONDITION is a boolean expression that is evaluated to see whether the\n\
14303 exception should cause a stop."),
14304 catch_assert_command
,
14309 varsize_limit
= 65536;
14310 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14311 &varsize_limit
, _("\
14312 Set the maximum number of bytes allowed in a variable-size object."), _("\
14313 Show the maximum number of bytes allowed in a variable-size object."), _("\
14314 Attempts to access an object whose size is not a compile-time constant\n\
14315 and exceeds this limit will cause an error."),
14316 NULL
, NULL
, &setlist
, &showlist
);
14318 add_info ("exceptions", info_exceptions_command
,
14320 List all Ada exception names.\n\
14321 Usage: info exceptions [REGEXP]\n\
14322 If a regular expression is passed as an argument, only those matching\n\
14323 the regular expression are listed."));
14325 add_prefix_cmd ("ada", class_maintenance
, maint_set_ada_cmd
,
14326 _("Set Ada maintenance-related variables."),
14327 &maint_set_ada_cmdlist
, "maintenance set ada ",
14328 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14330 add_prefix_cmd ("ada", class_maintenance
, maint_show_ada_cmd
,
14331 _("Show Ada maintenance-related variables."),
14332 &maint_show_ada_cmdlist
, "maintenance show ada ",
14333 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14335 add_setshow_boolean_cmd
14336 ("ignore-descriptive-types", class_maintenance
,
14337 &ada_ignore_descriptive_types_p
,
14338 _("Set whether descriptive types generated by GNAT should be ignored."),
14339 _("Show whether descriptive types generated by GNAT should be ignored."),
14341 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14342 DWARF attribute."),
14343 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14345 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14346 NULL
, xcalloc
, xfree
);
14348 /* The ada-lang observers. */
14349 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14350 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14351 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);