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"
52 #include "common/vec.h"
54 #include "common/gdb_vecs.h"
55 #include "typeprint.h"
56 #include "namespace.h"
60 #include "mi/mi-common.h"
61 #include "arch-utils.h"
62 #include "cli/cli-utils.h"
63 #include "common/function-view.h"
64 #include "common/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 enum ada_renaming_category
parse_old_style_renaming (struct type
*,
154 static struct symbol
*find_old_style_renaming_symbol (const char *,
155 const struct block
*);
157 static struct type
*ada_lookup_struct_elt_type (struct type
*, const char *,
160 static struct value
*evaluate_subexp_type (struct expression
*, int *);
162 static struct type
*ada_find_parallel_type_with_name (struct type
*,
165 static int is_dynamic_field (struct type
*, int);
167 static struct type
*to_fixed_variant_branch_type (struct type
*,
169 CORE_ADDR
, struct value
*);
171 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
173 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
175 static struct type
*to_static_fixed_type (struct type
*);
176 static struct type
*static_unwrap_type (struct type
*type
);
178 static struct value
*unwrap_value (struct value
*);
180 static struct type
*constrained_packed_array_type (struct type
*, long *);
182 static struct type
*decode_constrained_packed_array_type (struct type
*);
184 static long decode_packed_array_bitsize (struct type
*);
186 static struct value
*decode_constrained_packed_array (struct value
*);
188 static int ada_is_packed_array_type (struct type
*);
190 static int ada_is_unconstrained_packed_array_type (struct type
*);
192 static struct value
*value_subscript_packed (struct value
*, int,
195 static struct value
*coerce_unspec_val_to_type (struct value
*,
198 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
200 static int equiv_types (struct type
*, struct type
*);
202 static int is_name_suffix (const char *);
204 static int advance_wild_match (const char **, const char *, int);
206 static bool wild_match (const char *name
, const char *patn
);
208 static struct value
*ada_coerce_ref (struct value
*);
210 static LONGEST
pos_atr (struct value
*);
212 static struct value
*value_pos_atr (struct type
*, struct value
*);
214 static struct value
*value_val_atr (struct type
*, struct value
*);
216 static struct symbol
*standard_lookup (const char *, const struct block
*,
219 static struct value
*ada_search_struct_field (const char *, struct value
*, int,
222 static struct value
*ada_value_primitive_field (struct value
*, int, int,
225 static int find_struct_field (const char *, struct type
*, int,
226 struct type
**, int *, int *, int *, int *);
228 static int ada_resolve_function (struct block_symbol
*, int,
229 struct value
**, int, const char *,
232 static int ada_is_direct_array_type (struct type
*);
234 static void ada_language_arch_info (struct gdbarch
*,
235 struct language_arch_info
*);
237 static struct value
*ada_index_struct_field (int, struct value
*, int,
240 static struct value
*assign_aggregate (struct value
*, struct value
*,
244 static void aggregate_assign_from_choices (struct value
*, struct value
*,
246 int *, LONGEST
*, int *,
247 int, LONGEST
, LONGEST
);
249 static void aggregate_assign_positional (struct value
*, struct value
*,
251 int *, LONGEST
*, int *, int,
255 static void aggregate_assign_others (struct value
*, struct value
*,
257 int *, LONGEST
*, int, LONGEST
, LONGEST
);
260 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
263 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
266 static void ada_forward_operator_length (struct expression
*, int, int *,
269 static struct type
*ada_find_any_type (const char *name
);
271 static symbol_name_matcher_ftype
*ada_get_symbol_name_matcher
272 (const lookup_name_info
&lookup_name
);
276 /* The result of a symbol lookup to be stored in our symbol cache. */
280 /* The name used to perform the lookup. */
282 /* The namespace used during the lookup. */
284 /* The symbol returned by the lookup, or NULL if no matching symbol
287 /* The block where the symbol was found, or NULL if no matching
289 const struct block
*block
;
290 /* A pointer to the next entry with the same hash. */
291 struct cache_entry
*next
;
294 /* The Ada symbol cache, used to store the result of Ada-mode symbol
295 lookups in the course of executing the user's commands.
297 The cache is implemented using a simple, fixed-sized hash.
298 The size is fixed on the grounds that there are not likely to be
299 all that many symbols looked up during any given session, regardless
300 of the size of the symbol table. If we decide to go to a resizable
301 table, let's just use the stuff from libiberty instead. */
303 #define HASH_SIZE 1009
305 struct ada_symbol_cache
307 /* An obstack used to store the entries in our cache. */
308 struct obstack cache_space
;
310 /* The root of the hash table used to implement our symbol cache. */
311 struct cache_entry
*root
[HASH_SIZE
];
314 static void ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
);
316 /* Maximum-sized dynamic type. */
317 static unsigned int varsize_limit
;
319 static const char ada_completer_word_break_characters
[] =
321 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
323 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
326 /* The name of the symbol to use to get the name of the main subprogram. */
327 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
328 = "__gnat_ada_main_program_name";
330 /* Limit on the number of warnings to raise per expression evaluation. */
331 static int warning_limit
= 2;
333 /* Number of warning messages issued; reset to 0 by cleanups after
334 expression evaluation. */
335 static int warnings_issued
= 0;
337 static const char *known_runtime_file_name_patterns
[] = {
338 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
341 static const char *known_auxiliary_function_name_patterns
[] = {
342 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
345 /* Maintenance-related settings for this module. */
347 static struct cmd_list_element
*maint_set_ada_cmdlist
;
348 static struct cmd_list_element
*maint_show_ada_cmdlist
;
350 /* Implement the "maintenance set ada" (prefix) command. */
353 maint_set_ada_cmd (const char *args
, int from_tty
)
355 help_list (maint_set_ada_cmdlist
, "maintenance set ada ", all_commands
,
359 /* Implement the "maintenance show ada" (prefix) command. */
362 maint_show_ada_cmd (const char *args
, int from_tty
)
364 cmd_show_list (maint_show_ada_cmdlist
, from_tty
, "");
367 /* The "maintenance ada set/show ignore-descriptive-type" value. */
369 static int ada_ignore_descriptive_types_p
= 0;
371 /* Inferior-specific data. */
373 /* Per-inferior data for this module. */
375 struct ada_inferior_data
377 /* The ada__tags__type_specific_data type, which is used when decoding
378 tagged types. With older versions of GNAT, this type was directly
379 accessible through a component ("tsd") in the object tag. But this
380 is no longer the case, so we cache it for each inferior. */
381 struct type
*tsd_type
= nullptr;
383 /* The exception_support_info data. This data is used to determine
384 how to implement support for Ada exception catchpoints in a given
386 const struct exception_support_info
*exception_info
= nullptr;
389 /* Our key to this module's inferior data. */
390 static const struct inferior_key
<ada_inferior_data
> ada_inferior_data
;
392 /* Return our inferior data for the given inferior (INF).
394 This function always returns a valid pointer to an allocated
395 ada_inferior_data structure. If INF's inferior data has not
396 been previously set, this functions creates a new one with all
397 fields set to zero, sets INF's inferior to it, and then returns
398 a pointer to that newly allocated ada_inferior_data. */
400 static struct ada_inferior_data
*
401 get_ada_inferior_data (struct inferior
*inf
)
403 struct ada_inferior_data
*data
;
405 data
= ada_inferior_data
.get (inf
);
407 data
= ada_inferior_data
.emplace (inf
);
412 /* Perform all necessary cleanups regarding our module's inferior data
413 that is required after the inferior INF just exited. */
416 ada_inferior_exit (struct inferior
*inf
)
418 ada_inferior_data
.clear (inf
);
422 /* program-space-specific data. */
424 /* This module's per-program-space data. */
425 struct ada_pspace_data
429 if (sym_cache
!= NULL
)
430 ada_free_symbol_cache (sym_cache
);
433 /* The Ada symbol cache. */
434 struct ada_symbol_cache
*sym_cache
= nullptr;
437 /* Key to our per-program-space data. */
438 static const struct program_space_key
<ada_pspace_data
> ada_pspace_data_handle
;
440 /* Return this module's data for the given program space (PSPACE).
441 If not is found, add a zero'ed one now.
443 This function always returns a valid object. */
445 static struct ada_pspace_data
*
446 get_ada_pspace_data (struct program_space
*pspace
)
448 struct ada_pspace_data
*data
;
450 data
= ada_pspace_data_handle
.get (pspace
);
452 data
= ada_pspace_data_handle
.emplace (pspace
);
459 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
460 all typedef layers have been peeled. Otherwise, return TYPE.
462 Normally, we really expect a typedef type to only have 1 typedef layer.
463 In other words, we really expect the target type of a typedef type to be
464 a non-typedef type. This is particularly true for Ada units, because
465 the language does not have a typedef vs not-typedef distinction.
466 In that respect, the Ada compiler has been trying to eliminate as many
467 typedef definitions in the debugging information, since they generally
468 do not bring any extra information (we still use typedef under certain
469 circumstances related mostly to the GNAT encoding).
471 Unfortunately, we have seen situations where the debugging information
472 generated by the compiler leads to such multiple typedef layers. For
473 instance, consider the following example with stabs:
475 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
476 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
478 This is an error in the debugging information which causes type
479 pck__float_array___XUP to be defined twice, and the second time,
480 it is defined as a typedef of a typedef.
482 This is on the fringe of legality as far as debugging information is
483 concerned, and certainly unexpected. But it is easy to handle these
484 situations correctly, so we can afford to be lenient in this case. */
487 ada_typedef_target_type (struct type
*type
)
489 while (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
490 type
= TYPE_TARGET_TYPE (type
);
494 /* Given DECODED_NAME a string holding a symbol name in its
495 decoded form (ie using the Ada dotted notation), returns
496 its unqualified name. */
499 ada_unqualified_name (const char *decoded_name
)
503 /* If the decoded name starts with '<', it means that the encoded
504 name does not follow standard naming conventions, and thus that
505 it is not your typical Ada symbol name. Trying to unqualify it
506 is therefore pointless and possibly erroneous. */
507 if (decoded_name
[0] == '<')
510 result
= strrchr (decoded_name
, '.');
512 result
++; /* Skip the dot... */
514 result
= decoded_name
;
519 /* Return a string starting with '<', followed by STR, and '>'. */
522 add_angle_brackets (const char *str
)
524 return string_printf ("<%s>", str
);
528 ada_get_gdb_completer_word_break_characters (void)
530 return ada_completer_word_break_characters
;
533 /* Print an array element index using the Ada syntax. */
536 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
537 const struct value_print_options
*options
)
539 LA_VALUE_PRINT (index_value
, stream
, options
);
540 fprintf_filtered (stream
, " => ");
543 /* la_watch_location_expression for Ada. */
545 gdb::unique_xmalloc_ptr
<char>
546 ada_watch_location_expression (struct type
*type
, CORE_ADDR addr
)
548 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
549 std::string name
= type_to_string (type
);
550 return gdb::unique_xmalloc_ptr
<char>
551 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
554 /* Assuming VECT points to an array of *SIZE objects of size
555 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
556 updating *SIZE as necessary and returning the (new) array. */
559 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
561 if (*size
< min_size
)
564 if (*size
< min_size
)
566 vect
= xrealloc (vect
, *size
* element_size
);
571 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
572 suffix of FIELD_NAME beginning "___". */
575 field_name_match (const char *field_name
, const char *target
)
577 int len
= strlen (target
);
580 (strncmp (field_name
, target
, len
) == 0
581 && (field_name
[len
] == '\0'
582 || (startswith (field_name
+ len
, "___")
583 && strcmp (field_name
+ strlen (field_name
) - 6,
588 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
589 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
590 and return its index. This function also handles fields whose name
591 have ___ suffixes because the compiler sometimes alters their name
592 by adding such a suffix to represent fields with certain constraints.
593 If the field could not be found, return a negative number if
594 MAYBE_MISSING is set. Otherwise raise an error. */
597 ada_get_field_index (const struct type
*type
, const char *field_name
,
601 struct type
*struct_type
= check_typedef ((struct type
*) type
);
603 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (struct_type
); fieldno
++)
604 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
608 error (_("Unable to find field %s in struct %s. Aborting"),
609 field_name
, TYPE_NAME (struct_type
));
614 /* The length of the prefix of NAME prior to any "___" suffix. */
617 ada_name_prefix_len (const char *name
)
623 const char *p
= strstr (name
, "___");
626 return strlen (name
);
632 /* Return non-zero if SUFFIX is a suffix of STR.
633 Return zero if STR is null. */
636 is_suffix (const char *str
, const char *suffix
)
643 len2
= strlen (suffix
);
644 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
647 /* The contents of value VAL, treated as a value of type TYPE. The
648 result is an lval in memory if VAL is. */
650 static struct value
*
651 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
653 type
= ada_check_typedef (type
);
654 if (value_type (val
) == type
)
658 struct value
*result
;
660 /* Make sure that the object size is not unreasonable before
661 trying to allocate some memory for it. */
662 ada_ensure_varsize_limit (type
);
665 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
666 result
= allocate_value_lazy (type
);
669 result
= allocate_value (type
);
670 value_contents_copy_raw (result
, 0, val
, 0, TYPE_LENGTH (type
));
672 set_value_component_location (result
, val
);
673 set_value_bitsize (result
, value_bitsize (val
));
674 set_value_bitpos (result
, value_bitpos (val
));
675 set_value_address (result
, value_address (val
));
680 static const gdb_byte
*
681 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
686 return valaddr
+ offset
;
690 cond_offset_target (CORE_ADDR address
, long offset
)
695 return address
+ offset
;
698 /* Issue a warning (as for the definition of warning in utils.c, but
699 with exactly one argument rather than ...), unless the limit on the
700 number of warnings has passed during the evaluation of the current
703 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
704 provided by "complaint". */
705 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
708 lim_warning (const char *format
, ...)
712 va_start (args
, format
);
713 warnings_issued
+= 1;
714 if (warnings_issued
<= warning_limit
)
715 vwarning (format
, args
);
720 /* Issue an error if the size of an object of type T is unreasonable,
721 i.e. if it would be a bad idea to allocate a value of this type in
725 ada_ensure_varsize_limit (const struct type
*type
)
727 if (TYPE_LENGTH (type
) > varsize_limit
)
728 error (_("object size is larger than varsize-limit"));
731 /* Maximum value of a SIZE-byte signed integer type. */
733 max_of_size (int size
)
735 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
737 return top_bit
| (top_bit
- 1);
740 /* Minimum value of a SIZE-byte signed integer type. */
742 min_of_size (int size
)
744 return -max_of_size (size
) - 1;
747 /* Maximum value of a SIZE-byte unsigned integer type. */
749 umax_of_size (int size
)
751 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
753 return top_bit
| (top_bit
- 1);
756 /* Maximum value of integral type T, as a signed quantity. */
758 max_of_type (struct type
*t
)
760 if (TYPE_UNSIGNED (t
))
761 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
763 return max_of_size (TYPE_LENGTH (t
));
766 /* Minimum value of integral type T, as a signed quantity. */
768 min_of_type (struct type
*t
)
770 if (TYPE_UNSIGNED (t
))
773 return min_of_size (TYPE_LENGTH (t
));
776 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
778 ada_discrete_type_high_bound (struct type
*type
)
780 type
= resolve_dynamic_type (type
, NULL
, 0);
781 switch (TYPE_CODE (type
))
783 case TYPE_CODE_RANGE
:
784 return TYPE_HIGH_BOUND (type
);
786 return TYPE_FIELD_ENUMVAL (type
, TYPE_NFIELDS (type
) - 1);
791 return max_of_type (type
);
793 error (_("Unexpected type in ada_discrete_type_high_bound."));
797 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
799 ada_discrete_type_low_bound (struct type
*type
)
801 type
= resolve_dynamic_type (type
, NULL
, 0);
802 switch (TYPE_CODE (type
))
804 case TYPE_CODE_RANGE
:
805 return TYPE_LOW_BOUND (type
);
807 return TYPE_FIELD_ENUMVAL (type
, 0);
812 return min_of_type (type
);
814 error (_("Unexpected type in ada_discrete_type_low_bound."));
818 /* The identity on non-range types. For range types, the underlying
819 non-range scalar type. */
822 get_base_type (struct type
*type
)
824 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
826 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
828 type
= TYPE_TARGET_TYPE (type
);
833 /* Return a decoded version of the given VALUE. This means returning
834 a value whose type is obtained by applying all the GNAT-specific
835 encondings, making the resulting type a static but standard description
836 of the initial type. */
839 ada_get_decoded_value (struct value
*value
)
841 struct type
*type
= ada_check_typedef (value_type (value
));
843 if (ada_is_array_descriptor_type (type
)
844 || (ada_is_constrained_packed_array_type (type
)
845 && TYPE_CODE (type
) != TYPE_CODE_PTR
))
847 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
) /* array access type. */
848 value
= ada_coerce_to_simple_array_ptr (value
);
850 value
= ada_coerce_to_simple_array (value
);
853 value
= ada_to_fixed_value (value
);
858 /* Same as ada_get_decoded_value, but with the given TYPE.
859 Because there is no associated actual value for this type,
860 the resulting type might be a best-effort approximation in
861 the case of dynamic types. */
864 ada_get_decoded_type (struct type
*type
)
866 type
= to_static_fixed_type (type
);
867 if (ada_is_constrained_packed_array_type (type
))
868 type
= ada_coerce_to_simple_array_type (type
);
874 /* Language Selection */
876 /* If the main program is in Ada, return language_ada, otherwise return LANG
877 (the main program is in Ada iif the adainit symbol is found). */
880 ada_update_initial_language (enum language lang
)
882 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
883 (struct objfile
*) NULL
).minsym
!= NULL
)
889 /* If the main procedure is written in Ada, then return its name.
890 The result is good until the next call. Return NULL if the main
891 procedure doesn't appear to be in Ada. */
896 struct bound_minimal_symbol msym
;
897 static gdb::unique_xmalloc_ptr
<char> main_program_name
;
899 /* For Ada, the name of the main procedure is stored in a specific
900 string constant, generated by the binder. Look for that symbol,
901 extract its address, and then read that string. If we didn't find
902 that string, then most probably the main procedure is not written
904 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
906 if (msym
.minsym
!= NULL
)
908 CORE_ADDR main_program_name_addr
;
911 main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
912 if (main_program_name_addr
== 0)
913 error (_("Invalid address for Ada main program name."));
915 target_read_string (main_program_name_addr
, &main_program_name
,
920 return main_program_name
.get ();
923 /* The main procedure doesn't seem to be in Ada. */
929 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
932 const struct ada_opname_map ada_opname_table
[] = {
933 {"Oadd", "\"+\"", BINOP_ADD
},
934 {"Osubtract", "\"-\"", BINOP_SUB
},
935 {"Omultiply", "\"*\"", BINOP_MUL
},
936 {"Odivide", "\"/\"", BINOP_DIV
},
937 {"Omod", "\"mod\"", BINOP_MOD
},
938 {"Orem", "\"rem\"", BINOP_REM
},
939 {"Oexpon", "\"**\"", BINOP_EXP
},
940 {"Olt", "\"<\"", BINOP_LESS
},
941 {"Ole", "\"<=\"", BINOP_LEQ
},
942 {"Ogt", "\">\"", BINOP_GTR
},
943 {"Oge", "\">=\"", BINOP_GEQ
},
944 {"Oeq", "\"=\"", BINOP_EQUAL
},
945 {"One", "\"/=\"", BINOP_NOTEQUAL
},
946 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
947 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
948 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
949 {"Oconcat", "\"&\"", BINOP_CONCAT
},
950 {"Oabs", "\"abs\"", UNOP_ABS
},
951 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
952 {"Oadd", "\"+\"", UNOP_PLUS
},
953 {"Osubtract", "\"-\"", UNOP_NEG
},
957 /* The "encoded" form of DECODED, according to GNAT conventions. The
958 result is valid until the next call to ada_encode. If
959 THROW_ERRORS, throw an error if invalid operator name is found.
960 Otherwise, return NULL in that case. */
963 ada_encode_1 (const char *decoded
, bool throw_errors
)
965 static char *encoding_buffer
= NULL
;
966 static size_t encoding_buffer_size
= 0;
973 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
974 2 * strlen (decoded
) + 10);
977 for (p
= decoded
; *p
!= '\0'; p
+= 1)
981 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
986 const struct ada_opname_map
*mapping
;
988 for (mapping
= ada_opname_table
;
989 mapping
->encoded
!= NULL
990 && !startswith (p
, mapping
->decoded
); mapping
+= 1)
992 if (mapping
->encoded
== NULL
)
995 error (_("invalid Ada operator name: %s"), p
);
999 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
1000 k
+= strlen (mapping
->encoded
);
1005 encoding_buffer
[k
] = *p
;
1010 encoding_buffer
[k
] = '\0';
1011 return encoding_buffer
;
1014 /* The "encoded" form of DECODED, according to GNAT conventions.
1015 The result is valid until the next call to ada_encode. */
1018 ada_encode (const char *decoded
)
1020 return ada_encode_1 (decoded
, true);
1023 /* Return NAME folded to lower case, or, if surrounded by single
1024 quotes, unfolded, but with the quotes stripped away. Result good
1028 ada_fold_name (const char *name
)
1030 static char *fold_buffer
= NULL
;
1031 static size_t fold_buffer_size
= 0;
1033 int len
= strlen (name
);
1034 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
1036 if (name
[0] == '\'')
1038 strncpy (fold_buffer
, name
+ 1, len
- 2);
1039 fold_buffer
[len
- 2] = '\000';
1045 for (i
= 0; i
<= len
; i
+= 1)
1046 fold_buffer
[i
] = tolower (name
[i
]);
1052 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1055 is_lower_alphanum (const char c
)
1057 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1060 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1061 This function saves in LEN the length of that same symbol name but
1062 without either of these suffixes:
1068 These are suffixes introduced by the compiler for entities such as
1069 nested subprogram for instance, in order to avoid name clashes.
1070 They do not serve any purpose for the debugger. */
1073 ada_remove_trailing_digits (const char *encoded
, int *len
)
1075 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1079 while (i
> 0 && isdigit (encoded
[i
]))
1081 if (i
>= 0 && encoded
[i
] == '.')
1083 else if (i
>= 0 && encoded
[i
] == '$')
1085 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
1087 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
1092 /* Remove the suffix introduced by the compiler for protected object
1096 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1098 /* Remove trailing N. */
1100 /* Protected entry subprograms are broken into two
1101 separate subprograms: The first one is unprotected, and has
1102 a 'N' suffix; the second is the protected version, and has
1103 the 'P' suffix. The second calls the first one after handling
1104 the protection. Since the P subprograms are internally generated,
1105 we leave these names undecoded, giving the user a clue that this
1106 entity is internal. */
1109 && encoded
[*len
- 1] == 'N'
1110 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1114 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1117 ada_remove_Xbn_suffix (const char *encoded
, int *len
)
1121 while (i
> 0 && (encoded
[i
] == 'b' || encoded
[i
] == 'n'))
1124 if (encoded
[i
] != 'X')
1130 if (isalnum (encoded
[i
-1]))
1134 /* If ENCODED follows the GNAT entity encoding conventions, then return
1135 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1136 replaced by ENCODED.
1138 The resulting string is valid until the next call of ada_decode.
1139 If the string is unchanged by decoding, the original string pointer
1143 ada_decode (const char *encoded
)
1150 static char *decoding_buffer
= NULL
;
1151 static size_t decoding_buffer_size
= 0;
1153 /* With function descriptors on PPC64, the value of a symbol named
1154 ".FN", if it exists, is the entry point of the function "FN". */
1155 if (encoded
[0] == '.')
1158 /* The name of the Ada main procedure starts with "_ada_".
1159 This prefix is not part of the decoded name, so skip this part
1160 if we see this prefix. */
1161 if (startswith (encoded
, "_ada_"))
1164 /* If the name starts with '_', then it is not a properly encoded
1165 name, so do not attempt to decode it. Similarly, if the name
1166 starts with '<', the name should not be decoded. */
1167 if (encoded
[0] == '_' || encoded
[0] == '<')
1170 len0
= strlen (encoded
);
1172 ada_remove_trailing_digits (encoded
, &len0
);
1173 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1175 /* Remove the ___X.* suffix if present. Do not forget to verify that
1176 the suffix is located before the current "end" of ENCODED. We want
1177 to avoid re-matching parts of ENCODED that have previously been
1178 marked as discarded (by decrementing LEN0). */
1179 p
= strstr (encoded
, "___");
1180 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1188 /* Remove any trailing TKB suffix. It tells us that this symbol
1189 is for the body of a task, but that information does not actually
1190 appear in the decoded name. */
1192 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1195 /* Remove any trailing TB suffix. The TB suffix is slightly different
1196 from the TKB suffix because it is used for non-anonymous task
1199 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1202 /* Remove trailing "B" suffixes. */
1203 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1205 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1208 /* Make decoded big enough for possible expansion by operator name. */
1210 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
1211 decoded
= decoding_buffer
;
1213 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1215 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1218 while ((i
>= 0 && isdigit (encoded
[i
]))
1219 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1221 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1223 else if (encoded
[i
] == '$')
1227 /* The first few characters that are not alphabetic are not part
1228 of any encoding we use, so we can copy them over verbatim. */
1230 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1231 decoded
[j
] = encoded
[i
];
1236 /* Is this a symbol function? */
1237 if (at_start_name
&& encoded
[i
] == 'O')
1241 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1243 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1244 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1246 && !isalnum (encoded
[i
+ op_len
]))
1248 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1251 j
+= strlen (ada_opname_table
[k
].decoded
);
1255 if (ada_opname_table
[k
].encoded
!= NULL
)
1260 /* Replace "TK__" with "__", which will eventually be translated
1261 into "." (just below). */
1263 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1266 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1267 be translated into "." (just below). These are internal names
1268 generated for anonymous blocks inside which our symbol is nested. */
1270 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1271 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1272 && isdigit (encoded
[i
+4]))
1276 while (k
< len0
&& isdigit (encoded
[k
]))
1277 k
++; /* Skip any extra digit. */
1279 /* Double-check that the "__B_{DIGITS}+" sequence we found
1280 is indeed followed by "__". */
1281 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1285 /* Remove _E{DIGITS}+[sb] */
1287 /* Just as for protected object subprograms, there are 2 categories
1288 of subprograms created by the compiler for each entry. The first
1289 one implements the actual entry code, and has a suffix following
1290 the convention above; the second one implements the barrier and
1291 uses the same convention as above, except that the 'E' is replaced
1294 Just as above, we do not decode the name of barrier functions
1295 to give the user a clue that the code he is debugging has been
1296 internally generated. */
1298 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1299 && isdigit (encoded
[i
+2]))
1303 while (k
< len0
&& isdigit (encoded
[k
]))
1307 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1310 /* Just as an extra precaution, make sure that if this
1311 suffix is followed by anything else, it is a '_'.
1312 Otherwise, we matched this sequence by accident. */
1314 || (k
< len0
&& encoded
[k
] == '_'))
1319 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1320 the GNAT front-end in protected object subprograms. */
1323 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1325 /* Backtrack a bit up until we reach either the begining of
1326 the encoded name, or "__". Make sure that we only find
1327 digits or lowercase characters. */
1328 const char *ptr
= encoded
+ i
- 1;
1330 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1333 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1337 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1339 /* This is a X[bn]* sequence not separated from the previous
1340 part of the name with a non-alpha-numeric character (in other
1341 words, immediately following an alpha-numeric character), then
1342 verify that it is placed at the end of the encoded name. If
1343 not, then the encoding is not valid and we should abort the
1344 decoding. Otherwise, just skip it, it is used in body-nested
1348 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1352 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1354 /* Replace '__' by '.'. */
1362 /* It's a character part of the decoded name, so just copy it
1364 decoded
[j
] = encoded
[i
];
1369 decoded
[j
] = '\000';
1371 /* Decoded names should never contain any uppercase character.
1372 Double-check this, and abort the decoding if we find one. */
1374 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1375 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1378 if (strcmp (decoded
, encoded
) == 0)
1384 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1385 decoded
= decoding_buffer
;
1386 if (encoded
[0] == '<')
1387 strcpy (decoded
, encoded
);
1389 xsnprintf (decoded
, decoding_buffer_size
, "<%s>", encoded
);
1394 /* Table for keeping permanent unique copies of decoded names. Once
1395 allocated, names in this table are never released. While this is a
1396 storage leak, it should not be significant unless there are massive
1397 changes in the set of decoded names in successive versions of a
1398 symbol table loaded during a single session. */
1399 static struct htab
*decoded_names_store
;
1401 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1402 in the language-specific part of GSYMBOL, if it has not been
1403 previously computed. Tries to save the decoded name in the same
1404 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1405 in any case, the decoded symbol has a lifetime at least that of
1407 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1408 const, but nevertheless modified to a semantically equivalent form
1409 when a decoded name is cached in it. */
1412 ada_decode_symbol (const struct general_symbol_info
*arg
)
1414 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1415 const char **resultp
=
1416 &gsymbol
->language_specific
.demangled_name
;
1418 if (!gsymbol
->ada_mangled
)
1420 const char *decoded
= ada_decode (gsymbol
->name
);
1421 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1423 gsymbol
->ada_mangled
= 1;
1425 if (obstack
!= NULL
)
1427 = (const char *) obstack_copy0 (obstack
, decoded
, strlen (decoded
));
1430 /* Sometimes, we can't find a corresponding objfile, in
1431 which case, we put the result on the heap. Since we only
1432 decode when needed, we hope this usually does not cause a
1433 significant memory leak (FIXME). */
1435 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1439 *slot
= xstrdup (decoded
);
1448 ada_la_decode (const char *encoded
, int options
)
1450 return xstrdup (ada_decode (encoded
));
1453 /* Implement la_sniff_from_mangled_name for Ada. */
1456 ada_sniff_from_mangled_name (const char *mangled
, char **out
)
1458 const char *demangled
= ada_decode (mangled
);
1462 if (demangled
!= mangled
&& demangled
!= NULL
&& demangled
[0] != '<')
1464 /* Set the gsymbol language to Ada, but still return 0.
1465 Two reasons for that:
1467 1. For Ada, we prefer computing the symbol's decoded name
1468 on the fly rather than pre-compute it, in order to save
1469 memory (Ada projects are typically very large).
1471 2. There are some areas in the definition of the GNAT
1472 encoding where, with a bit of bad luck, we might be able
1473 to decode a non-Ada symbol, generating an incorrect
1474 demangled name (Eg: names ending with "TB" for instance
1475 are identified as task bodies and so stripped from
1476 the decoded name returned).
1478 Returning 1, here, but not setting *DEMANGLED, helps us get a
1479 little bit of the best of both worlds. Because we're last,
1480 we should not affect any of the other languages that were
1481 able to demangle the symbol before us; we get to correctly
1482 tag Ada symbols as such; and even if we incorrectly tagged a
1483 non-Ada symbol, which should be rare, any routing through the
1484 Ada language should be transparent (Ada tries to behave much
1485 like C/C++ with non-Ada symbols). */
1496 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1497 generated by the GNAT compiler to describe the index type used
1498 for each dimension of an array, check whether it follows the latest
1499 known encoding. If not, fix it up to conform to the latest encoding.
1500 Otherwise, do nothing. This function also does nothing if
1501 INDEX_DESC_TYPE is NULL.
1503 The GNAT encoding used to describle the array index type evolved a bit.
1504 Initially, the information would be provided through the name of each
1505 field of the structure type only, while the type of these fields was
1506 described as unspecified and irrelevant. The debugger was then expected
1507 to perform a global type lookup using the name of that field in order
1508 to get access to the full index type description. Because these global
1509 lookups can be very expensive, the encoding was later enhanced to make
1510 the global lookup unnecessary by defining the field type as being
1511 the full index type description.
1513 The purpose of this routine is to allow us to support older versions
1514 of the compiler by detecting the use of the older encoding, and by
1515 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1516 we essentially replace each field's meaningless type by the associated
1520 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1524 if (index_desc_type
== NULL
)
1526 gdb_assert (TYPE_NFIELDS (index_desc_type
) > 0);
1528 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1529 to check one field only, no need to check them all). If not, return
1532 If our INDEX_DESC_TYPE was generated using the older encoding,
1533 the field type should be a meaningless integer type whose name
1534 is not equal to the field name. */
1535 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)) != NULL
1536 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)),
1537 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1540 /* Fixup each field of INDEX_DESC_TYPE. */
1541 for (i
= 0; i
< TYPE_NFIELDS (index_desc_type
); i
++)
1543 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1544 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1547 TYPE_FIELD_TYPE (index_desc_type
, i
) = raw_type
;
1551 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1553 static const char *bound_name
[] = {
1554 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1555 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1558 /* Maximum number of array dimensions we are prepared to handle. */
1560 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1563 /* The desc_* routines return primitive portions of array descriptors
1566 /* The descriptor or array type, if any, indicated by TYPE; removes
1567 level of indirection, if needed. */
1569 static struct type
*
1570 desc_base_type (struct type
*type
)
1574 type
= ada_check_typedef (type
);
1575 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
1576 type
= ada_typedef_target_type (type
);
1579 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1580 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1581 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1586 /* True iff TYPE indicates a "thin" array pointer type. */
1589 is_thin_pntr (struct type
*type
)
1592 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1593 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1596 /* The descriptor type for thin pointer type TYPE. */
1598 static struct type
*
1599 thin_descriptor_type (struct type
*type
)
1601 struct type
*base_type
= desc_base_type (type
);
1603 if (base_type
== NULL
)
1605 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1609 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1611 if (alt_type
== NULL
)
1618 /* A pointer to the array data for thin-pointer value VAL. */
1620 static struct value
*
1621 thin_data_pntr (struct value
*val
)
1623 struct type
*type
= ada_check_typedef (value_type (val
));
1624 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1626 data_type
= lookup_pointer_type (data_type
);
1628 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1629 return value_cast (data_type
, value_copy (val
));
1631 return value_from_longest (data_type
, value_address (val
));
1634 /* True iff TYPE indicates a "thick" array pointer type. */
1637 is_thick_pntr (struct type
*type
)
1639 type
= desc_base_type (type
);
1640 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1641 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1644 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1645 pointer to one, the type of its bounds data; otherwise, NULL. */
1647 static struct type
*
1648 desc_bounds_type (struct type
*type
)
1652 type
= desc_base_type (type
);
1656 else if (is_thin_pntr (type
))
1658 type
= thin_descriptor_type (type
);
1661 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1663 return ada_check_typedef (r
);
1665 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1667 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1669 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1674 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1675 one, a pointer to its bounds data. Otherwise NULL. */
1677 static struct value
*
1678 desc_bounds (struct value
*arr
)
1680 struct type
*type
= ada_check_typedef (value_type (arr
));
1682 if (is_thin_pntr (type
))
1684 struct type
*bounds_type
=
1685 desc_bounds_type (thin_descriptor_type (type
));
1688 if (bounds_type
== NULL
)
1689 error (_("Bad GNAT array descriptor"));
1691 /* NOTE: The following calculation is not really kosher, but
1692 since desc_type is an XVE-encoded type (and shouldn't be),
1693 the correct calculation is a real pain. FIXME (and fix GCC). */
1694 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1695 addr
= value_as_long (arr
);
1697 addr
= value_address (arr
);
1700 value_from_longest (lookup_pointer_type (bounds_type
),
1701 addr
- TYPE_LENGTH (bounds_type
));
1704 else if (is_thick_pntr (type
))
1706 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1707 _("Bad GNAT array descriptor"));
1708 struct type
*p_bounds_type
= value_type (p_bounds
);
1711 && TYPE_CODE (p_bounds_type
) == TYPE_CODE_PTR
)
1713 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1715 if (TYPE_STUB (target_type
))
1716 p_bounds
= value_cast (lookup_pointer_type
1717 (ada_check_typedef (target_type
)),
1721 error (_("Bad GNAT array descriptor"));
1729 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1730 position of the field containing the address of the bounds data. */
1733 fat_pntr_bounds_bitpos (struct type
*type
)
1735 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1738 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1739 size of the field containing the address of the bounds data. */
1742 fat_pntr_bounds_bitsize (struct type
*type
)
1744 type
= desc_base_type (type
);
1746 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1747 return TYPE_FIELD_BITSIZE (type
, 1);
1749 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1752 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1753 pointer to one, the type of its array data (a array-with-no-bounds type);
1754 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1757 static struct type
*
1758 desc_data_target_type (struct type
*type
)
1760 type
= desc_base_type (type
);
1762 /* NOTE: The following is bogus; see comment in desc_bounds. */
1763 if (is_thin_pntr (type
))
1764 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1));
1765 else if (is_thick_pntr (type
))
1767 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1770 && TYPE_CODE (ada_check_typedef (data_type
)) == TYPE_CODE_PTR
)
1771 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1777 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1780 static struct value
*
1781 desc_data (struct value
*arr
)
1783 struct type
*type
= value_type (arr
);
1785 if (is_thin_pntr (type
))
1786 return thin_data_pntr (arr
);
1787 else if (is_thick_pntr (type
))
1788 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1789 _("Bad GNAT array descriptor"));
1795 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1796 position of the field containing the address of the data. */
1799 fat_pntr_data_bitpos (struct type
*type
)
1801 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1804 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1805 size of the field containing the address of the data. */
1808 fat_pntr_data_bitsize (struct type
*type
)
1810 type
= desc_base_type (type
);
1812 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1813 return TYPE_FIELD_BITSIZE (type
, 0);
1815 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1818 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1819 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1820 bound, if WHICH is 1. The first bound is I=1. */
1822 static struct value
*
1823 desc_one_bound (struct value
*bounds
, int i
, int which
)
1825 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1826 _("Bad GNAT array descriptor bounds"));
1829 /* If BOUNDS is an array-bounds structure type, return the bit position
1830 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1831 bound, if WHICH is 1. The first bound is I=1. */
1834 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1836 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1839 /* If BOUNDS is an array-bounds structure type, return the bit field size
1840 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1841 bound, if WHICH is 1. The first bound is I=1. */
1844 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1846 type
= desc_base_type (type
);
1848 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1849 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1851 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1854 /* If TYPE is the type of an array-bounds structure, the type of its
1855 Ith bound (numbering from 1). Otherwise, NULL. */
1857 static struct type
*
1858 desc_index_type (struct type
*type
, int i
)
1860 type
= desc_base_type (type
);
1862 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1863 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1868 /* The number of index positions in the array-bounds type TYPE.
1869 Return 0 if TYPE is NULL. */
1872 desc_arity (struct type
*type
)
1874 type
= desc_base_type (type
);
1877 return TYPE_NFIELDS (type
) / 2;
1881 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1882 an array descriptor type (representing an unconstrained array
1886 ada_is_direct_array_type (struct type
*type
)
1890 type
= ada_check_typedef (type
);
1891 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1892 || ada_is_array_descriptor_type (type
));
1895 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1899 ada_is_array_type (struct type
*type
)
1902 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1903 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1904 type
= TYPE_TARGET_TYPE (type
);
1905 return ada_is_direct_array_type (type
);
1908 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1911 ada_is_simple_array_type (struct type
*type
)
1915 type
= ada_check_typedef (type
);
1916 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1917 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1918 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
)))
1919 == TYPE_CODE_ARRAY
));
1922 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1925 ada_is_array_descriptor_type (struct type
*type
)
1927 struct type
*data_type
= desc_data_target_type (type
);
1931 type
= ada_check_typedef (type
);
1932 return (data_type
!= NULL
1933 && TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
1934 && desc_arity (desc_bounds_type (type
)) > 0);
1937 /* Non-zero iff type is a partially mal-formed GNAT array
1938 descriptor. FIXME: This is to compensate for some problems with
1939 debugging output from GNAT. Re-examine periodically to see if it
1943 ada_is_bogus_array_descriptor (struct type
*type
)
1947 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1948 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1949 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1950 && !ada_is_array_descriptor_type (type
);
1954 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1955 (fat pointer) returns the type of the array data described---specifically,
1956 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1957 in from the descriptor; otherwise, they are left unspecified. If
1958 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1959 returns NULL. The result is simply the type of ARR if ARR is not
1962 ada_type_of_array (struct value
*arr
, int bounds
)
1964 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1965 return decode_constrained_packed_array_type (value_type (arr
));
1967 if (!ada_is_array_descriptor_type (value_type (arr
)))
1968 return value_type (arr
);
1972 struct type
*array_type
=
1973 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1975 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1976 TYPE_FIELD_BITSIZE (array_type
, 0) =
1977 decode_packed_array_bitsize (value_type (arr
));
1983 struct type
*elt_type
;
1985 struct value
*descriptor
;
1987 elt_type
= ada_array_element_type (value_type (arr
), -1);
1988 arity
= ada_array_arity (value_type (arr
));
1990 if (elt_type
== NULL
|| arity
== 0)
1991 return ada_check_typedef (value_type (arr
));
1993 descriptor
= desc_bounds (arr
);
1994 if (value_as_long (descriptor
) == 0)
1998 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1999 struct type
*array_type
= alloc_type_copy (value_type (arr
));
2000 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
2001 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
2004 create_static_range_type (range_type
, value_type (low
),
2005 longest_to_int (value_as_long (low
)),
2006 longest_to_int (value_as_long (high
)));
2007 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
2009 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
2011 /* We need to store the element packed bitsize, as well as
2012 recompute the array size, because it was previously
2013 computed based on the unpacked element size. */
2014 LONGEST lo
= value_as_long (low
);
2015 LONGEST hi
= value_as_long (high
);
2017 TYPE_FIELD_BITSIZE (elt_type
, 0) =
2018 decode_packed_array_bitsize (value_type (arr
));
2019 /* If the array has no element, then the size is already
2020 zero, and does not need to be recomputed. */
2024 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
2026 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
2031 return lookup_pointer_type (elt_type
);
2035 /* If ARR does not represent an array, returns ARR unchanged.
2036 Otherwise, returns either a standard GDB array with bounds set
2037 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2038 GDB array. Returns NULL if ARR is a null fat pointer. */
2041 ada_coerce_to_simple_array_ptr (struct value
*arr
)
2043 if (ada_is_array_descriptor_type (value_type (arr
)))
2045 struct type
*arrType
= ada_type_of_array (arr
, 1);
2047 if (arrType
== NULL
)
2049 return value_cast (arrType
, value_copy (desc_data (arr
)));
2051 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
2052 return decode_constrained_packed_array (arr
);
2057 /* If ARR does not represent an array, returns ARR unchanged.
2058 Otherwise, returns a standard GDB array describing ARR (which may
2059 be ARR itself if it already is in the proper form). */
2062 ada_coerce_to_simple_array (struct value
*arr
)
2064 if (ada_is_array_descriptor_type (value_type (arr
)))
2066 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
2069 error (_("Bounds unavailable for null array pointer."));
2070 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
2071 return value_ind (arrVal
);
2073 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
2074 return decode_constrained_packed_array (arr
);
2079 /* If TYPE represents a GNAT array type, return it translated to an
2080 ordinary GDB array type (possibly with BITSIZE fields indicating
2081 packing). For other types, is the identity. */
2084 ada_coerce_to_simple_array_type (struct type
*type
)
2086 if (ada_is_constrained_packed_array_type (type
))
2087 return decode_constrained_packed_array_type (type
);
2089 if (ada_is_array_descriptor_type (type
))
2090 return ada_check_typedef (desc_data_target_type (type
));
2095 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2098 ada_is_packed_array_type (struct type
*type
)
2102 type
= desc_base_type (type
);
2103 type
= ada_check_typedef (type
);
2105 ada_type_name (type
) != NULL
2106 && strstr (ada_type_name (type
), "___XP") != NULL
;
2109 /* Non-zero iff TYPE represents a standard GNAT constrained
2110 packed-array type. */
2113 ada_is_constrained_packed_array_type (struct type
*type
)
2115 return ada_is_packed_array_type (type
)
2116 && !ada_is_array_descriptor_type (type
);
2119 /* Non-zero iff TYPE represents an array descriptor for a
2120 unconstrained packed-array type. */
2123 ada_is_unconstrained_packed_array_type (struct type
*type
)
2125 return ada_is_packed_array_type (type
)
2126 && ada_is_array_descriptor_type (type
);
2129 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2130 return the size of its elements in bits. */
2133 decode_packed_array_bitsize (struct type
*type
)
2135 const char *raw_name
;
2139 /* Access to arrays implemented as fat pointers are encoded as a typedef
2140 of the fat pointer type. We need the name of the fat pointer type
2141 to do the decoding, so strip the typedef layer. */
2142 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
2143 type
= ada_typedef_target_type (type
);
2145 raw_name
= ada_type_name (ada_check_typedef (type
));
2147 raw_name
= ada_type_name (desc_base_type (type
));
2152 tail
= strstr (raw_name
, "___XP");
2153 gdb_assert (tail
!= NULL
);
2155 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2158 (_("could not understand bit size information on packed array"));
2165 /* Given that TYPE is a standard GDB array type with all bounds filled
2166 in, and that the element size of its ultimate scalar constituents
2167 (that is, either its elements, or, if it is an array of arrays, its
2168 elements' elements, etc.) is *ELT_BITS, return an identical type,
2169 but with the bit sizes of its elements (and those of any
2170 constituent arrays) recorded in the BITSIZE components of its
2171 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2174 Note that, for arrays whose index type has an XA encoding where
2175 a bound references a record discriminant, getting that discriminant,
2176 and therefore the actual value of that bound, is not possible
2177 because none of the given parameters gives us access to the record.
2178 This function assumes that it is OK in the context where it is being
2179 used to return an array whose bounds are still dynamic and where
2180 the length is arbitrary. */
2182 static struct type
*
2183 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2185 struct type
*new_elt_type
;
2186 struct type
*new_type
;
2187 struct type
*index_type_desc
;
2188 struct type
*index_type
;
2189 LONGEST low_bound
, high_bound
;
2191 type
= ada_check_typedef (type
);
2192 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2195 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2196 if (index_type_desc
)
2197 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, 0),
2200 index_type
= TYPE_INDEX_TYPE (type
);
2202 new_type
= alloc_type_copy (type
);
2204 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2206 create_array_type (new_type
, new_elt_type
, index_type
);
2207 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2208 TYPE_NAME (new_type
) = ada_type_name (type
);
2210 if ((TYPE_CODE (check_typedef (index_type
)) == TYPE_CODE_RANGE
2211 && is_dynamic_type (check_typedef (index_type
)))
2212 || get_discrete_bounds (index_type
, &low_bound
, &high_bound
) < 0)
2213 low_bound
= high_bound
= 0;
2214 if (high_bound
< low_bound
)
2215 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2218 *elt_bits
*= (high_bound
- low_bound
+ 1);
2219 TYPE_LENGTH (new_type
) =
2220 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2223 TYPE_FIXED_INSTANCE (new_type
) = 1;
2227 /* The array type encoded by TYPE, where
2228 ada_is_constrained_packed_array_type (TYPE). */
2230 static struct type
*
2231 decode_constrained_packed_array_type (struct type
*type
)
2233 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2236 struct type
*shadow_type
;
2240 raw_name
= ada_type_name (desc_base_type (type
));
2245 name
= (char *) alloca (strlen (raw_name
) + 1);
2246 tail
= strstr (raw_name
, "___XP");
2247 type
= desc_base_type (type
);
2249 memcpy (name
, raw_name
, tail
- raw_name
);
2250 name
[tail
- raw_name
] = '\000';
2252 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2254 if (shadow_type
== NULL
)
2256 lim_warning (_("could not find bounds information on packed array"));
2259 shadow_type
= check_typedef (shadow_type
);
2261 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
2263 lim_warning (_("could not understand bounds "
2264 "information on packed array"));
2268 bits
= decode_packed_array_bitsize (type
);
2269 return constrained_packed_array_type (shadow_type
, &bits
);
2272 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2273 array, returns a simple array that denotes that array. Its type is a
2274 standard GDB array type except that the BITSIZEs of the array
2275 target types are set to the number of bits in each element, and the
2276 type length is set appropriately. */
2278 static struct value
*
2279 decode_constrained_packed_array (struct value
*arr
)
2283 /* If our value is a pointer, then dereference it. Likewise if
2284 the value is a reference. Make sure that this operation does not
2285 cause the target type to be fixed, as this would indirectly cause
2286 this array to be decoded. The rest of the routine assumes that
2287 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2288 and "value_ind" routines to perform the dereferencing, as opposed
2289 to using "ada_coerce_ref" or "ada_value_ind". */
2290 arr
= coerce_ref (arr
);
2291 if (TYPE_CODE (ada_check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
2292 arr
= value_ind (arr
);
2294 type
= decode_constrained_packed_array_type (value_type (arr
));
2297 error (_("can't unpack array"));
2301 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr
)))
2302 && ada_is_modular_type (value_type (arr
)))
2304 /* This is a (right-justified) modular type representing a packed
2305 array with no wrapper. In order to interpret the value through
2306 the (left-justified) packed array type we just built, we must
2307 first left-justify it. */
2308 int bit_size
, bit_pos
;
2311 mod
= ada_modulus (value_type (arr
)) - 1;
2318 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2319 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2320 bit_pos
/ HOST_CHAR_BIT
,
2321 bit_pos
% HOST_CHAR_BIT
,
2326 return coerce_unspec_val_to_type (arr
, type
);
2330 /* The value of the element of packed array ARR at the ARITY indices
2331 given in IND. ARR must be a simple array. */
2333 static struct value
*
2334 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2337 int bits
, elt_off
, bit_off
;
2338 long elt_total_bit_offset
;
2339 struct type
*elt_type
;
2343 elt_total_bit_offset
= 0;
2344 elt_type
= ada_check_typedef (value_type (arr
));
2345 for (i
= 0; i
< arity
; i
+= 1)
2347 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
2348 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2350 (_("attempt to do packed indexing of "
2351 "something other than a packed array"));
2354 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
2355 LONGEST lowerbound
, upperbound
;
2358 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2360 lim_warning (_("don't know bounds of array"));
2361 lowerbound
= upperbound
= 0;
2364 idx
= pos_atr (ind
[i
]);
2365 if (idx
< lowerbound
|| idx
> upperbound
)
2366 lim_warning (_("packed array index %ld out of bounds"),
2368 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2369 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2370 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2373 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2374 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2376 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2381 /* Non-zero iff TYPE includes negative integer values. */
2384 has_negatives (struct type
*type
)
2386 switch (TYPE_CODE (type
))
2391 return !TYPE_UNSIGNED (type
);
2392 case TYPE_CODE_RANGE
:
2393 return TYPE_LOW_BOUND (type
) < 0;
2397 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2398 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2399 the unpacked buffer.
2401 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2402 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2404 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2407 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2409 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2412 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2413 gdb_byte
*unpacked
, int unpacked_len
,
2414 int is_big_endian
, int is_signed_type
,
2417 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2418 int src_idx
; /* Index into the source area */
2419 int src_bytes_left
; /* Number of source bytes left to process. */
2420 int srcBitsLeft
; /* Number of source bits left to move */
2421 int unusedLS
; /* Number of bits in next significant
2422 byte of source that are unused */
2424 int unpacked_idx
; /* Index into the unpacked buffer */
2425 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2427 unsigned long accum
; /* Staging area for bits being transferred */
2428 int accumSize
; /* Number of meaningful bits in accum */
2431 /* Transmit bytes from least to most significant; delta is the direction
2432 the indices move. */
2433 int delta
= is_big_endian
? -1 : 1;
2435 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2437 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2438 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2439 bit_size
, unpacked_len
);
2441 srcBitsLeft
= bit_size
;
2442 src_bytes_left
= src_len
;
2443 unpacked_bytes_left
= unpacked_len
;
2448 src_idx
= src_len
- 1;
2450 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2454 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2460 unpacked_idx
= unpacked_len
- 1;
2464 /* Non-scalar values must be aligned at a byte boundary... */
2466 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2467 /* ... And are placed at the beginning (most-significant) bytes
2469 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2470 unpacked_bytes_left
= unpacked_idx
+ 1;
2475 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2477 src_idx
= unpacked_idx
= 0;
2478 unusedLS
= bit_offset
;
2481 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2486 while (src_bytes_left
> 0)
2488 /* Mask for removing bits of the next source byte that are not
2489 part of the value. */
2490 unsigned int unusedMSMask
=
2491 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2493 /* Sign-extend bits for this byte. */
2494 unsigned int signMask
= sign
& ~unusedMSMask
;
2497 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2498 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2499 if (accumSize
>= HOST_CHAR_BIT
)
2501 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2502 accumSize
-= HOST_CHAR_BIT
;
2503 accum
>>= HOST_CHAR_BIT
;
2504 unpacked_bytes_left
-= 1;
2505 unpacked_idx
+= delta
;
2507 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2509 src_bytes_left
-= 1;
2512 while (unpacked_bytes_left
> 0)
2514 accum
|= sign
<< accumSize
;
2515 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2516 accumSize
-= HOST_CHAR_BIT
;
2519 accum
>>= HOST_CHAR_BIT
;
2520 unpacked_bytes_left
-= 1;
2521 unpacked_idx
+= delta
;
2525 /* Create a new value of type TYPE from the contents of OBJ starting
2526 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2527 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2528 assigning through the result will set the field fetched from.
2529 VALADDR is ignored unless OBJ is NULL, in which case,
2530 VALADDR+OFFSET must address the start of storage containing the
2531 packed value. The value returned in this case is never an lval.
2532 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2535 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2536 long offset
, int bit_offset
, int bit_size
,
2540 const gdb_byte
*src
; /* First byte containing data to unpack */
2542 const int is_scalar
= is_scalar_type (type
);
2543 const int is_big_endian
= gdbarch_bits_big_endian (get_type_arch (type
));
2544 gdb::byte_vector staging
;
2546 type
= ada_check_typedef (type
);
2549 src
= valaddr
+ offset
;
2551 src
= value_contents (obj
) + offset
;
2553 if (is_dynamic_type (type
))
2555 /* The length of TYPE might by dynamic, so we need to resolve
2556 TYPE in order to know its actual size, which we then use
2557 to create the contents buffer of the value we return.
2558 The difficulty is that the data containing our object is
2559 packed, and therefore maybe not at a byte boundary. So, what
2560 we do, is unpack the data into a byte-aligned buffer, and then
2561 use that buffer as our object's value for resolving the type. */
2562 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2563 staging
.resize (staging_len
);
2565 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2566 staging
.data (), staging
.size (),
2567 is_big_endian
, has_negatives (type
),
2569 type
= resolve_dynamic_type (type
, staging
.data (), 0);
2570 if (TYPE_LENGTH (type
) < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2572 /* This happens when the length of the object is dynamic,
2573 and is actually smaller than the space reserved for it.
2574 For instance, in an array of variant records, the bit_size
2575 we're given is the array stride, which is constant and
2576 normally equal to the maximum size of its element.
2577 But, in reality, each element only actually spans a portion
2579 bit_size
= TYPE_LENGTH (type
) * HOST_CHAR_BIT
;
2585 v
= allocate_value (type
);
2586 src
= valaddr
+ offset
;
2588 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2590 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2593 v
= value_at (type
, value_address (obj
) + offset
);
2594 buf
= (gdb_byte
*) alloca (src_len
);
2595 read_memory (value_address (v
), buf
, src_len
);
2600 v
= allocate_value (type
);
2601 src
= value_contents (obj
) + offset
;
2606 long new_offset
= offset
;
2608 set_value_component_location (v
, obj
);
2609 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2610 set_value_bitsize (v
, bit_size
);
2611 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2614 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2616 set_value_offset (v
, new_offset
);
2618 /* Also set the parent value. This is needed when trying to
2619 assign a new value (in inferior memory). */
2620 set_value_parent (v
, obj
);
2623 set_value_bitsize (v
, bit_size
);
2624 unpacked
= value_contents_writeable (v
);
2628 memset (unpacked
, 0, TYPE_LENGTH (type
));
2632 if (staging
.size () == TYPE_LENGTH (type
))
2634 /* Small short-cut: If we've unpacked the data into a buffer
2635 of the same size as TYPE's length, then we can reuse that,
2636 instead of doing the unpacking again. */
2637 memcpy (unpacked
, staging
.data (), staging
.size ());
2640 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2641 unpacked
, TYPE_LENGTH (type
),
2642 is_big_endian
, has_negatives (type
), is_scalar
);
2647 /* Store the contents of FROMVAL into the location of TOVAL.
2648 Return a new value with the location of TOVAL and contents of
2649 FROMVAL. Handles assignment into packed fields that have
2650 floating-point or non-scalar types. */
2652 static struct value
*
2653 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2655 struct type
*type
= value_type (toval
);
2656 int bits
= value_bitsize (toval
);
2658 toval
= ada_coerce_ref (toval
);
2659 fromval
= ada_coerce_ref (fromval
);
2661 if (ada_is_direct_array_type (value_type (toval
)))
2662 toval
= ada_coerce_to_simple_array (toval
);
2663 if (ada_is_direct_array_type (value_type (fromval
)))
2664 fromval
= ada_coerce_to_simple_array (fromval
);
2666 if (!deprecated_value_modifiable (toval
))
2667 error (_("Left operand of assignment is not a modifiable lvalue."));
2669 if (VALUE_LVAL (toval
) == lval_memory
2671 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2672 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2674 int len
= (value_bitpos (toval
)
2675 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2677 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2679 CORE_ADDR to_addr
= value_address (toval
);
2681 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2682 fromval
= value_cast (type
, fromval
);
2684 read_memory (to_addr
, buffer
, len
);
2685 from_size
= value_bitsize (fromval
);
2687 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2689 const int is_big_endian
= gdbarch_bits_big_endian (get_type_arch (type
));
2690 ULONGEST from_offset
= 0;
2691 if (is_big_endian
&& is_scalar_type (value_type (fromval
)))
2692 from_offset
= from_size
- bits
;
2693 copy_bitwise (buffer
, value_bitpos (toval
),
2694 value_contents (fromval
), from_offset
,
2695 bits
, is_big_endian
);
2696 write_memory_with_notification (to_addr
, buffer
, len
);
2698 val
= value_copy (toval
);
2699 memcpy (value_contents_raw (val
), value_contents (fromval
),
2700 TYPE_LENGTH (type
));
2701 deprecated_set_value_type (val
, type
);
2706 return value_assign (toval
, fromval
);
2710 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2711 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2712 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2713 COMPONENT, and not the inferior's memory. The current contents
2714 of COMPONENT are ignored.
2716 Although not part of the initial design, this function also works
2717 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2718 had a null address, and COMPONENT had an address which is equal to
2719 its offset inside CONTAINER. */
2722 value_assign_to_component (struct value
*container
, struct value
*component
,
2725 LONGEST offset_in_container
=
2726 (LONGEST
) (value_address (component
) - value_address (container
));
2727 int bit_offset_in_container
=
2728 value_bitpos (component
) - value_bitpos (container
);
2731 val
= value_cast (value_type (component
), val
);
2733 if (value_bitsize (component
) == 0)
2734 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2736 bits
= value_bitsize (component
);
2738 if (gdbarch_bits_big_endian (get_type_arch (value_type (container
))))
2742 if (is_scalar_type (check_typedef (value_type (component
))))
2744 = TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
;
2747 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2748 value_bitpos (container
) + bit_offset_in_container
,
2749 value_contents (val
), src_offset
, bits
, 1);
2752 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2753 value_bitpos (container
) + bit_offset_in_container
,
2754 value_contents (val
), 0, bits
, 0);
2757 /* Determine if TYPE is an access to an unconstrained array. */
2760 ada_is_access_to_unconstrained_array (struct type
*type
)
2762 return (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
2763 && is_thick_pntr (ada_typedef_target_type (type
)));
2766 /* The value of the element of array ARR at the ARITY indices given in IND.
2767 ARR may be either a simple array, GNAT array descriptor, or pointer
2771 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2775 struct type
*elt_type
;
2777 elt
= ada_coerce_to_simple_array (arr
);
2779 elt_type
= ada_check_typedef (value_type (elt
));
2780 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2781 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2782 return value_subscript_packed (elt
, arity
, ind
);
2784 for (k
= 0; k
< arity
; k
+= 1)
2786 struct type
*saved_elt_type
= TYPE_TARGET_TYPE (elt_type
);
2788 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2789 error (_("too many subscripts (%d expected)"), k
);
2791 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2793 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
2794 && TYPE_CODE (value_type (elt
)) != TYPE_CODE_TYPEDEF
)
2796 /* The element is a typedef to an unconstrained array,
2797 except that the value_subscript call stripped the
2798 typedef layer. The typedef layer is GNAT's way to
2799 specify that the element is, at the source level, an
2800 access to the unconstrained array, rather than the
2801 unconstrained array. So, we need to restore that
2802 typedef layer, which we can do by forcing the element's
2803 type back to its original type. Otherwise, the returned
2804 value is going to be printed as the array, rather
2805 than as an access. Another symptom of the same issue
2806 would be that an expression trying to dereference the
2807 element would also be improperly rejected. */
2808 deprecated_set_value_type (elt
, saved_elt_type
);
2811 elt_type
= ada_check_typedef (value_type (elt
));
2817 /* Assuming ARR is a pointer to a GDB array, the value of the element
2818 of *ARR at the ARITY indices given in IND.
2819 Does not read the entire array into memory.
2821 Note: Unlike what one would expect, this function is used instead of
2822 ada_value_subscript for basically all non-packed array types. The reason
2823 for this is that a side effect of doing our own pointer arithmetics instead
2824 of relying on value_subscript is that there is no implicit typedef peeling.
2825 This is important for arrays of array accesses, where it allows us to
2826 preserve the fact that the array's element is an array access, where the
2827 access part os encoded in a typedef layer. */
2829 static struct value
*
2830 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2833 struct value
*array_ind
= ada_value_ind (arr
);
2835 = check_typedef (value_enclosing_type (array_ind
));
2837 if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
2838 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
2839 return value_subscript_packed (array_ind
, arity
, ind
);
2841 for (k
= 0; k
< arity
; k
+= 1)
2844 struct value
*lwb_value
;
2846 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2847 error (_("too many subscripts (%d expected)"), k
);
2848 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2850 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2851 lwb_value
= value_from_longest (value_type(ind
[k
]), lwb
);
2852 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - pos_atr (lwb_value
));
2853 type
= TYPE_TARGET_TYPE (type
);
2856 return value_ind (arr
);
2859 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2860 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2861 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2862 this array is LOW, as per Ada rules. */
2863 static struct value
*
2864 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2867 struct type
*type0
= ada_check_typedef (type
);
2868 struct type
*base_index_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0
));
2869 struct type
*index_type
2870 = create_static_range_type (NULL
, base_index_type
, low
, high
);
2871 struct type
*slice_type
= create_array_type_with_stride
2872 (NULL
, TYPE_TARGET_TYPE (type0
), index_type
,
2873 get_dyn_prop (DYN_PROP_BYTE_STRIDE
, type0
),
2874 TYPE_FIELD_BITSIZE (type0
, 0));
2875 int base_low
= ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0
));
2876 LONGEST base_low_pos
, low_pos
;
2879 if (!discrete_position (base_index_type
, low
, &low_pos
)
2880 || !discrete_position (base_index_type
, base_low
, &base_low_pos
))
2882 warning (_("unable to get positions in slice, use bounds instead"));
2884 base_low_pos
= base_low
;
2887 base
= value_as_address (array_ptr
)
2888 + ((low_pos
- base_low_pos
)
2889 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0
)));
2890 return value_at_lazy (slice_type
, base
);
2894 static struct value
*
2895 ada_value_slice (struct value
*array
, int low
, int high
)
2897 struct type
*type
= ada_check_typedef (value_type (array
));
2898 struct type
*base_index_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2899 struct type
*index_type
2900 = create_static_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2901 struct type
*slice_type
= create_array_type_with_stride
2902 (NULL
, TYPE_TARGET_TYPE (type
), index_type
,
2903 get_dyn_prop (DYN_PROP_BYTE_STRIDE
, type
),
2904 TYPE_FIELD_BITSIZE (type
, 0));
2905 LONGEST low_pos
, high_pos
;
2907 if (!discrete_position (base_index_type
, low
, &low_pos
)
2908 || !discrete_position (base_index_type
, high
, &high_pos
))
2910 warning (_("unable to get positions in slice, use bounds instead"));
2915 return value_cast (slice_type
,
2916 value_slice (array
, low
, high_pos
- low_pos
+ 1));
2919 /* If type is a record type in the form of a standard GNAT array
2920 descriptor, returns the number of dimensions for type. If arr is a
2921 simple array, returns the number of "array of"s that prefix its
2922 type designation. Otherwise, returns 0. */
2925 ada_array_arity (struct type
*type
)
2932 type
= desc_base_type (type
);
2935 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2936 return desc_arity (desc_bounds_type (type
));
2938 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2941 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2947 /* If TYPE is a record type in the form of a standard GNAT array
2948 descriptor or a simple array type, returns the element type for
2949 TYPE after indexing by NINDICES indices, or by all indices if
2950 NINDICES is -1. Otherwise, returns NULL. */
2953 ada_array_element_type (struct type
*type
, int nindices
)
2955 type
= desc_base_type (type
);
2957 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2960 struct type
*p_array_type
;
2962 p_array_type
= desc_data_target_type (type
);
2964 k
= ada_array_arity (type
);
2968 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2969 if (nindices
>= 0 && k
> nindices
)
2971 while (k
> 0 && p_array_type
!= NULL
)
2973 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2976 return p_array_type
;
2978 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2980 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2982 type
= TYPE_TARGET_TYPE (type
);
2991 /* The type of nth index in arrays of given type (n numbering from 1).
2992 Does not examine memory. Throws an error if N is invalid or TYPE
2993 is not an array type. NAME is the name of the Ada attribute being
2994 evaluated ('range, 'first, 'last, or 'length); it is used in building
2995 the error message. */
2997 static struct type
*
2998 ada_index_type (struct type
*type
, int n
, const char *name
)
3000 struct type
*result_type
;
3002 type
= desc_base_type (type
);
3004 if (n
< 0 || n
> ada_array_arity (type
))
3005 error (_("invalid dimension number to '%s"), name
);
3007 if (ada_is_simple_array_type (type
))
3011 for (i
= 1; i
< n
; i
+= 1)
3012 type
= TYPE_TARGET_TYPE (type
);
3013 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
3014 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3015 has a target type of TYPE_CODE_UNDEF. We compensate here, but
3016 perhaps stabsread.c would make more sense. */
3017 if (result_type
&& TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
3022 result_type
= desc_index_type (desc_bounds_type (type
), n
);
3023 if (result_type
== NULL
)
3024 error (_("attempt to take bound of something that is not an array"));
3030 /* Given that arr is an array type, returns the lower bound of the
3031 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3032 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
3033 array-descriptor type. It works for other arrays with bounds supplied
3034 by run-time quantities other than discriminants. */
3037 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
3039 struct type
*type
, *index_type_desc
, *index_type
;
3042 gdb_assert (which
== 0 || which
== 1);
3044 if (ada_is_constrained_packed_array_type (arr_type
))
3045 arr_type
= decode_constrained_packed_array_type (arr_type
);
3047 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
3048 return (LONGEST
) - which
;
3050 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
3051 type
= TYPE_TARGET_TYPE (arr_type
);
3055 if (TYPE_FIXED_INSTANCE (type
))
3057 /* The array has already been fixed, so we do not need to
3058 check the parallel ___XA type again. That encoding has
3059 already been applied, so ignore it now. */
3060 index_type_desc
= NULL
;
3064 index_type_desc
= ada_find_parallel_type (type
, "___XA");
3065 ada_fixup_array_indexes_type (index_type_desc
);
3068 if (index_type_desc
!= NULL
)
3069 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, n
- 1),
3073 struct type
*elt_type
= check_typedef (type
);
3075 for (i
= 1; i
< n
; i
++)
3076 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
3078 index_type
= TYPE_INDEX_TYPE (elt_type
);
3082 (LONGEST
) (which
== 0
3083 ? ada_discrete_type_low_bound (index_type
)
3084 : ada_discrete_type_high_bound (index_type
));
3087 /* Given that arr is an array value, returns the lower bound of the
3088 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3089 WHICH is 1. This routine will also work for arrays with bounds
3090 supplied by run-time quantities other than discriminants. */
3093 ada_array_bound (struct value
*arr
, int n
, int which
)
3095 struct type
*arr_type
;
3097 if (TYPE_CODE (check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
3098 arr
= value_ind (arr
);
3099 arr_type
= value_enclosing_type (arr
);
3101 if (ada_is_constrained_packed_array_type (arr_type
))
3102 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
3103 else if (ada_is_simple_array_type (arr_type
))
3104 return ada_array_bound_from_type (arr_type
, n
, which
);
3106 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
3109 /* Given that arr is an array value, returns the length of the
3110 nth index. This routine will also work for arrays with bounds
3111 supplied by run-time quantities other than discriminants.
3112 Does not work for arrays indexed by enumeration types with representation
3113 clauses at the moment. */
3116 ada_array_length (struct value
*arr
, int n
)
3118 struct type
*arr_type
, *index_type
;
3121 if (TYPE_CODE (check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
3122 arr
= value_ind (arr
);
3123 arr_type
= value_enclosing_type (arr
);
3125 if (ada_is_constrained_packed_array_type (arr_type
))
3126 return ada_array_length (decode_constrained_packed_array (arr
), n
);
3128 if (ada_is_simple_array_type (arr_type
))
3130 low
= ada_array_bound_from_type (arr_type
, n
, 0);
3131 high
= ada_array_bound_from_type (arr_type
, n
, 1);
3135 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
3136 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
3139 arr_type
= check_typedef (arr_type
);
3140 index_type
= ada_index_type (arr_type
, n
, "length");
3141 if (index_type
!= NULL
)
3143 struct type
*base_type
;
3144 if (TYPE_CODE (index_type
) == TYPE_CODE_RANGE
)
3145 base_type
= TYPE_TARGET_TYPE (index_type
);
3147 base_type
= index_type
;
3149 low
= pos_atr (value_from_longest (base_type
, low
));
3150 high
= pos_atr (value_from_longest (base_type
, high
));
3152 return high
- low
+ 1;
3155 /* An array whose type is that of ARR_TYPE (an array type), with
3156 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3157 less than LOW, then LOW-1 is used. */
3159 static struct value
*
3160 empty_array (struct type
*arr_type
, int low
, int high
)
3162 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3163 struct type
*index_type
3164 = create_static_range_type
3165 (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0
)), low
,
3166 high
< low
? low
- 1 : high
);
3167 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3169 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3173 /* Name resolution */
3175 /* The "decoded" name for the user-definable Ada operator corresponding
3179 ada_decoded_op_name (enum exp_opcode op
)
3183 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3185 if (ada_opname_table
[i
].op
== op
)
3186 return ada_opname_table
[i
].decoded
;
3188 error (_("Could not find operator name for opcode"));
3192 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3193 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3194 undefined namespace) and converts operators that are
3195 user-defined into appropriate function calls. If CONTEXT_TYPE is
3196 non-null, it provides a preferred result type [at the moment, only
3197 type void has any effect---causing procedures to be preferred over
3198 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3199 return type is preferred. May change (expand) *EXP. */
3202 resolve (expression_up
*expp
, int void_context_p
, int parse_completion
,
3203 innermost_block_tracker
*tracker
)
3205 struct type
*context_type
= NULL
;
3209 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
3211 resolve_subexp (expp
, &pc
, 1, context_type
, parse_completion
, tracker
);
3214 /* Resolve the operator of the subexpression beginning at
3215 position *POS of *EXPP. "Resolving" consists of replacing
3216 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3217 with their resolutions, replacing built-in operators with
3218 function calls to user-defined operators, where appropriate, and,
3219 when DEPROCEDURE_P is non-zero, converting function-valued variables
3220 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3221 are as in ada_resolve, above. */
3223 static struct value
*
3224 resolve_subexp (expression_up
*expp
, int *pos
, int deprocedure_p
,
3225 struct type
*context_type
, int parse_completion
,
3226 innermost_block_tracker
*tracker
)
3230 struct expression
*exp
; /* Convenience: == *expp. */
3231 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3232 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3233 int nargs
; /* Number of operands. */
3240 /* Pass one: resolve operands, saving their types and updating *pos,
3245 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3246 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3251 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3253 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3258 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3263 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
),
3264 parse_completion
, tracker
);
3267 case OP_ATR_MODULUS
:
3277 case TERNOP_IN_RANGE
:
3278 case BINOP_IN_BOUNDS
:
3284 case OP_DISCRETE_RANGE
:
3286 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3295 arg1
= resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3297 resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
, tracker
);
3299 resolve_subexp (expp
, pos
, 1, value_type (arg1
), parse_completion
,
3317 case BINOP_LOGICAL_AND
:
3318 case BINOP_LOGICAL_OR
:
3319 case BINOP_BITWISE_AND
:
3320 case BINOP_BITWISE_IOR
:
3321 case BINOP_BITWISE_XOR
:
3324 case BINOP_NOTEQUAL
:
3331 case BINOP_SUBSCRIPT
:
3339 case UNOP_LOGICAL_NOT
:
3349 case OP_VAR_MSYM_VALUE
:
3356 case OP_INTERNALVAR
:
3366 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3369 case STRUCTOP_STRUCT
:
3370 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3383 error (_("Unexpected operator during name resolution"));
3386 argvec
= XALLOCAVEC (struct value
*, nargs
+ 1);
3387 for (i
= 0; i
< nargs
; i
+= 1)
3388 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
,
3393 /* Pass two: perform any resolution on principal operator. */
3400 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3402 std::vector
<struct block_symbol
> candidates
;
3406 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3407 (exp
->elts
[pc
+ 2].symbol
),
3408 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3411 if (n_candidates
> 1)
3413 /* Types tend to get re-introduced locally, so if there
3414 are any local symbols that are not types, first filter
3417 for (j
= 0; j
< n_candidates
; j
+= 1)
3418 switch (SYMBOL_CLASS (candidates
[j
].symbol
))
3423 case LOC_REGPARM_ADDR
:
3431 if (j
< n_candidates
)
3434 while (j
< n_candidates
)
3436 if (SYMBOL_CLASS (candidates
[j
].symbol
) == LOC_TYPEDEF
)
3438 candidates
[j
] = candidates
[n_candidates
- 1];
3447 if (n_candidates
== 0)
3448 error (_("No definition found for %s"),
3449 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3450 else if (n_candidates
== 1)
3452 else if (deprocedure_p
3453 && !is_nonfunction (candidates
.data (), n_candidates
))
3455 i
= ada_resolve_function
3456 (candidates
.data (), n_candidates
, NULL
, 0,
3457 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
3458 context_type
, parse_completion
);
3460 error (_("Could not find a match for %s"),
3461 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3465 printf_filtered (_("Multiple matches for %s\n"),
3466 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3467 user_select_syms (candidates
.data (), n_candidates
, 1);
3471 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3472 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].symbol
;
3473 tracker
->update (candidates
[i
]);
3477 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
3480 replace_operator_with_call (expp
, pc
, 0, 4,
3481 exp
->elts
[pc
+ 2].symbol
,
3482 exp
->elts
[pc
+ 1].block
);
3489 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3490 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3492 std::vector
<struct block_symbol
> candidates
;
3496 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3497 (exp
->elts
[pc
+ 5].symbol
),
3498 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3501 if (n_candidates
== 1)
3505 i
= ada_resolve_function
3506 (candidates
.data (), n_candidates
,
3508 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
3509 context_type
, parse_completion
);
3511 error (_("Could not find a match for %s"),
3512 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
3515 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3516 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].symbol
;
3517 tracker
->update (candidates
[i
]);
3528 case BINOP_BITWISE_AND
:
3529 case BINOP_BITWISE_IOR
:
3530 case BINOP_BITWISE_XOR
:
3532 case BINOP_NOTEQUAL
:
3540 case UNOP_LOGICAL_NOT
:
3542 if (possible_user_operator_p (op
, argvec
))
3544 std::vector
<struct block_symbol
> candidates
;
3548 ada_lookup_symbol_list (ada_decoded_op_name (op
),
3552 i
= ada_resolve_function (candidates
.data (), n_candidates
, argvec
,
3553 nargs
, ada_decoded_op_name (op
), NULL
,
3558 replace_operator_with_call (expp
, pc
, nargs
, 1,
3559 candidates
[i
].symbol
,
3560 candidates
[i
].block
);
3571 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
3572 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS
,
3573 exp
->elts
[pc
+ 1].objfile
,
3574 exp
->elts
[pc
+ 2].msymbol
);
3576 return evaluate_subexp_type (exp
, pos
);
3579 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3580 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3582 /* The term "match" here is rather loose. The match is heuristic and
3586 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3588 ftype
= ada_check_typedef (ftype
);
3589 atype
= ada_check_typedef (atype
);
3591 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3592 ftype
= TYPE_TARGET_TYPE (ftype
);
3593 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3594 atype
= TYPE_TARGET_TYPE (atype
);
3596 switch (TYPE_CODE (ftype
))
3599 return TYPE_CODE (ftype
) == TYPE_CODE (atype
);
3601 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3602 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3603 TYPE_TARGET_TYPE (atype
), 0);
3606 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3608 case TYPE_CODE_ENUM
:
3609 case TYPE_CODE_RANGE
:
3610 switch (TYPE_CODE (atype
))
3613 case TYPE_CODE_ENUM
:
3614 case TYPE_CODE_RANGE
:
3620 case TYPE_CODE_ARRAY
:
3621 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3622 || ada_is_array_descriptor_type (atype
));
3624 case TYPE_CODE_STRUCT
:
3625 if (ada_is_array_descriptor_type (ftype
))
3626 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3627 || ada_is_array_descriptor_type (atype
));
3629 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3630 && !ada_is_array_descriptor_type (atype
));
3632 case TYPE_CODE_UNION
:
3634 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3638 /* Return non-zero if the formals of FUNC "sufficiently match" the
3639 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3640 may also be an enumeral, in which case it is treated as a 0-
3641 argument function. */
3644 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3647 struct type
*func_type
= SYMBOL_TYPE (func
);
3649 if (SYMBOL_CLASS (func
) == LOC_CONST
3650 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3651 return (n_actuals
== 0);
3652 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3655 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3658 for (i
= 0; i
< n_actuals
; i
+= 1)
3660 if (actuals
[i
] == NULL
)
3664 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
,
3666 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3668 if (!ada_type_match (ftype
, atype
, 1))
3675 /* False iff function type FUNC_TYPE definitely does not produce a value
3676 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3677 FUNC_TYPE is not a valid function type with a non-null return type
3678 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3681 return_match (struct type
*func_type
, struct type
*context_type
)
3683 struct type
*return_type
;
3685 if (func_type
== NULL
)
3688 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3689 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3691 return_type
= get_base_type (func_type
);
3692 if (return_type
== NULL
)
3695 context_type
= get_base_type (context_type
);
3697 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3698 return context_type
== NULL
|| return_type
== context_type
;
3699 else if (context_type
== NULL
)
3700 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3702 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3706 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3707 function (if any) that matches the types of the NARGS arguments in
3708 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3709 that returns that type, then eliminate matches that don't. If
3710 CONTEXT_TYPE is void and there is at least one match that does not
3711 return void, eliminate all matches that do.
3713 Asks the user if there is more than one match remaining. Returns -1
3714 if there is no such symbol or none is selected. NAME is used
3715 solely for messages. May re-arrange and modify SYMS in
3716 the process; the index returned is for the modified vector. */
3719 ada_resolve_function (struct block_symbol syms
[],
3720 int nsyms
, struct value
**args
, int nargs
,
3721 const char *name
, struct type
*context_type
,
3722 int parse_completion
)
3726 int m
; /* Number of hits */
3729 /* In the first pass of the loop, we only accept functions matching
3730 context_type. If none are found, we add a second pass of the loop
3731 where every function is accepted. */
3732 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3734 for (k
= 0; k
< nsyms
; k
+= 1)
3736 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].symbol
));
3738 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
3739 && (fallback
|| return_match (type
, context_type
)))
3747 /* If we got multiple matches, ask the user which one to use. Don't do this
3748 interactive thing during completion, though, as the purpose of the
3749 completion is providing a list of all possible matches. Prompting the
3750 user to filter it down would be completely unexpected in this case. */
3753 else if (m
> 1 && !parse_completion
)
3755 printf_filtered (_("Multiple matches for %s\n"), name
);
3756 user_select_syms (syms
, m
, 1);
3762 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3763 in a listing of choices during disambiguation (see sort_choices, below).
3764 The idea is that overloadings of a subprogram name from the
3765 same package should sort in their source order. We settle for ordering
3766 such symbols by their trailing number (__N or $N). */
3769 encoded_ordered_before (const char *N0
, const char *N1
)
3773 else if (N0
== NULL
)
3779 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3781 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3783 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3784 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3789 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3792 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3794 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3795 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3797 return (strcmp (N0
, N1
) < 0);
3801 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3805 sort_choices (struct block_symbol syms
[], int nsyms
)
3809 for (i
= 1; i
< nsyms
; i
+= 1)
3811 struct block_symbol sym
= syms
[i
];
3814 for (j
= i
- 1; j
>= 0; j
-= 1)
3816 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].symbol
),
3817 SYMBOL_LINKAGE_NAME (sym
.symbol
)))
3819 syms
[j
+ 1] = syms
[j
];
3825 /* Whether GDB should display formals and return types for functions in the
3826 overloads selection menu. */
3827 static int print_signatures
= 1;
3829 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3830 all but functions, the signature is just the name of the symbol. For
3831 functions, this is the name of the function, the list of types for formals
3832 and the return type (if any). */
3835 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3836 const struct type_print_options
*flags
)
3838 struct type
*type
= SYMBOL_TYPE (sym
);
3840 fprintf_filtered (stream
, "%s", SYMBOL_PRINT_NAME (sym
));
3841 if (!print_signatures
3843 || TYPE_CODE (type
) != TYPE_CODE_FUNC
)
3846 if (TYPE_NFIELDS (type
) > 0)
3850 fprintf_filtered (stream
, " (");
3851 for (i
= 0; i
< TYPE_NFIELDS (type
); ++i
)
3854 fprintf_filtered (stream
, "; ");
3855 ada_print_type (TYPE_FIELD_TYPE (type
, i
), NULL
, stream
, -1, 0,
3858 fprintf_filtered (stream
, ")");
3860 if (TYPE_TARGET_TYPE (type
) != NULL
3861 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) != TYPE_CODE_VOID
)
3863 fprintf_filtered (stream
, " return ");
3864 ada_print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, -1, 0, flags
);
3868 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3869 by asking the user (if necessary), returning the number selected,
3870 and setting the first elements of SYMS items. Error if no symbols
3873 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3874 to be re-integrated one of these days. */
3877 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3880 int *chosen
= XALLOCAVEC (int , nsyms
);
3882 int first_choice
= (max_results
== 1) ? 1 : 2;
3883 const char *select_mode
= multiple_symbols_select_mode ();
3885 if (max_results
< 1)
3886 error (_("Request to select 0 symbols!"));
3890 if (select_mode
== multiple_symbols_cancel
)
3892 canceled because the command is ambiguous\n\
3893 See set/show multiple-symbol."));
3895 /* If select_mode is "all", then return all possible symbols.
3896 Only do that if more than one symbol can be selected, of course.
3897 Otherwise, display the menu as usual. */
3898 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3901 printf_filtered (_("[0] cancel\n"));
3902 if (max_results
> 1)
3903 printf_filtered (_("[1] all\n"));
3905 sort_choices (syms
, nsyms
);
3907 for (i
= 0; i
< nsyms
; i
+= 1)
3909 if (syms
[i
].symbol
== NULL
)
3912 if (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_BLOCK
)
3914 struct symtab_and_line sal
=
3915 find_function_start_sal (syms
[i
].symbol
, 1);
3917 printf_filtered ("[%d] ", i
+ first_choice
);
3918 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3919 &type_print_raw_options
);
3920 if (sal
.symtab
== NULL
)
3921 printf_filtered (_(" at <no source file available>:%d\n"),
3924 printf_filtered (_(" at %s:%d\n"),
3925 symtab_to_filename_for_display (sal
.symtab
),
3932 (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_CONST
3933 && SYMBOL_TYPE (syms
[i
].symbol
) != NULL
3934 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) == TYPE_CODE_ENUM
);
3935 struct symtab
*symtab
= NULL
;
3937 if (SYMBOL_OBJFILE_OWNED (syms
[i
].symbol
))
3938 symtab
= symbol_symtab (syms
[i
].symbol
);
3940 if (SYMBOL_LINE (syms
[i
].symbol
) != 0 && symtab
!= NULL
)
3942 printf_filtered ("[%d] ", i
+ first_choice
);
3943 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3944 &type_print_raw_options
);
3945 printf_filtered (_(" at %s:%d\n"),
3946 symtab_to_filename_for_display (symtab
),
3947 SYMBOL_LINE (syms
[i
].symbol
));
3949 else if (is_enumeral
3950 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].symbol
)) != NULL
)
3952 printf_filtered (("[%d] "), i
+ first_choice
);
3953 ada_print_type (SYMBOL_TYPE (syms
[i
].symbol
), NULL
,
3954 gdb_stdout
, -1, 0, &type_print_raw_options
);
3955 printf_filtered (_("'(%s) (enumeral)\n"),
3956 SYMBOL_PRINT_NAME (syms
[i
].symbol
));
3960 printf_filtered ("[%d] ", i
+ first_choice
);
3961 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3962 &type_print_raw_options
);
3965 printf_filtered (is_enumeral
3966 ? _(" in %s (enumeral)\n")
3968 symtab_to_filename_for_display (symtab
));
3970 printf_filtered (is_enumeral
3971 ? _(" (enumeral)\n")
3977 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3980 for (i
= 0; i
< n_chosen
; i
+= 1)
3981 syms
[i
] = syms
[chosen
[i
]];
3986 /* Read and validate a set of numeric choices from the user in the
3987 range 0 .. N_CHOICES-1. Place the results in increasing
3988 order in CHOICES[0 .. N-1], and return N.
3990 The user types choices as a sequence of numbers on one line
3991 separated by blanks, encoding them as follows:
3993 + A choice of 0 means to cancel the selection, throwing an error.
3994 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3995 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3997 The user is not allowed to choose more than MAX_RESULTS values.
3999 ANNOTATION_SUFFIX, if present, is used to annotate the input
4000 prompts (for use with the -f switch). */
4003 get_selections (int *choices
, int n_choices
, int max_results
,
4004 int is_all_choice
, const char *annotation_suffix
)
4009 int first_choice
= is_all_choice
? 2 : 1;
4011 prompt
= getenv ("PS2");
4015 args
= command_line_input (prompt
, annotation_suffix
);
4018 error_no_arg (_("one or more choice numbers"));
4022 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4023 order, as given in args. Choices are validated. */
4029 args
= skip_spaces (args
);
4030 if (*args
== '\0' && n_chosen
== 0)
4031 error_no_arg (_("one or more choice numbers"));
4032 else if (*args
== '\0')
4035 choice
= strtol (args
, &args2
, 10);
4036 if (args
== args2
|| choice
< 0
4037 || choice
> n_choices
+ first_choice
- 1)
4038 error (_("Argument must be choice number"));
4042 error (_("cancelled"));
4044 if (choice
< first_choice
)
4046 n_chosen
= n_choices
;
4047 for (j
= 0; j
< n_choices
; j
+= 1)
4051 choice
-= first_choice
;
4053 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
4057 if (j
< 0 || choice
!= choices
[j
])
4061 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
4062 choices
[k
+ 1] = choices
[k
];
4063 choices
[j
+ 1] = choice
;
4068 if (n_chosen
> max_results
)
4069 error (_("Select no more than %d of the above"), max_results
);
4074 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4075 on the function identified by SYM and BLOCK, and taking NARGS
4076 arguments. Update *EXPP as needed to hold more space. */
4079 replace_operator_with_call (expression_up
*expp
, int pc
, int nargs
,
4080 int oplen
, struct symbol
*sym
,
4081 const struct block
*block
)
4083 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4084 symbol, -oplen for operator being replaced). */
4085 struct expression
*newexp
= (struct expression
*)
4086 xzalloc (sizeof (struct expression
)
4087 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
4088 struct expression
*exp
= expp
->get ();
4090 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
4091 newexp
->language_defn
= exp
->language_defn
;
4092 newexp
->gdbarch
= exp
->gdbarch
;
4093 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
4094 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
4095 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
4097 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
4098 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
4100 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
4101 newexp
->elts
[pc
+ 4].block
= block
;
4102 newexp
->elts
[pc
+ 5].symbol
= sym
;
4104 expp
->reset (newexp
);
4107 /* Type-class predicates */
4109 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4113 numeric_type_p (struct type
*type
)
4119 switch (TYPE_CODE (type
))
4124 case TYPE_CODE_RANGE
:
4125 return (type
== TYPE_TARGET_TYPE (type
)
4126 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
4133 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4136 integer_type_p (struct type
*type
)
4142 switch (TYPE_CODE (type
))
4146 case TYPE_CODE_RANGE
:
4147 return (type
== TYPE_TARGET_TYPE (type
)
4148 || integer_type_p (TYPE_TARGET_TYPE (type
)));
4155 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4158 scalar_type_p (struct type
*type
)
4164 switch (TYPE_CODE (type
))
4167 case TYPE_CODE_RANGE
:
4168 case TYPE_CODE_ENUM
:
4177 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4180 discrete_type_p (struct type
*type
)
4186 switch (TYPE_CODE (type
))
4189 case TYPE_CODE_RANGE
:
4190 case TYPE_CODE_ENUM
:
4191 case TYPE_CODE_BOOL
:
4199 /* Returns non-zero if OP with operands in the vector ARGS could be
4200 a user-defined function. Errs on the side of pre-defined operators
4201 (i.e., result 0). */
4204 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4206 struct type
*type0
=
4207 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
4208 struct type
*type1
=
4209 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4223 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4227 case BINOP_BITWISE_AND
:
4228 case BINOP_BITWISE_IOR
:
4229 case BINOP_BITWISE_XOR
:
4230 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4233 case BINOP_NOTEQUAL
:
4238 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4241 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4244 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4248 case UNOP_LOGICAL_NOT
:
4250 return (!numeric_type_p (type0
));
4259 1. In the following, we assume that a renaming type's name may
4260 have an ___XD suffix. It would be nice if this went away at some
4262 2. We handle both the (old) purely type-based representation of
4263 renamings and the (new) variable-based encoding. At some point,
4264 it is devoutly to be hoped that the former goes away
4265 (FIXME: hilfinger-2007-07-09).
4266 3. Subprogram renamings are not implemented, although the XRS
4267 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4269 /* If SYM encodes a renaming,
4271 <renaming> renames <renamed entity>,
4273 sets *LEN to the length of the renamed entity's name,
4274 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4275 the string describing the subcomponent selected from the renamed
4276 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4277 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4278 are undefined). Otherwise, returns a value indicating the category
4279 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4280 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4281 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4282 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4283 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4284 may be NULL, in which case they are not assigned.
4286 [Currently, however, GCC does not generate subprogram renamings.] */
4288 enum ada_renaming_category
4289 ada_parse_renaming (struct symbol
*sym
,
4290 const char **renamed_entity
, int *len
,
4291 const char **renaming_expr
)
4293 enum ada_renaming_category kind
;
4298 return ADA_NOT_RENAMING
;
4299 switch (SYMBOL_CLASS (sym
))
4302 return ADA_NOT_RENAMING
;
4304 return parse_old_style_renaming (SYMBOL_TYPE (sym
),
4305 renamed_entity
, len
, renaming_expr
);
4309 case LOC_OPTIMIZED_OUT
:
4310 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
4312 return ADA_NOT_RENAMING
;
4316 kind
= ADA_OBJECT_RENAMING
;
4320 kind
= ADA_EXCEPTION_RENAMING
;
4324 kind
= ADA_PACKAGE_RENAMING
;
4328 kind
= ADA_SUBPROGRAM_RENAMING
;
4332 return ADA_NOT_RENAMING
;
4336 if (renamed_entity
!= NULL
)
4337 *renamed_entity
= info
;
4338 suffix
= strstr (info
, "___XE");
4339 if (suffix
== NULL
|| suffix
== info
)
4340 return ADA_NOT_RENAMING
;
4342 *len
= strlen (info
) - strlen (suffix
);
4344 if (renaming_expr
!= NULL
)
4345 *renaming_expr
= suffix
;
4349 /* Assuming TYPE encodes a renaming according to the old encoding in
4350 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4351 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4352 ADA_NOT_RENAMING otherwise. */
4353 static enum ada_renaming_category
4354 parse_old_style_renaming (struct type
*type
,
4355 const char **renamed_entity
, int *len
,
4356 const char **renaming_expr
)
4358 enum ada_renaming_category kind
;
4363 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
4364 || TYPE_NFIELDS (type
) != 1)
4365 return ADA_NOT_RENAMING
;
4367 name
= TYPE_NAME (type
);
4369 return ADA_NOT_RENAMING
;
4371 name
= strstr (name
, "___XR");
4373 return ADA_NOT_RENAMING
;
4378 kind
= ADA_OBJECT_RENAMING
;
4381 kind
= ADA_EXCEPTION_RENAMING
;
4384 kind
= ADA_PACKAGE_RENAMING
;
4387 kind
= ADA_SUBPROGRAM_RENAMING
;
4390 return ADA_NOT_RENAMING
;
4393 info
= TYPE_FIELD_NAME (type
, 0);
4395 return ADA_NOT_RENAMING
;
4396 if (renamed_entity
!= NULL
)
4397 *renamed_entity
= info
;
4398 suffix
= strstr (info
, "___XE");
4399 if (renaming_expr
!= NULL
)
4400 *renaming_expr
= suffix
+ 5;
4401 if (suffix
== NULL
|| suffix
== info
)
4402 return ADA_NOT_RENAMING
;
4404 *len
= suffix
- info
;
4408 /* Compute the value of the given RENAMING_SYM, which is expected to
4409 be a symbol encoding a renaming expression. BLOCK is the block
4410 used to evaluate the renaming. */
4412 static struct value
*
4413 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4414 const struct block
*block
)
4416 const char *sym_name
;
4418 sym_name
= SYMBOL_LINKAGE_NAME (renaming_sym
);
4419 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4420 return evaluate_expression (expr
.get ());
4424 /* Evaluation: Function Calls */
4426 /* Return an lvalue containing the value VAL. This is the identity on
4427 lvalues, and otherwise has the side-effect of allocating memory
4428 in the inferior where a copy of the value contents is copied. */
4430 static struct value
*
4431 ensure_lval (struct value
*val
)
4433 if (VALUE_LVAL (val
) == not_lval
4434 || VALUE_LVAL (val
) == lval_internalvar
)
4436 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4437 const CORE_ADDR addr
=
4438 value_as_long (value_allocate_space_in_inferior (len
));
4440 VALUE_LVAL (val
) = lval_memory
;
4441 set_value_address (val
, addr
);
4442 write_memory (addr
, value_contents (val
), len
);
4448 /* Return the value ACTUAL, converted to be an appropriate value for a
4449 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4450 allocating any necessary descriptors (fat pointers), or copies of
4451 values not residing in memory, updating it as needed. */
4454 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4456 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4457 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4458 struct type
*formal_target
=
4459 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4460 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4461 struct type
*actual_target
=
4462 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
4463 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4465 if (ada_is_array_descriptor_type (formal_target
)
4466 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
4467 return make_array_descriptor (formal_type
, actual
);
4468 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4469 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
4471 struct value
*result
;
4473 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
4474 && ada_is_array_descriptor_type (actual_target
))
4475 result
= desc_data (actual
);
4476 else if (TYPE_CODE (formal_type
) != TYPE_CODE_PTR
)
4478 if (VALUE_LVAL (actual
) != lval_memory
)
4482 actual_type
= ada_check_typedef (value_type (actual
));
4483 val
= allocate_value (actual_type
);
4484 memcpy ((char *) value_contents_raw (val
),
4485 (char *) value_contents (actual
),
4486 TYPE_LENGTH (actual_type
));
4487 actual
= ensure_lval (val
);
4489 result
= value_addr (actual
);
4493 return value_cast_pointers (formal_type
, result
, 0);
4495 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
4496 return ada_value_ind (actual
);
4497 else if (ada_is_aligner_type (formal_type
))
4499 /* We need to turn this parameter into an aligner type
4501 struct value
*aligner
= allocate_value (formal_type
);
4502 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4504 value_assign_to_component (aligner
, component
, actual
);
4511 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4512 type TYPE. This is usually an inefficient no-op except on some targets
4513 (such as AVR) where the representation of a pointer and an address
4517 value_pointer (struct value
*value
, struct type
*type
)
4519 struct gdbarch
*gdbarch
= get_type_arch (type
);
4520 unsigned len
= TYPE_LENGTH (type
);
4521 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4524 addr
= value_address (value
);
4525 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4526 addr
= extract_unsigned_integer (buf
, len
, gdbarch_byte_order (gdbarch
));
4531 /* Push a descriptor of type TYPE for array value ARR on the stack at
4532 *SP, updating *SP to reflect the new descriptor. Return either
4533 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4534 to-descriptor type rather than a descriptor type), a struct value *
4535 representing a pointer to this descriptor. */
4537 static struct value
*
4538 make_array_descriptor (struct type
*type
, struct value
*arr
)
4540 struct type
*bounds_type
= desc_bounds_type (type
);
4541 struct type
*desc_type
= desc_base_type (type
);
4542 struct value
*descriptor
= allocate_value (desc_type
);
4543 struct value
*bounds
= allocate_value (bounds_type
);
4546 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4549 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4550 ada_array_bound (arr
, i
, 0),
4551 desc_bound_bitpos (bounds_type
, i
, 0),
4552 desc_bound_bitsize (bounds_type
, i
, 0));
4553 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4554 ada_array_bound (arr
, i
, 1),
4555 desc_bound_bitpos (bounds_type
, i
, 1),
4556 desc_bound_bitsize (bounds_type
, i
, 1));
4559 bounds
= ensure_lval (bounds
);
4561 modify_field (value_type (descriptor
),
4562 value_contents_writeable (descriptor
),
4563 value_pointer (ensure_lval (arr
),
4564 TYPE_FIELD_TYPE (desc_type
, 0)),
4565 fat_pntr_data_bitpos (desc_type
),
4566 fat_pntr_data_bitsize (desc_type
));
4568 modify_field (value_type (descriptor
),
4569 value_contents_writeable (descriptor
),
4570 value_pointer (bounds
,
4571 TYPE_FIELD_TYPE (desc_type
, 1)),
4572 fat_pntr_bounds_bitpos (desc_type
),
4573 fat_pntr_bounds_bitsize (desc_type
));
4575 descriptor
= ensure_lval (descriptor
);
4577 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
4578 return value_addr (descriptor
);
4583 /* Symbol Cache Module */
4585 /* Performance measurements made as of 2010-01-15 indicate that
4586 this cache does bring some noticeable improvements. Depending
4587 on the type of entity being printed, the cache can make it as much
4588 as an order of magnitude faster than without it.
4590 The descriptive type DWARF extension has significantly reduced
4591 the need for this cache, at least when DWARF is being used. However,
4592 even in this case, some expensive name-based symbol searches are still
4593 sometimes necessary - to find an XVZ variable, mostly. */
4595 /* Initialize the contents of SYM_CACHE. */
4598 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4600 obstack_init (&sym_cache
->cache_space
);
4601 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4604 /* Free the memory used by SYM_CACHE. */
4607 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4609 obstack_free (&sym_cache
->cache_space
, NULL
);
4613 /* Return the symbol cache associated to the given program space PSPACE.
4614 If not allocated for this PSPACE yet, allocate and initialize one. */
4616 static struct ada_symbol_cache
*
4617 ada_get_symbol_cache (struct program_space
*pspace
)
4619 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4621 if (pspace_data
->sym_cache
== NULL
)
4623 pspace_data
->sym_cache
= XCNEW (struct ada_symbol_cache
);
4624 ada_init_symbol_cache (pspace_data
->sym_cache
);
4627 return pspace_data
->sym_cache
;
4630 /* Clear all entries from the symbol cache. */
4633 ada_clear_symbol_cache (void)
4635 struct ada_symbol_cache
*sym_cache
4636 = ada_get_symbol_cache (current_program_space
);
4638 obstack_free (&sym_cache
->cache_space
, NULL
);
4639 ada_init_symbol_cache (sym_cache
);
4642 /* Search our cache for an entry matching NAME and DOMAIN.
4643 Return it if found, or NULL otherwise. */
4645 static struct cache_entry
**
4646 find_entry (const char *name
, domain_enum domain
)
4648 struct ada_symbol_cache
*sym_cache
4649 = ada_get_symbol_cache (current_program_space
);
4650 int h
= msymbol_hash (name
) % HASH_SIZE
;
4651 struct cache_entry
**e
;
4653 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4655 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4661 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4662 Return 1 if found, 0 otherwise.
4664 If an entry was found and SYM is not NULL, set *SYM to the entry's
4665 SYM. Same principle for BLOCK if not NULL. */
4668 lookup_cached_symbol (const char *name
, domain_enum domain
,
4669 struct symbol
**sym
, const struct block
**block
)
4671 struct cache_entry
**e
= find_entry (name
, domain
);
4678 *block
= (*e
)->block
;
4682 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4683 in domain DOMAIN, save this result in our symbol cache. */
4686 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4687 const struct block
*block
)
4689 struct ada_symbol_cache
*sym_cache
4690 = ada_get_symbol_cache (current_program_space
);
4693 struct cache_entry
*e
;
4695 /* Symbols for builtin types don't have a block.
4696 For now don't cache such symbols. */
4697 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4700 /* If the symbol is a local symbol, then do not cache it, as a search
4701 for that symbol depends on the context. To determine whether
4702 the symbol is local or not, we check the block where we found it
4703 against the global and static blocks of its associated symtab. */
4705 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4706 GLOBAL_BLOCK
) != block
4707 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4708 STATIC_BLOCK
) != block
)
4711 h
= msymbol_hash (name
) % HASH_SIZE
;
4712 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4713 e
->next
= sym_cache
->root
[h
];
4714 sym_cache
->root
[h
] = e
;
4716 = (char *) obstack_alloc (&sym_cache
->cache_space
, strlen (name
) + 1);
4717 strcpy (copy
, name
);
4725 /* Return the symbol name match type that should be used used when
4726 searching for all symbols matching LOOKUP_NAME.
4728 LOOKUP_NAME is expected to be a symbol name after transformation
4731 static symbol_name_match_type
4732 name_match_type_from_name (const char *lookup_name
)
4734 return (strstr (lookup_name
, "__") == NULL
4735 ? symbol_name_match_type::WILD
4736 : symbol_name_match_type::FULL
);
4739 /* Return the result of a standard (literal, C-like) lookup of NAME in
4740 given DOMAIN, visible from lexical block BLOCK. */
4742 static struct symbol
*
4743 standard_lookup (const char *name
, const struct block
*block
,
4746 /* Initialize it just to avoid a GCC false warning. */
4747 struct block_symbol sym
= {};
4749 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4751 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4752 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4757 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4758 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4759 since they contend in overloading in the same way. */
4761 is_nonfunction (struct block_symbol syms
[], int n
)
4765 for (i
= 0; i
< n
; i
+= 1)
4766 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) != TYPE_CODE_FUNC
4767 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) != TYPE_CODE_ENUM
4768 || SYMBOL_CLASS (syms
[i
].symbol
) != LOC_CONST
))
4774 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4775 struct types. Otherwise, they may not. */
4778 equiv_types (struct type
*type0
, struct type
*type1
)
4782 if (type0
== NULL
|| type1
== NULL
4783 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
4785 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
4786 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
4787 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4788 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4794 /* True iff SYM0 represents the same entity as SYM1, or one that is
4795 no more defined than that of SYM1. */
4798 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4802 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4803 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4806 switch (SYMBOL_CLASS (sym0
))
4812 struct type
*type0
= SYMBOL_TYPE (sym0
);
4813 struct type
*type1
= SYMBOL_TYPE (sym1
);
4814 const char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4815 const char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4816 int len0
= strlen (name0
);
4819 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4820 && (equiv_types (type0
, type1
)
4821 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4822 && startswith (name1
+ len0
, "___XV")));
4825 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4826 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4832 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4833 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4836 add_defn_to_vec (struct obstack
*obstackp
,
4838 const struct block
*block
)
4841 struct block_symbol
*prevDefns
= defns_collected (obstackp
, 0);
4843 /* Do not try to complete stub types, as the debugger is probably
4844 already scanning all symbols matching a certain name at the
4845 time when this function is called. Trying to replace the stub
4846 type by its associated full type will cause us to restart a scan
4847 which may lead to an infinite recursion. Instead, the client
4848 collecting the matching symbols will end up collecting several
4849 matches, with at least one of them complete. It can then filter
4850 out the stub ones if needed. */
4852 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4854 if (lesseq_defined_than (sym
, prevDefns
[i
].symbol
))
4856 else if (lesseq_defined_than (prevDefns
[i
].symbol
, sym
))
4858 prevDefns
[i
].symbol
= sym
;
4859 prevDefns
[i
].block
= block
;
4865 struct block_symbol info
;
4869 obstack_grow (obstackp
, &info
, sizeof (struct block_symbol
));
4873 /* Number of block_symbol structures currently collected in current vector in
4877 num_defns_collected (struct obstack
*obstackp
)
4879 return obstack_object_size (obstackp
) / sizeof (struct block_symbol
);
4882 /* Vector of block_symbol structures currently collected in current vector in
4883 OBSTACKP. If FINISH, close off the vector and return its final address. */
4885 static struct block_symbol
*
4886 defns_collected (struct obstack
*obstackp
, int finish
)
4889 return (struct block_symbol
*) obstack_finish (obstackp
);
4891 return (struct block_symbol
*) obstack_base (obstackp
);
4894 /* Return a bound minimal symbol matching NAME according to Ada
4895 decoding rules. Returns an invalid symbol if there is no such
4896 minimal symbol. Names prefixed with "standard__" are handled
4897 specially: "standard__" is first stripped off, and only static and
4898 global symbols are searched. */
4900 struct bound_minimal_symbol
4901 ada_lookup_simple_minsym (const char *name
)
4903 struct bound_minimal_symbol result
;
4905 memset (&result
, 0, sizeof (result
));
4907 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4908 lookup_name_info
lookup_name (name
, match_type
);
4910 symbol_name_matcher_ftype
*match_name
4911 = ada_get_symbol_name_matcher (lookup_name
);
4913 for (objfile
*objfile
: current_program_space
->objfiles ())
4915 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4917 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol
), lookup_name
, NULL
)
4918 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4920 result
.minsym
= msymbol
;
4921 result
.objfile
= objfile
;
4930 /* Return all the bound minimal symbols matching NAME according to Ada
4931 decoding rules. Returns an empty vector if there is no such
4932 minimal symbol. Names prefixed with "standard__" are handled
4933 specially: "standard__" is first stripped off, and only static and
4934 global symbols are searched. */
4936 static std::vector
<struct bound_minimal_symbol
>
4937 ada_lookup_simple_minsyms (const char *name
)
4939 std::vector
<struct bound_minimal_symbol
> result
;
4941 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4942 lookup_name_info
lookup_name (name
, match_type
);
4944 symbol_name_matcher_ftype
*match_name
4945 = ada_get_symbol_name_matcher (lookup_name
);
4947 for (objfile
*objfile
: current_program_space
->objfiles ())
4949 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4951 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol
), lookup_name
, NULL
)
4952 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4953 result
.push_back ({msymbol
, objfile
});
4960 /* For all subprograms that statically enclose the subprogram of the
4961 selected frame, add symbols matching identifier NAME in DOMAIN
4962 and their blocks to the list of data in OBSTACKP, as for
4963 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4964 with a wildcard prefix. */
4967 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4968 const lookup_name_info
&lookup_name
,
4973 /* True if TYPE is definitely an artificial type supplied to a symbol
4974 for which no debugging information was given in the symbol file. */
4977 is_nondebugging_type (struct type
*type
)
4979 const char *name
= ada_type_name (type
);
4981 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4984 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4985 that are deemed "identical" for practical purposes.
4987 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4988 types and that their number of enumerals is identical (in other
4989 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4992 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4996 /* The heuristic we use here is fairly conservative. We consider
4997 that 2 enumerate types are identical if they have the same
4998 number of enumerals and that all enumerals have the same
4999 underlying value and name. */
5001 /* All enums in the type should have an identical underlying value. */
5002 for (i
= 0; i
< TYPE_NFIELDS (type1
); i
++)
5003 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
5006 /* All enumerals should also have the same name (modulo any numerical
5008 for (i
= 0; i
< TYPE_NFIELDS (type1
); i
++)
5010 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
5011 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
5012 int len_1
= strlen (name_1
);
5013 int len_2
= strlen (name_2
);
5015 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
5016 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
5018 || strncmp (TYPE_FIELD_NAME (type1
, i
),
5019 TYPE_FIELD_NAME (type2
, i
),
5027 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
5028 that are deemed "identical" for practical purposes. Sometimes,
5029 enumerals are not strictly identical, but their types are so similar
5030 that they can be considered identical.
5032 For instance, consider the following code:
5034 type Color is (Black, Red, Green, Blue, White);
5035 type RGB_Color is new Color range Red .. Blue;
5037 Type RGB_Color is a subrange of an implicit type which is a copy
5038 of type Color. If we call that implicit type RGB_ColorB ("B" is
5039 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5040 As a result, when an expression references any of the enumeral
5041 by name (Eg. "print green"), the expression is technically
5042 ambiguous and the user should be asked to disambiguate. But
5043 doing so would only hinder the user, since it wouldn't matter
5044 what choice he makes, the outcome would always be the same.
5045 So, for practical purposes, we consider them as the same. */
5048 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
5052 /* Before performing a thorough comparison check of each type,
5053 we perform a series of inexpensive checks. We expect that these
5054 checks will quickly fail in the vast majority of cases, and thus
5055 help prevent the unnecessary use of a more expensive comparison.
5056 Said comparison also expects us to make some of these checks
5057 (see ada_identical_enum_types_p). */
5059 /* Quick check: All symbols should have an enum type. */
5060 for (i
= 0; i
< syms
.size (); i
++)
5061 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].symbol
)) != TYPE_CODE_ENUM
)
5064 /* Quick check: They should all have the same value. */
5065 for (i
= 1; i
< syms
.size (); i
++)
5066 if (SYMBOL_VALUE (syms
[i
].symbol
) != SYMBOL_VALUE (syms
[0].symbol
))
5069 /* Quick check: They should all have the same number of enumerals. */
5070 for (i
= 1; i
< syms
.size (); i
++)
5071 if (TYPE_NFIELDS (SYMBOL_TYPE (syms
[i
].symbol
))
5072 != TYPE_NFIELDS (SYMBOL_TYPE (syms
[0].symbol
)))
5075 /* All the sanity checks passed, so we might have a set of
5076 identical enumeration types. Perform a more complete
5077 comparison of the type of each symbol. */
5078 for (i
= 1; i
< syms
.size (); i
++)
5079 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].symbol
),
5080 SYMBOL_TYPE (syms
[0].symbol
)))
5086 /* Remove any non-debugging symbols in SYMS that definitely
5087 duplicate other symbols in the list (The only case I know of where
5088 this happens is when object files containing stabs-in-ecoff are
5089 linked with files containing ordinary ecoff debugging symbols (or no
5090 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5091 Returns the number of items in the modified list. */
5094 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
5098 /* We should never be called with less than 2 symbols, as there
5099 cannot be any extra symbol in that case. But it's easy to
5100 handle, since we have nothing to do in that case. */
5101 if (syms
->size () < 2)
5102 return syms
->size ();
5105 while (i
< syms
->size ())
5109 /* If two symbols have the same name and one of them is a stub type,
5110 the get rid of the stub. */
5112 if (TYPE_STUB (SYMBOL_TYPE ((*syms
)[i
].symbol
))
5113 && SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
) != NULL
)
5115 for (j
= 0; j
< syms
->size (); j
++)
5118 && !TYPE_STUB (SYMBOL_TYPE ((*syms
)[j
].symbol
))
5119 && SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
) != NULL
5120 && strcmp (SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
),
5121 SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
)) == 0)
5126 /* Two symbols with the same name, same class and same address
5127 should be identical. */
5129 else if (SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
) != NULL
5130 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5131 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5133 for (j
= 0; j
< syms
->size (); j
+= 1)
5136 && SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
) != NULL
5137 && strcmp (SYMBOL_LINKAGE_NAME ((*syms
)[i
].symbol
),
5138 SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
)) == 0
5139 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5140 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5141 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5142 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5148 syms
->erase (syms
->begin () + i
);
5153 /* If all the remaining symbols are identical enumerals, then
5154 just keep the first one and discard the rest.
5156 Unlike what we did previously, we do not discard any entry
5157 unless they are ALL identical. This is because the symbol
5158 comparison is not a strict comparison, but rather a practical
5159 comparison. If all symbols are considered identical, then
5160 we can just go ahead and use the first one and discard the rest.
5161 But if we cannot reduce the list to a single element, we have
5162 to ask the user to disambiguate anyways. And if we have to
5163 present a multiple-choice menu, it's less confusing if the list
5164 isn't missing some choices that were identical and yet distinct. */
5165 if (symbols_are_identical_enums (*syms
))
5168 return syms
->size ();
5171 /* Given a type that corresponds to a renaming entity, use the type name
5172 to extract the scope (package name or function name, fully qualified,
5173 and following the GNAT encoding convention) where this renaming has been
5177 xget_renaming_scope (struct type
*renaming_type
)
5179 /* The renaming types adhere to the following convention:
5180 <scope>__<rename>___<XR extension>.
5181 So, to extract the scope, we search for the "___XR" extension,
5182 and then backtrack until we find the first "__". */
5184 const char *name
= TYPE_NAME (renaming_type
);
5185 const char *suffix
= strstr (name
, "___XR");
5188 /* Now, backtrack a bit until we find the first "__". Start looking
5189 at suffix - 3, as the <rename> part is at least one character long. */
5191 for (last
= suffix
- 3; last
> name
; last
--)
5192 if (last
[0] == '_' && last
[1] == '_')
5195 /* Make a copy of scope and return it. */
5196 return std::string (name
, last
);
5199 /* Return nonzero if NAME corresponds to a package name. */
5202 is_package_name (const char *name
)
5204 /* Here, We take advantage of the fact that no symbols are generated
5205 for packages, while symbols are generated for each function.
5206 So the condition for NAME represent a package becomes equivalent
5207 to NAME not existing in our list of symbols. There is only one
5208 small complication with library-level functions (see below). */
5210 /* If it is a function that has not been defined at library level,
5211 then we should be able to look it up in the symbols. */
5212 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5215 /* Library-level function names start with "_ada_". See if function
5216 "_ada_" followed by NAME can be found. */
5218 /* Do a quick check that NAME does not contain "__", since library-level
5219 functions names cannot contain "__" in them. */
5220 if (strstr (name
, "__") != NULL
)
5223 std::string fun_name
= string_printf ("_ada_%s", name
);
5225 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5228 /* Return nonzero if SYM corresponds to a renaming entity that is
5229 not visible from FUNCTION_NAME. */
5232 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5234 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5237 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5239 /* If the rename has been defined in a package, then it is visible. */
5240 if (is_package_name (scope
.c_str ()))
5243 /* Check that the rename is in the current function scope by checking
5244 that its name starts with SCOPE. */
5246 /* If the function name starts with "_ada_", it means that it is
5247 a library-level function. Strip this prefix before doing the
5248 comparison, as the encoding for the renaming does not contain
5250 if (startswith (function_name
, "_ada_"))
5253 return !startswith (function_name
, scope
.c_str ());
5256 /* Remove entries from SYMS that corresponds to a renaming entity that
5257 is not visible from the function associated with CURRENT_BLOCK or
5258 that is superfluous due to the presence of more specific renaming
5259 information. Places surviving symbols in the initial entries of
5260 SYMS and returns the number of surviving symbols.
5263 First, in cases where an object renaming is implemented as a
5264 reference variable, GNAT may produce both the actual reference
5265 variable and the renaming encoding. In this case, we discard the
5268 Second, GNAT emits a type following a specified encoding for each renaming
5269 entity. Unfortunately, STABS currently does not support the definition
5270 of types that are local to a given lexical block, so all renamings types
5271 are emitted at library level. As a consequence, if an application
5272 contains two renaming entities using the same name, and a user tries to
5273 print the value of one of these entities, the result of the ada symbol
5274 lookup will also contain the wrong renaming type.
5276 This function partially covers for this limitation by attempting to
5277 remove from the SYMS list renaming symbols that should be visible
5278 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5279 method with the current information available. The implementation
5280 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5282 - When the user tries to print a rename in a function while there
5283 is another rename entity defined in a package: Normally, the
5284 rename in the function has precedence over the rename in the
5285 package, so the latter should be removed from the list. This is
5286 currently not the case.
5288 - This function will incorrectly remove valid renames if
5289 the CURRENT_BLOCK corresponds to a function which symbol name
5290 has been changed by an "Export" pragma. As a consequence,
5291 the user will be unable to print such rename entities. */
5294 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5295 const struct block
*current_block
)
5297 struct symbol
*current_function
;
5298 const char *current_function_name
;
5300 int is_new_style_renaming
;
5302 /* If there is both a renaming foo___XR... encoded as a variable and
5303 a simple variable foo in the same block, discard the latter.
5304 First, zero out such symbols, then compress. */
5305 is_new_style_renaming
= 0;
5306 for (i
= 0; i
< syms
->size (); i
+= 1)
5308 struct symbol
*sym
= (*syms
)[i
].symbol
;
5309 const struct block
*block
= (*syms
)[i
].block
;
5313 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5315 name
= SYMBOL_LINKAGE_NAME (sym
);
5316 suffix
= strstr (name
, "___XR");
5320 int name_len
= suffix
- name
;
5323 is_new_style_renaming
= 1;
5324 for (j
= 0; j
< syms
->size (); j
+= 1)
5325 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5326 && strncmp (name
, SYMBOL_LINKAGE_NAME ((*syms
)[j
].symbol
),
5328 && block
== (*syms
)[j
].block
)
5329 (*syms
)[j
].symbol
= NULL
;
5332 if (is_new_style_renaming
)
5336 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5337 if ((*syms
)[j
].symbol
!= NULL
)
5339 (*syms
)[k
] = (*syms
)[j
];
5345 /* Extract the function name associated to CURRENT_BLOCK.
5346 Abort if unable to do so. */
5348 if (current_block
== NULL
)
5349 return syms
->size ();
5351 current_function
= block_linkage_function (current_block
);
5352 if (current_function
== NULL
)
5353 return syms
->size ();
5355 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
5356 if (current_function_name
== NULL
)
5357 return syms
->size ();
5359 /* Check each of the symbols, and remove it from the list if it is
5360 a type corresponding to a renaming that is out of the scope of
5361 the current block. */
5364 while (i
< syms
->size ())
5366 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5367 == ADA_OBJECT_RENAMING
5368 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5369 current_function_name
))
5370 syms
->erase (syms
->begin () + i
);
5375 return syms
->size ();
5378 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5379 whose name and domain match NAME and DOMAIN respectively.
5380 If no match was found, then extend the search to "enclosing"
5381 routines (in other words, if we're inside a nested function,
5382 search the symbols defined inside the enclosing functions).
5383 If WILD_MATCH_P is nonzero, perform the naming matching in
5384 "wild" mode (see function "wild_match" for more info).
5386 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5389 ada_add_local_symbols (struct obstack
*obstackp
,
5390 const lookup_name_info
&lookup_name
,
5391 const struct block
*block
, domain_enum domain
)
5393 int block_depth
= 0;
5395 while (block
!= NULL
)
5398 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5400 /* If we found a non-function match, assume that's the one. */
5401 if (is_nonfunction (defns_collected (obstackp
, 0),
5402 num_defns_collected (obstackp
)))
5405 block
= BLOCK_SUPERBLOCK (block
);
5408 /* If no luck so far, try to find NAME as a local symbol in some lexically
5409 enclosing subprogram. */
5410 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5411 add_symbols_from_enclosing_procs (obstackp
, lookup_name
, domain
);
5414 /* An object of this type is used as the user_data argument when
5415 calling the map_matching_symbols method. */
5419 struct objfile
*objfile
;
5420 struct obstack
*obstackp
;
5421 struct symbol
*arg_sym
;
5425 /* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
5426 to a list of symbols. DATA0 is a pointer to a struct match_data *
5427 containing the obstack that collects the symbol list, the file that SYM
5428 must come from, a flag indicating whether a non-argument symbol has
5429 been found in the current block, and the last argument symbol
5430 passed in SYM within the current block (if any). When SYM is null,
5431 marking the end of a block, the argument symbol is added if no
5432 other has been found. */
5435 aux_add_nonlocal_symbols (const struct block
*block
, struct symbol
*sym
,
5438 struct match_data
*data
= (struct match_data
*) data0
;
5442 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5443 add_defn_to_vec (data
->obstackp
,
5444 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5446 data
->found_sym
= 0;
5447 data
->arg_sym
= NULL
;
5451 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5453 else if (SYMBOL_IS_ARGUMENT (sym
))
5454 data
->arg_sym
= sym
;
5457 data
->found_sym
= 1;
5458 add_defn_to_vec (data
->obstackp
,
5459 fixup_symbol_section (sym
, data
->objfile
),
5466 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5467 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5468 symbols to OBSTACKP. Return whether we found such symbols. */
5471 ada_add_block_renamings (struct obstack
*obstackp
,
5472 const struct block
*block
,
5473 const lookup_name_info
&lookup_name
,
5476 struct using_direct
*renaming
;
5477 int defns_mark
= num_defns_collected (obstackp
);
5479 symbol_name_matcher_ftype
*name_match
5480 = ada_get_symbol_name_matcher (lookup_name
);
5482 for (renaming
= block_using (block
);
5484 renaming
= renaming
->next
)
5488 /* Avoid infinite recursions: skip this renaming if we are actually
5489 already traversing it.
5491 Currently, symbol lookup in Ada don't use the namespace machinery from
5492 C++/Fortran support: skip namespace imports that use them. */
5493 if (renaming
->searched
5494 || (renaming
->import_src
!= NULL
5495 && renaming
->import_src
[0] != '\0')
5496 || (renaming
->import_dest
!= NULL
5497 && renaming
->import_dest
[0] != '\0'))
5499 renaming
->searched
= 1;
5501 /* TODO: here, we perform another name-based symbol lookup, which can
5502 pull its own multiple overloads. In theory, we should be able to do
5503 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5504 not a simple name. But in order to do this, we would need to enhance
5505 the DWARF reader to associate a symbol to this renaming, instead of a
5506 name. So, for now, we do something simpler: re-use the C++/Fortran
5507 namespace machinery. */
5508 r_name
= (renaming
->alias
!= NULL
5510 : renaming
->declaration
);
5511 if (name_match (r_name
, lookup_name
, NULL
))
5513 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5514 lookup_name
.match_type ());
5515 ada_add_all_symbols (obstackp
, block
, decl_lookup_name
, domain
,
5518 renaming
->searched
= 0;
5520 return num_defns_collected (obstackp
) != defns_mark
;
5523 /* Implements compare_names, but only applying the comparision using
5524 the given CASING. */
5527 compare_names_with_case (const char *string1
, const char *string2
,
5528 enum case_sensitivity casing
)
5530 while (*string1
!= '\0' && *string2
!= '\0')
5534 if (isspace (*string1
) || isspace (*string2
))
5535 return strcmp_iw_ordered (string1
, string2
);
5537 if (casing
== case_sensitive_off
)
5539 c1
= tolower (*string1
);
5540 c2
= tolower (*string2
);
5557 return strcmp_iw_ordered (string1
, string2
);
5559 if (*string2
== '\0')
5561 if (is_name_suffix (string1
))
5568 if (*string2
== '(')
5569 return strcmp_iw_ordered (string1
, string2
);
5572 if (casing
== case_sensitive_off
)
5573 return tolower (*string1
) - tolower (*string2
);
5575 return *string1
- *string2
;
5580 /* Compare STRING1 to STRING2, with results as for strcmp.
5581 Compatible with strcmp_iw_ordered in that...
5583 strcmp_iw_ordered (STRING1, STRING2) <= 0
5587 compare_names (STRING1, STRING2) <= 0
5589 (they may differ as to what symbols compare equal). */
5592 compare_names (const char *string1
, const char *string2
)
5596 /* Similar to what strcmp_iw_ordered does, we need to perform
5597 a case-insensitive comparison first, and only resort to
5598 a second, case-sensitive, comparison if the first one was
5599 not sufficient to differentiate the two strings. */
5601 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5603 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5608 /* Convenience function to get at the Ada encoded lookup name for
5609 LOOKUP_NAME, as a C string. */
5612 ada_lookup_name (const lookup_name_info
&lookup_name
)
5614 return lookup_name
.ada ().lookup_name ().c_str ();
5617 /* Add to OBSTACKP all non-local symbols whose name and domain match
5618 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5619 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5620 symbols otherwise. */
5623 add_nonlocal_symbols (struct obstack
*obstackp
,
5624 const lookup_name_info
&lookup_name
,
5625 domain_enum domain
, int global
)
5627 struct match_data data
;
5629 memset (&data
, 0, sizeof data
);
5630 data
.obstackp
= obstackp
;
5632 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5634 for (objfile
*objfile
: current_program_space
->objfiles ())
5636 data
.objfile
= objfile
;
5639 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
.name ().c_str (),
5641 aux_add_nonlocal_symbols
, &data
,
5642 symbol_name_match_type::WILD
,
5645 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
.name ().c_str (),
5647 aux_add_nonlocal_symbols
, &data
,
5648 symbol_name_match_type::FULL
,
5651 for (compunit_symtab
*cu
: objfile
->compunits ())
5653 const struct block
*global_block
5654 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5656 if (ada_add_block_renamings (obstackp
, global_block
, lookup_name
,
5662 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
5664 const char *name
= ada_lookup_name (lookup_name
);
5665 std::string name1
= std::string ("<_ada_") + name
+ '>';
5667 for (objfile
*objfile
: current_program_space
->objfiles ())
5669 data
.objfile
= objfile
;
5670 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
.c_str (),
5672 aux_add_nonlocal_symbols
,
5674 symbol_name_match_type::FULL
,
5680 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5681 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5682 returning the number of matches. Add these to OBSTACKP.
5684 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5685 symbol match within the nest of blocks whose innermost member is BLOCK,
5686 is the one match returned (no other matches in that or
5687 enclosing blocks is returned). If there are any matches in or
5688 surrounding BLOCK, then these alone are returned.
5690 Names prefixed with "standard__" are handled specially:
5691 "standard__" is first stripped off (by the lookup_name
5692 constructor), and only static and global symbols are searched.
5694 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5695 to lookup global symbols. */
5698 ada_add_all_symbols (struct obstack
*obstackp
,
5699 const struct block
*block
,
5700 const lookup_name_info
&lookup_name
,
5703 int *made_global_lookup_p
)
5707 if (made_global_lookup_p
)
5708 *made_global_lookup_p
= 0;
5710 /* Special case: If the user specifies a symbol name inside package
5711 Standard, do a non-wild matching of the symbol name without
5712 the "standard__" prefix. This was primarily introduced in order
5713 to allow the user to specifically access the standard exceptions
5714 using, for instance, Standard.Constraint_Error when Constraint_Error
5715 is ambiguous (due to the user defining its own Constraint_Error
5716 entity inside its program). */
5717 if (lookup_name
.ada ().standard_p ())
5720 /* Check the non-global symbols. If we have ANY match, then we're done. */
5725 ada_add_local_symbols (obstackp
, lookup_name
, block
, domain
);
5728 /* In the !full_search case we're are being called by
5729 ada_iterate_over_symbols, and we don't want to search
5731 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5733 if (num_defns_collected (obstackp
) > 0 || !full_search
)
5737 /* No non-global symbols found. Check our cache to see if we have
5738 already performed this search before. If we have, then return
5741 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5742 domain
, &sym
, &block
))
5745 add_defn_to_vec (obstackp
, sym
, block
);
5749 if (made_global_lookup_p
)
5750 *made_global_lookup_p
= 1;
5752 /* Search symbols from all global blocks. */
5754 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 1);
5756 /* Now add symbols from all per-file blocks if we've gotten no hits
5757 (not strictly correct, but perhaps better than an error). */
5759 if (num_defns_collected (obstackp
) == 0)
5760 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 0);
5763 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5764 is non-zero, enclosing scope and in global scopes, returning the number of
5766 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5767 found and the blocks and symbol tables (if any) in which they were
5770 When full_search is non-zero, any non-function/non-enumeral
5771 symbol match within the nest of blocks whose innermost member is BLOCK,
5772 is the one match returned (no other matches in that or
5773 enclosing blocks is returned). If there are any matches in or
5774 surrounding BLOCK, then these alone are returned.
5776 Names prefixed with "standard__" are handled specially: "standard__"
5777 is first stripped off, and only static and global symbols are searched. */
5780 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5781 const struct block
*block
,
5783 std::vector
<struct block_symbol
> *results
,
5786 int syms_from_global_search
;
5788 auto_obstack obstack
;
5790 ada_add_all_symbols (&obstack
, block
, lookup_name
,
5791 domain
, full_search
, &syms_from_global_search
);
5793 ndefns
= num_defns_collected (&obstack
);
5795 struct block_symbol
*base
= defns_collected (&obstack
, 1);
5796 for (int i
= 0; i
< ndefns
; ++i
)
5797 results
->push_back (base
[i
]);
5799 ndefns
= remove_extra_symbols (results
);
5801 if (ndefns
== 0 && full_search
&& syms_from_global_search
)
5802 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5804 if (ndefns
== 1 && full_search
&& syms_from_global_search
)
5805 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5806 (*results
)[0].symbol
, (*results
)[0].block
);
5808 ndefns
= remove_irrelevant_renamings (results
, block
);
5813 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5814 in global scopes, returning the number of matches, and filling *RESULTS
5815 with (SYM,BLOCK) tuples.
5817 See ada_lookup_symbol_list_worker for further details. */
5820 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5822 std::vector
<struct block_symbol
> *results
)
5824 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5825 lookup_name_info
lookup_name (name
, name_match_type
);
5827 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, results
, 1);
5830 /* Implementation of the la_iterate_over_symbols method. */
5833 ada_iterate_over_symbols
5834 (const struct block
*block
, const lookup_name_info
&name
,
5836 gdb::function_view
<symbol_found_callback_ftype
> callback
)
5839 std::vector
<struct block_symbol
> results
;
5841 ndefs
= ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
5843 for (i
= 0; i
< ndefs
; ++i
)
5845 if (!callback (&results
[i
]))
5850 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5851 to 1, but choosing the first symbol found if there are multiple
5854 The result is stored in *INFO, which must be non-NULL.
5855 If no match is found, INFO->SYM is set to NULL. */
5858 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5860 struct block_symbol
*info
)
5862 /* Since we already have an encoded name, wrap it in '<>' to force a
5863 verbatim match. Otherwise, if the name happens to not look like
5864 an encoded name (because it doesn't include a "__"),
5865 ada_lookup_name_info would re-encode/fold it again, and that
5866 would e.g., incorrectly lowercase object renaming names like
5867 "R28b" -> "r28b". */
5868 std::string verbatim
= std::string ("<") + name
+ '>';
5870 gdb_assert (info
!= NULL
);
5871 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
, NULL
);
5874 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5875 scope and in global scopes, or NULL if none. NAME is folded and
5876 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5877 choosing the first symbol if there are multiple choices.
5878 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5881 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5882 domain_enum domain
, int *is_a_field_of_this
)
5884 if (is_a_field_of_this
!= NULL
)
5885 *is_a_field_of_this
= 0;
5887 std::vector
<struct block_symbol
> candidates
;
5890 n_candidates
= ada_lookup_symbol_list (name
, block0
, domain
, &candidates
);
5892 if (n_candidates
== 0)
5895 block_symbol info
= candidates
[0];
5896 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5900 static struct block_symbol
5901 ada_lookup_symbol_nonlocal (const struct language_defn
*langdef
,
5903 const struct block
*block
,
5904 const domain_enum domain
)
5906 struct block_symbol sym
;
5908 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
, NULL
);
5909 if (sym
.symbol
!= NULL
)
5912 /* If we haven't found a match at this point, try the primitive
5913 types. In other languages, this search is performed before
5914 searching for global symbols in order to short-circuit that
5915 global-symbol search if it happens that the name corresponds
5916 to a primitive type. But we cannot do the same in Ada, because
5917 it is perfectly legitimate for a program to declare a type which
5918 has the same name as a standard type. If looking up a type in
5919 that situation, we have traditionally ignored the primitive type
5920 in favor of user-defined types. This is why, unlike most other
5921 languages, we search the primitive types this late and only after
5922 having searched the global symbols without success. */
5924 if (domain
== VAR_DOMAIN
)
5926 struct gdbarch
*gdbarch
;
5929 gdbarch
= target_gdbarch ();
5931 gdbarch
= block_gdbarch (block
);
5932 sym
.symbol
= language_lookup_primitive_type_as_symbol (langdef
, gdbarch
, name
);
5933 if (sym
.symbol
!= NULL
)
5941 /* True iff STR is a possible encoded suffix of a normal Ada name
5942 that is to be ignored for matching purposes. Suffixes of parallel
5943 names (e.g., XVE) are not included here. Currently, the possible suffixes
5944 are given by any of the regular expressions:
5946 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5947 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5948 TKB [subprogram suffix for task bodies]
5949 _E[0-9]+[bs]$ [protected object entry suffixes]
5950 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5952 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5953 match is performed. This sequence is used to differentiate homonyms,
5954 is an optional part of a valid name suffix. */
5957 is_name_suffix (const char *str
)
5960 const char *matching
;
5961 const int len
= strlen (str
);
5963 /* Skip optional leading __[0-9]+. */
5965 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5968 while (isdigit (str
[0]))
5974 if (str
[0] == '.' || str
[0] == '$')
5977 while (isdigit (matching
[0]))
5979 if (matching
[0] == '\0')
5985 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5988 while (isdigit (matching
[0]))
5990 if (matching
[0] == '\0')
5994 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5996 if (strcmp (str
, "TKB") == 0)
6000 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
6001 with a N at the end. Unfortunately, the compiler uses the same
6002 convention for other internal types it creates. So treating
6003 all entity names that end with an "N" as a name suffix causes
6004 some regressions. For instance, consider the case of an enumerated
6005 type. To support the 'Image attribute, it creates an array whose
6007 Having a single character like this as a suffix carrying some
6008 information is a bit risky. Perhaps we should change the encoding
6009 to be something like "_N" instead. In the meantime, do not do
6010 the following check. */
6011 /* Protected Object Subprograms */
6012 if (len
== 1 && str
[0] == 'N')
6017 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
6020 while (isdigit (matching
[0]))
6022 if ((matching
[0] == 'b' || matching
[0] == 's')
6023 && matching
[1] == '\0')
6027 /* ??? We should not modify STR directly, as we are doing below. This
6028 is fine in this case, but may become problematic later if we find
6029 that this alternative did not work, and want to try matching
6030 another one from the begining of STR. Since we modified it, we
6031 won't be able to find the begining of the string anymore! */
6035 while (str
[0] != '_' && str
[0] != '\0')
6037 if (str
[0] != 'n' && str
[0] != 'b')
6043 if (str
[0] == '\000')
6048 if (str
[1] != '_' || str
[2] == '\000')
6052 if (strcmp (str
+ 3, "JM") == 0)
6054 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6055 the LJM suffix in favor of the JM one. But we will
6056 still accept LJM as a valid suffix for a reasonable
6057 amount of time, just to allow ourselves to debug programs
6058 compiled using an older version of GNAT. */
6059 if (strcmp (str
+ 3, "LJM") == 0)
6063 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
6064 || str
[4] == 'U' || str
[4] == 'P')
6066 if (str
[4] == 'R' && str
[5] != 'T')
6070 if (!isdigit (str
[2]))
6072 for (k
= 3; str
[k
] != '\0'; k
+= 1)
6073 if (!isdigit (str
[k
]) && str
[k
] != '_')
6077 if (str
[0] == '$' && isdigit (str
[1]))
6079 for (k
= 2; str
[k
] != '\0'; k
+= 1)
6080 if (!isdigit (str
[k
]) && str
[k
] != '_')
6087 /* Return non-zero if the string starting at NAME and ending before
6088 NAME_END contains no capital letters. */
6091 is_valid_name_for_wild_match (const char *name0
)
6093 const char *decoded_name
= ada_decode (name0
);
6096 /* If the decoded name starts with an angle bracket, it means that
6097 NAME0 does not follow the GNAT encoding format. It should then
6098 not be allowed as a possible wild match. */
6099 if (decoded_name
[0] == '<')
6102 for (i
=0; decoded_name
[i
] != '\0'; i
++)
6103 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
6109 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6110 that could start a simple name. Assumes that *NAMEP points into
6111 the string beginning at NAME0. */
6114 advance_wild_match (const char **namep
, const char *name0
, int target0
)
6116 const char *name
= *namep
;
6126 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
6129 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
6134 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
6135 || name
[2] == target0
))
6143 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
6153 /* Return true iff NAME encodes a name of the form prefix.PATN.
6154 Ignores any informational suffixes of NAME (i.e., for which
6155 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6159 wild_match (const char *name
, const char *patn
)
6162 const char *name0
= name
;
6166 const char *match
= name
;
6170 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
6173 if (*p
== '\0' && is_name_suffix (name
))
6174 return match
== name0
|| is_valid_name_for_wild_match (name0
);
6176 if (name
[-1] == '_')
6179 if (!advance_wild_match (&name
, name0
, *patn
))
6184 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6185 any trailing suffixes that encode debugging information or leading
6186 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6187 information that is ignored). */
6190 full_match (const char *sym_name
, const char *search_name
)
6192 size_t search_name_len
= strlen (search_name
);
6194 if (strncmp (sym_name
, search_name
, search_name_len
) == 0
6195 && is_name_suffix (sym_name
+ search_name_len
))
6198 if (startswith (sym_name
, "_ada_")
6199 && strncmp (sym_name
+ 5, search_name
, search_name_len
) == 0
6200 && is_name_suffix (sym_name
+ search_name_len
+ 5))
6206 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6207 *defn_symbols, updating the list of symbols in OBSTACKP (if
6208 necessary). OBJFILE is the section containing BLOCK. */
6211 ada_add_block_symbols (struct obstack
*obstackp
,
6212 const struct block
*block
,
6213 const lookup_name_info
&lookup_name
,
6214 domain_enum domain
, struct objfile
*objfile
)
6216 struct block_iterator iter
;
6217 /* A matching argument symbol, if any. */
6218 struct symbol
*arg_sym
;
6219 /* Set true when we find a matching non-argument symbol. */
6225 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6227 sym
= block_iter_match_next (lookup_name
, &iter
))
6229 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
6230 SYMBOL_DOMAIN (sym
), domain
))
6232 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6234 if (SYMBOL_IS_ARGUMENT (sym
))
6239 add_defn_to_vec (obstackp
,
6240 fixup_symbol_section (sym
, objfile
),
6247 /* Handle renamings. */
6249 if (ada_add_block_renamings (obstackp
, block
, lookup_name
, domain
))
6252 if (!found_sym
&& arg_sym
!= NULL
)
6254 add_defn_to_vec (obstackp
,
6255 fixup_symbol_section (arg_sym
, objfile
),
6259 if (!lookup_name
.ada ().wild_match_p ())
6263 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6264 const char *name
= ada_lookup_name
.c_str ();
6265 size_t name_len
= ada_lookup_name
.size ();
6267 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6269 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
6270 SYMBOL_DOMAIN (sym
), domain
))
6274 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
6277 cmp
= !startswith (SYMBOL_LINKAGE_NAME (sym
), "_ada_");
6279 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
6284 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
6286 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6288 if (SYMBOL_IS_ARGUMENT (sym
))
6293 add_defn_to_vec (obstackp
,
6294 fixup_symbol_section (sym
, objfile
),
6302 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6303 They aren't parameters, right? */
6304 if (!found_sym
&& arg_sym
!= NULL
)
6306 add_defn_to_vec (obstackp
,
6307 fixup_symbol_section (arg_sym
, objfile
),
6314 /* Symbol Completion */
6319 ada_lookup_name_info::matches
6320 (const char *sym_name
,
6321 symbol_name_match_type match_type
,
6322 completion_match_result
*comp_match_res
) const
6325 const char *text
= m_encoded_name
.c_str ();
6326 size_t text_len
= m_encoded_name
.size ();
6328 /* First, test against the fully qualified name of the symbol. */
6330 if (strncmp (sym_name
, text
, text_len
) == 0)
6333 if (match
&& !m_encoded_p
)
6335 /* One needed check before declaring a positive match is to verify
6336 that iff we are doing a verbatim match, the decoded version
6337 of the symbol name starts with '<'. Otherwise, this symbol name
6338 is not a suitable completion. */
6339 const char *sym_name_copy
= sym_name
;
6340 bool has_angle_bracket
;
6342 sym_name
= ada_decode (sym_name
);
6343 has_angle_bracket
= (sym_name
[0] == '<');
6344 match
= (has_angle_bracket
== m_verbatim_p
);
6345 sym_name
= sym_name_copy
;
6348 if (match
&& !m_verbatim_p
)
6350 /* When doing non-verbatim match, another check that needs to
6351 be done is to verify that the potentially matching symbol name
6352 does not include capital letters, because the ada-mode would
6353 not be able to understand these symbol names without the
6354 angle bracket notation. */
6357 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6362 /* Second: Try wild matching... */
6364 if (!match
&& m_wild_match_p
)
6366 /* Since we are doing wild matching, this means that TEXT
6367 may represent an unqualified symbol name. We therefore must
6368 also compare TEXT against the unqualified name of the symbol. */
6369 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
6371 if (strncmp (sym_name
, text
, text_len
) == 0)
6375 /* Finally: If we found a match, prepare the result to return. */
6380 if (comp_match_res
!= NULL
)
6382 std::string
&match_str
= comp_match_res
->match
.storage ();
6385 match_str
= ada_decode (sym_name
);
6389 match_str
= add_angle_brackets (sym_name
);
6391 match_str
= sym_name
;
6395 comp_match_res
->set_match (match_str
.c_str ());
6401 /* Add the list of possible symbol names completing TEXT to TRACKER.
6402 WORD is the entire command on which completion is made. */
6405 ada_collect_symbol_completion_matches (completion_tracker
&tracker
,
6406 complete_symbol_mode mode
,
6407 symbol_name_match_type name_match_type
,
6408 const char *text
, const char *word
,
6409 enum type_code code
)
6412 const struct block
*b
, *surrounding_static_block
= 0;
6413 struct block_iterator iter
;
6415 gdb_assert (code
== TYPE_CODE_UNDEF
);
6417 lookup_name_info
lookup_name (text
, name_match_type
, true);
6419 /* First, look at the partial symtab symbols. */
6420 expand_symtabs_matching (NULL
,
6426 /* At this point scan through the misc symbol vectors and add each
6427 symbol you find to the list. Eventually we want to ignore
6428 anything that isn't a text symbol (everything else will be
6429 handled by the psymtab code above). */
6431 for (objfile
*objfile
: current_program_space
->objfiles ())
6433 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
6437 if (completion_skip_symbol (mode
, msymbol
))
6440 language symbol_language
= MSYMBOL_LANGUAGE (msymbol
);
6442 /* Ada minimal symbols won't have their language set to Ada. If
6443 we let completion_list_add_name compare using the
6444 default/C-like matcher, then when completing e.g., symbols in a
6445 package named "pck", we'd match internal Ada symbols like
6446 "pckS", which are invalid in an Ada expression, unless you wrap
6447 them in '<' '>' to request a verbatim match.
6449 Unfortunately, some Ada encoded names successfully demangle as
6450 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6451 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6452 with the wrong language set. Paper over that issue here. */
6453 if (symbol_language
== language_auto
6454 || symbol_language
== language_cplus
)
6455 symbol_language
= language_ada
;
6457 completion_list_add_name (tracker
,
6459 MSYMBOL_LINKAGE_NAME (msymbol
),
6460 lookup_name
, text
, word
);
6464 /* Search upwards from currently selected frame (so that we can
6465 complete on local vars. */
6467 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
6469 if (!BLOCK_SUPERBLOCK (b
))
6470 surrounding_static_block
= b
; /* For elmin of dups */
6472 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6474 if (completion_skip_symbol (mode
, sym
))
6477 completion_list_add_name (tracker
,
6478 SYMBOL_LANGUAGE (sym
),
6479 SYMBOL_LINKAGE_NAME (sym
),
6480 lookup_name
, text
, word
);
6484 /* Go through the symtabs and check the externs and statics for
6485 symbols which match. */
6487 for (objfile
*objfile
: current_program_space
->objfiles ())
6489 for (compunit_symtab
*s
: objfile
->compunits ())
6492 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
6493 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6495 if (completion_skip_symbol (mode
, sym
))
6498 completion_list_add_name (tracker
,
6499 SYMBOL_LANGUAGE (sym
),
6500 SYMBOL_LINKAGE_NAME (sym
),
6501 lookup_name
, text
, word
);
6506 for (objfile
*objfile
: current_program_space
->objfiles ())
6508 for (compunit_symtab
*s
: objfile
->compunits ())
6511 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
6512 /* Don't do this block twice. */
6513 if (b
== surrounding_static_block
)
6515 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6517 if (completion_skip_symbol (mode
, sym
))
6520 completion_list_add_name (tracker
,
6521 SYMBOL_LANGUAGE (sym
),
6522 SYMBOL_LINKAGE_NAME (sym
),
6523 lookup_name
, text
, word
);
6531 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6532 for tagged types. */
6535 ada_is_dispatch_table_ptr_type (struct type
*type
)
6539 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
6542 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
6546 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6549 /* Return non-zero if TYPE is an interface tag. */
6552 ada_is_interface_tag (struct type
*type
)
6554 const char *name
= TYPE_NAME (type
);
6559 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6562 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6563 to be invisible to users. */
6566 ada_is_ignored_field (struct type
*type
, int field_num
)
6568 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
6571 /* Check the name of that field. */
6573 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6575 /* Anonymous field names should not be printed.
6576 brobecker/2007-02-20: I don't think this can actually happen
6577 but we don't want to print the value of annonymous fields anyway. */
6581 /* Normally, fields whose name start with an underscore ("_")
6582 are fields that have been internally generated by the compiler,
6583 and thus should not be printed. The "_parent" field is special,
6584 however: This is a field internally generated by the compiler
6585 for tagged types, and it contains the components inherited from
6586 the parent type. This field should not be printed as is, but
6587 should not be ignored either. */
6588 if (name
[0] == '_' && !startswith (name
, "_parent"))
6592 /* If this is the dispatch table of a tagged type or an interface tag,
6594 if (ada_is_tagged_type (type
, 1)
6595 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
))
6596 || ada_is_interface_tag (TYPE_FIELD_TYPE (type
, field_num
))))
6599 /* Not a special field, so it should not be ignored. */
6603 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6604 pointer or reference type whose ultimate target has a tag field. */
6607 ada_is_tagged_type (struct type
*type
, int refok
)
6609 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6612 /* True iff TYPE represents the type of X'Tag */
6615 ada_is_tag_type (struct type
*type
)
6617 type
= ada_check_typedef (type
);
6619 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
6623 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6625 return (name
!= NULL
6626 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6630 /* The type of the tag on VAL. */
6633 ada_tag_type (struct value
*val
)
6635 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6638 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6639 retired at Ada 05). */
6642 is_ada95_tag (struct value
*tag
)
6644 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6647 /* The value of the tag on VAL. */
6650 ada_value_tag (struct value
*val
)
6652 return ada_value_struct_elt (val
, "_tag", 0);
6655 /* The value of the tag on the object of type TYPE whose contents are
6656 saved at VALADDR, if it is non-null, or is at memory address
6659 static struct value
*
6660 value_tag_from_contents_and_address (struct type
*type
,
6661 const gdb_byte
*valaddr
,
6664 int tag_byte_offset
;
6665 struct type
*tag_type
;
6667 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6670 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6672 : valaddr
+ tag_byte_offset
);
6673 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6675 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6680 static struct type
*
6681 type_from_tag (struct value
*tag
)
6683 const char *type_name
= ada_tag_name (tag
);
6685 if (type_name
!= NULL
)
6686 return ada_find_any_type (ada_encode (type_name
));
6690 /* Given a value OBJ of a tagged type, return a value of this
6691 type at the base address of the object. The base address, as
6692 defined in Ada.Tags, it is the address of the primary tag of
6693 the object, and therefore where the field values of its full
6694 view can be fetched. */
6697 ada_tag_value_at_base_address (struct value
*obj
)
6700 LONGEST offset_to_top
= 0;
6701 struct type
*ptr_type
, *obj_type
;
6703 CORE_ADDR base_address
;
6705 obj_type
= value_type (obj
);
6707 /* It is the responsability of the caller to deref pointers. */
6709 if (TYPE_CODE (obj_type
) == TYPE_CODE_PTR
6710 || TYPE_CODE (obj_type
) == TYPE_CODE_REF
)
6713 tag
= ada_value_tag (obj
);
6717 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6719 if (is_ada95_tag (tag
))
6722 ptr_type
= language_lookup_primitive_type
6723 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6724 ptr_type
= lookup_pointer_type (ptr_type
);
6725 val
= value_cast (ptr_type
, tag
);
6729 /* It is perfectly possible that an exception be raised while
6730 trying to determine the base address, just like for the tag;
6731 see ada_tag_name for more details. We do not print the error
6732 message for the same reason. */
6736 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6739 catch (const gdb_exception_error
&e
)
6744 /* If offset is null, nothing to do. */
6746 if (offset_to_top
== 0)
6749 /* -1 is a special case in Ada.Tags; however, what should be done
6750 is not quite clear from the documentation. So do nothing for
6753 if (offset_to_top
== -1)
6756 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6757 from the base address. This was however incompatible with
6758 C++ dispatch table: C++ uses a *negative* value to *add*
6759 to the base address. Ada's convention has therefore been
6760 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6761 use the same convention. Here, we support both cases by
6762 checking the sign of OFFSET_TO_TOP. */
6764 if (offset_to_top
> 0)
6765 offset_to_top
= -offset_to_top
;
6767 base_address
= value_address (obj
) + offset_to_top
;
6768 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6770 /* Make sure that we have a proper tag at the new address.
6771 Otherwise, offset_to_top is bogus (which can happen when
6772 the object is not initialized yet). */
6777 obj_type
= type_from_tag (tag
);
6782 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6785 /* Return the "ada__tags__type_specific_data" type. */
6787 static struct type
*
6788 ada_get_tsd_type (struct inferior
*inf
)
6790 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6792 if (data
->tsd_type
== 0)
6793 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6794 return data
->tsd_type
;
6797 /* Return the TSD (type-specific data) associated to the given TAG.
6798 TAG is assumed to be the tag of a tagged-type entity.
6800 May return NULL if we are unable to get the TSD. */
6802 static struct value
*
6803 ada_get_tsd_from_tag (struct value
*tag
)
6808 /* First option: The TSD is simply stored as a field of our TAG.
6809 Only older versions of GNAT would use this format, but we have
6810 to test it first, because there are no visible markers for
6811 the current approach except the absence of that field. */
6813 val
= ada_value_struct_elt (tag
, "tsd", 1);
6817 /* Try the second representation for the dispatch table (in which
6818 there is no explicit 'tsd' field in the referent of the tag pointer,
6819 and instead the tsd pointer is stored just before the dispatch
6822 type
= ada_get_tsd_type (current_inferior());
6825 type
= lookup_pointer_type (lookup_pointer_type (type
));
6826 val
= value_cast (type
, tag
);
6829 return value_ind (value_ptradd (val
, -1));
6832 /* Given the TSD of a tag (type-specific data), return a string
6833 containing the name of the associated type.
6835 The returned value is good until the next call. May return NULL
6836 if we are unable to determine the tag name. */
6839 ada_tag_name_from_tsd (struct value
*tsd
)
6841 static char name
[1024];
6845 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6848 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
6849 for (p
= name
; *p
!= '\0'; p
+= 1)
6855 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6858 Return NULL if the TAG is not an Ada tag, or if we were unable to
6859 determine the name of that tag. The result is good until the next
6863 ada_tag_name (struct value
*tag
)
6867 if (!ada_is_tag_type (value_type (tag
)))
6870 /* It is perfectly possible that an exception be raised while trying
6871 to determine the TAG's name, even under normal circumstances:
6872 The associated variable may be uninitialized or corrupted, for
6873 instance. We do not let any exception propagate past this point.
6874 instead we return NULL.
6876 We also do not print the error message either (which often is very
6877 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6878 the caller print a more meaningful message if necessary. */
6881 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6884 name
= ada_tag_name_from_tsd (tsd
);
6886 catch (const gdb_exception_error
&e
)
6893 /* The parent type of TYPE, or NULL if none. */
6896 ada_parent_type (struct type
*type
)
6900 type
= ada_check_typedef (type
);
6902 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6905 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6906 if (ada_is_parent_field (type
, i
))
6908 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
6910 /* If the _parent field is a pointer, then dereference it. */
6911 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
6912 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6913 /* If there is a parallel XVS type, get the actual base type. */
6914 parent_type
= ada_get_base_type (parent_type
);
6916 return ada_check_typedef (parent_type
);
6922 /* True iff field number FIELD_NUM of structure type TYPE contains the
6923 parent-type (inherited) fields of a derived type. Assumes TYPE is
6924 a structure type with at least FIELD_NUM+1 fields. */
6927 ada_is_parent_field (struct type
*type
, int field_num
)
6929 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6931 return (name
!= NULL
6932 && (startswith (name
, "PARENT")
6933 || startswith (name
, "_parent")));
6936 /* True iff field number FIELD_NUM of structure type TYPE is a
6937 transparent wrapper field (which should be silently traversed when doing
6938 field selection and flattened when printing). Assumes TYPE is a
6939 structure type with at least FIELD_NUM+1 fields. Such fields are always
6943 ada_is_wrapper_field (struct type
*type
, int field_num
)
6945 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6947 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6949 /* This happens in functions with "out" or "in out" parameters
6950 which are passed by copy. For such functions, GNAT describes
6951 the function's return type as being a struct where the return
6952 value is in a field called RETVAL, and where the other "out"
6953 or "in out" parameters are fields of that struct. This is not
6958 return (name
!= NULL
6959 && (startswith (name
, "PARENT")
6960 || strcmp (name
, "REP") == 0
6961 || startswith (name
, "_parent")
6962 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6965 /* True iff field number FIELD_NUM of structure or union type TYPE
6966 is a variant wrapper. Assumes TYPE is a structure type with at least
6967 FIELD_NUM+1 fields. */
6970 ada_is_variant_part (struct type
*type
, int field_num
)
6972 /* Only Ada types are eligible. */
6973 if (!ADA_TYPE_P (type
))
6976 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
6978 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
6979 || (is_dynamic_field (type
, field_num
)
6980 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
6981 == TYPE_CODE_UNION
)));
6984 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6985 whose discriminants are contained in the record type OUTER_TYPE,
6986 returns the type of the controlling discriminant for the variant.
6987 May return NULL if the type could not be found. */
6990 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6992 const char *name
= ada_variant_discrim_name (var_type
);
6994 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6997 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6998 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6999 represents a 'when others' clause; otherwise 0. */
7002 ada_is_others_clause (struct type
*type
, int field_num
)
7004 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
7006 return (name
!= NULL
&& name
[0] == 'O');
7009 /* Assuming that TYPE0 is the type of the variant part of a record,
7010 returns the name of the discriminant controlling the variant.
7011 The value is valid until the next call to ada_variant_discrim_name. */
7014 ada_variant_discrim_name (struct type
*type0
)
7016 static char *result
= NULL
;
7017 static size_t result_len
= 0;
7020 const char *discrim_end
;
7021 const char *discrim_start
;
7023 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
7024 type
= TYPE_TARGET_TYPE (type0
);
7028 name
= ada_type_name (type
);
7030 if (name
== NULL
|| name
[0] == '\000')
7033 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
7036 if (startswith (discrim_end
, "___XVN"))
7039 if (discrim_end
== name
)
7042 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
7045 if (discrim_start
== name
+ 1)
7047 if ((discrim_start
> name
+ 3
7048 && startswith (discrim_start
- 3, "___"))
7049 || discrim_start
[-1] == '.')
7053 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
7054 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
7055 result
[discrim_end
- discrim_start
] = '\0';
7059 /* Scan STR for a subtype-encoded number, beginning at position K.
7060 Put the position of the character just past the number scanned in
7061 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7062 Return 1 if there was a valid number at the given position, and 0
7063 otherwise. A "subtype-encoded" number consists of the absolute value
7064 in decimal, followed by the letter 'm' to indicate a negative number.
7065 Assumes 0m does not occur. */
7068 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
7072 if (!isdigit (str
[k
]))
7075 /* Do it the hard way so as not to make any assumption about
7076 the relationship of unsigned long (%lu scan format code) and
7079 while (isdigit (str
[k
]))
7081 RU
= RU
* 10 + (str
[k
] - '0');
7088 *R
= (-(LONGEST
) (RU
- 1)) - 1;
7094 /* NOTE on the above: Technically, C does not say what the results of
7095 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7096 number representable as a LONGEST (although either would probably work
7097 in most implementations). When RU>0, the locution in the then branch
7098 above is always equivalent to the negative of RU. */
7105 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7106 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7107 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
7110 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
7112 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
7126 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
7136 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
7137 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
7139 if (val
>= L
&& val
<= U
)
7151 /* FIXME: Lots of redundancy below. Try to consolidate. */
7153 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7154 ARG_TYPE, extract and return the value of one of its (non-static)
7155 fields. FIELDNO says which field. Differs from value_primitive_field
7156 only in that it can handle packed values of arbitrary type. */
7158 static struct value
*
7159 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
7160 struct type
*arg_type
)
7164 arg_type
= ada_check_typedef (arg_type
);
7165 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
7167 /* Handle packed fields. It might be that the field is not packed
7168 relative to its containing structure, but the structure itself is
7169 packed; in this case we must take the bit-field path. */
7170 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
7172 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
7173 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
7175 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
7176 offset
+ bit_pos
/ 8,
7177 bit_pos
% 8, bit_size
, type
);
7180 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
7183 /* Find field with name NAME in object of type TYPE. If found,
7184 set the following for each argument that is non-null:
7185 - *FIELD_TYPE_P to the field's type;
7186 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7187 an object of that type;
7188 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7189 - *BIT_SIZE_P to its size in bits if the field is packed, and
7191 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7192 fields up to but not including the desired field, or by the total
7193 number of fields if not found. A NULL value of NAME never
7194 matches; the function just counts visible fields in this case.
7196 Notice that we need to handle when a tagged record hierarchy
7197 has some components with the same name, like in this scenario:
7199 type Top_T is tagged record
7205 type Middle_T is new Top.Top_T with record
7206 N : Character := 'a';
7210 type Bottom_T is new Middle.Middle_T with record
7212 C : Character := '5';
7214 A : Character := 'J';
7217 Let's say we now have a variable declared and initialized as follow:
7219 TC : Top_A := new Bottom_T;
7221 And then we use this variable to call this function
7223 procedure Assign (Obj: in out Top_T; TV : Integer);
7227 Assign (Top_T (B), 12);
7229 Now, we're in the debugger, and we're inside that procedure
7230 then and we want to print the value of obj.c:
7232 Usually, the tagged record or one of the parent type owns the
7233 component to print and there's no issue but in this particular
7234 case, what does it mean to ask for Obj.C? Since the actual
7235 type for object is type Bottom_T, it could mean two things: type
7236 component C from the Middle_T view, but also component C from
7237 Bottom_T. So in that "undefined" case, when the component is
7238 not found in the non-resolved type (which includes all the
7239 components of the parent type), then resolve it and see if we
7240 get better luck once expanded.
7242 In the case of homonyms in the derived tagged type, we don't
7243 guaranty anything, and pick the one that's easiest for us
7246 Returns 1 if found, 0 otherwise. */
7249 find_struct_field (const char *name
, struct type
*type
, int offset
,
7250 struct type
**field_type_p
,
7251 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
7255 int parent_offset
= -1;
7257 type
= ada_check_typedef (type
);
7259 if (field_type_p
!= NULL
)
7260 *field_type_p
= NULL
;
7261 if (byte_offset_p
!= NULL
)
7263 if (bit_offset_p
!= NULL
)
7265 if (bit_size_p
!= NULL
)
7268 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7270 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
7271 int fld_offset
= offset
+ bit_pos
/ 8;
7272 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7274 if (t_field_name
== NULL
)
7277 else if (ada_is_parent_field (type
, i
))
7279 /* This is a field pointing us to the parent type of a tagged
7280 type. As hinted in this function's documentation, we give
7281 preference to fields in the current record first, so what
7282 we do here is just record the index of this field before
7283 we skip it. If it turns out we couldn't find our field
7284 in the current record, then we'll get back to it and search
7285 inside it whether the field might exist in the parent. */
7291 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7293 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7295 if (field_type_p
!= NULL
)
7296 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
7297 if (byte_offset_p
!= NULL
)
7298 *byte_offset_p
= fld_offset
;
7299 if (bit_offset_p
!= NULL
)
7300 *bit_offset_p
= bit_pos
% 8;
7301 if (bit_size_p
!= NULL
)
7302 *bit_size_p
= bit_size
;
7305 else if (ada_is_wrapper_field (type
, i
))
7307 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
7308 field_type_p
, byte_offset_p
, bit_offset_p
,
7309 bit_size_p
, index_p
))
7312 else if (ada_is_variant_part (type
, i
))
7314 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7317 struct type
*field_type
7318 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
7320 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
7322 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
7324 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7325 field_type_p
, byte_offset_p
,
7326 bit_offset_p
, bit_size_p
, index_p
))
7330 else if (index_p
!= NULL
)
7334 /* Field not found so far. If this is a tagged type which
7335 has a parent, try finding that field in the parent now. */
7337 if (parent_offset
!= -1)
7339 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
7340 int fld_offset
= offset
+ bit_pos
/ 8;
7342 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, parent_offset
),
7343 fld_offset
, field_type_p
, byte_offset_p
,
7344 bit_offset_p
, bit_size_p
, index_p
))
7351 /* Number of user-visible fields in record type TYPE. */
7354 num_visible_fields (struct type
*type
)
7359 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7363 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7364 and search in it assuming it has (class) type TYPE.
7365 If found, return value, else return NULL.
7367 Searches recursively through wrapper fields (e.g., '_parent').
7369 In the case of homonyms in the tagged types, please refer to the
7370 long explanation in find_struct_field's function documentation. */
7372 static struct value
*
7373 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7377 int parent_offset
= -1;
7379 type
= ada_check_typedef (type
);
7380 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7382 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7384 if (t_field_name
== NULL
)
7387 else if (ada_is_parent_field (type
, i
))
7389 /* This is a field pointing us to the parent type of a tagged
7390 type. As hinted in this function's documentation, we give
7391 preference to fields in the current record first, so what
7392 we do here is just record the index of this field before
7393 we skip it. If it turns out we couldn't find our field
7394 in the current record, then we'll get back to it and search
7395 inside it whether the field might exist in the parent. */
7401 else if (field_name_match (t_field_name
, name
))
7402 return ada_value_primitive_field (arg
, offset
, i
, type
);
7404 else if (ada_is_wrapper_field (type
, i
))
7406 struct value
*v
= /* Do not let indent join lines here. */
7407 ada_search_struct_field (name
, arg
,
7408 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7409 TYPE_FIELD_TYPE (type
, i
));
7415 else if (ada_is_variant_part (type
, i
))
7417 /* PNH: Do we ever get here? See find_struct_field. */
7419 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7421 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7423 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
7425 struct value
*v
= ada_search_struct_field
/* Force line
7428 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7429 TYPE_FIELD_TYPE (field_type
, j
));
7437 /* Field not found so far. If this is a tagged type which
7438 has a parent, try finding that field in the parent now. */
7440 if (parent_offset
!= -1)
7442 struct value
*v
= ada_search_struct_field (
7443 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7444 TYPE_FIELD_TYPE (type
, parent_offset
));
7453 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7454 int, struct type
*);
7457 /* Return field #INDEX in ARG, where the index is that returned by
7458 * find_struct_field through its INDEX_P argument. Adjust the address
7459 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7460 * If found, return value, else return NULL. */
7462 static struct value
*
7463 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7466 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7470 /* Auxiliary function for ada_index_struct_field. Like
7471 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7474 static struct value
*
7475 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7479 type
= ada_check_typedef (type
);
7481 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7483 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7485 else if (ada_is_wrapper_field (type
, i
))
7487 struct value
*v
= /* Do not let indent join lines here. */
7488 ada_index_struct_field_1 (index_p
, arg
,
7489 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7490 TYPE_FIELD_TYPE (type
, i
));
7496 else if (ada_is_variant_part (type
, i
))
7498 /* PNH: Do we ever get here? See ada_search_struct_field,
7499 find_struct_field. */
7500 error (_("Cannot assign this kind of variant record"));
7502 else if (*index_p
== 0)
7503 return ada_value_primitive_field (arg
, offset
, i
, type
);
7510 /* Given ARG, a value of type (pointer or reference to a)*
7511 structure/union, extract the component named NAME from the ultimate
7512 target structure/union and return it as a value with its
7515 The routine searches for NAME among all members of the structure itself
7516 and (recursively) among all members of any wrapper members
7519 If NO_ERR, then simply return NULL in case of error, rather than
7523 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
7525 struct type
*t
, *t1
;
7530 t1
= t
= ada_check_typedef (value_type (arg
));
7531 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7533 t1
= TYPE_TARGET_TYPE (t
);
7536 t1
= ada_check_typedef (t1
);
7537 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7539 arg
= coerce_ref (arg
);
7544 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7546 t1
= TYPE_TARGET_TYPE (t
);
7549 t1
= ada_check_typedef (t1
);
7550 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7552 arg
= value_ind (arg
);
7559 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
7563 v
= ada_search_struct_field (name
, arg
, 0, t
);
7566 int bit_offset
, bit_size
, byte_offset
;
7567 struct type
*field_type
;
7570 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7571 address
= value_address (ada_value_ind (arg
));
7573 address
= value_address (ada_coerce_ref (arg
));
7575 /* Check to see if this is a tagged type. We also need to handle
7576 the case where the type is a reference to a tagged type, but
7577 we have to be careful to exclude pointers to tagged types.
7578 The latter should be shown as usual (as a pointer), whereas
7579 a reference should mostly be transparent to the user. */
7581 if (ada_is_tagged_type (t1
, 0)
7582 || (TYPE_CODE (t1
) == TYPE_CODE_REF
7583 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1
), 0)))
7585 /* We first try to find the searched field in the current type.
7586 If not found then let's look in the fixed type. */
7588 if (!find_struct_field (name
, t1
, 0,
7589 &field_type
, &byte_offset
, &bit_offset
,
7598 /* Convert to fixed type in all cases, so that we have proper
7599 offsets to each field in unconstrained record types. */
7600 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
7601 address
, NULL
, check_tag
);
7603 if (find_struct_field (name
, t1
, 0,
7604 &field_type
, &byte_offset
, &bit_offset
,
7609 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7610 arg
= ada_coerce_ref (arg
);
7612 arg
= ada_value_ind (arg
);
7613 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
7614 bit_offset
, bit_size
,
7618 v
= value_at_lazy (field_type
, address
+ byte_offset
);
7622 if (v
!= NULL
|| no_err
)
7625 error (_("There is no member named %s."), name
);
7631 error (_("Attempt to extract a component of "
7632 "a value that is not a record."));
7635 /* Return a string representation of type TYPE. */
7638 type_as_string (struct type
*type
)
7640 string_file tmp_stream
;
7642 type_print (type
, "", &tmp_stream
, -1);
7644 return std::move (tmp_stream
.string ());
7647 /* Given a type TYPE, look up the type of the component of type named NAME.
7648 If DISPP is non-null, add its byte displacement from the beginning of a
7649 structure (pointed to by a value) of type TYPE to *DISPP (does not
7650 work for packed fields).
7652 Matches any field whose name has NAME as a prefix, possibly
7655 TYPE can be either a struct or union. If REFOK, TYPE may also
7656 be a (pointer or reference)+ to a struct or union, and the
7657 ultimate target type will be searched.
7659 Looks recursively into variant clauses and parent types.
7661 In the case of homonyms in the tagged types, please refer to the
7662 long explanation in find_struct_field's function documentation.
7664 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7665 TYPE is not a type of the right kind. */
7667 static struct type
*
7668 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7672 int parent_offset
= -1;
7677 if (refok
&& type
!= NULL
)
7680 type
= ada_check_typedef (type
);
7681 if (TYPE_CODE (type
) != TYPE_CODE_PTR
7682 && TYPE_CODE (type
) != TYPE_CODE_REF
)
7684 type
= TYPE_TARGET_TYPE (type
);
7688 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
7689 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
7694 error (_("Type %s is not a structure or union type"),
7695 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7698 type
= to_static_fixed_type (type
);
7700 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7702 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7705 if (t_field_name
== NULL
)
7708 else if (ada_is_parent_field (type
, i
))
7710 /* This is a field pointing us to the parent type of a tagged
7711 type. As hinted in this function's documentation, we give
7712 preference to fields in the current record first, so what
7713 we do here is just record the index of this field before
7714 we skip it. If it turns out we couldn't find our field
7715 in the current record, then we'll get back to it and search
7716 inside it whether the field might exist in the parent. */
7722 else if (field_name_match (t_field_name
, name
))
7723 return TYPE_FIELD_TYPE (type
, i
);
7725 else if (ada_is_wrapper_field (type
, i
))
7727 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
7733 else if (ada_is_variant_part (type
, i
))
7736 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7739 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7741 /* FIXME pnh 2008/01/26: We check for a field that is
7742 NOT wrapped in a struct, since the compiler sometimes
7743 generates these for unchecked variant types. Revisit
7744 if the compiler changes this practice. */
7745 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7747 if (v_field_name
!= NULL
7748 && field_name_match (v_field_name
, name
))
7749 t
= TYPE_FIELD_TYPE (field_type
, j
);
7751 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
,
7762 /* Field not found so far. If this is a tagged type which
7763 has a parent, try finding that field in the parent now. */
7765 if (parent_offset
!= -1)
7769 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, parent_offset
),
7778 const char *name_str
= name
!= NULL
? name
: _("<null>");
7780 error (_("Type %s has no component named %s"),
7781 type_as_string (type
).c_str (), name_str
);
7787 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7788 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7789 represents an unchecked union (that is, the variant part of a
7790 record that is named in an Unchecked_Union pragma). */
7793 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7795 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7797 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7801 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7802 within a value of type OUTER_TYPE that is stored in GDB at
7803 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7804 numbering from 0) is applicable. Returns -1 if none are. */
7807 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
7808 const gdb_byte
*outer_valaddr
)
7812 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7813 struct value
*outer
;
7814 struct value
*discrim
;
7815 LONGEST discrim_val
;
7817 /* Using plain value_from_contents_and_address here causes problems
7818 because we will end up trying to resolve a type that is currently
7819 being constructed. */
7820 outer
= value_from_contents_and_address_unresolved (outer_type
,
7822 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7823 if (discrim
== NULL
)
7825 discrim_val
= value_as_long (discrim
);
7828 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
7830 if (ada_is_others_clause (var_type
, i
))
7832 else if (ada_in_variant (discrim_val
, var_type
, i
))
7836 return others_clause
;
7841 /* Dynamic-Sized Records */
7843 /* Strategy: The type ostensibly attached to a value with dynamic size
7844 (i.e., a size that is not statically recorded in the debugging
7845 data) does not accurately reflect the size or layout of the value.
7846 Our strategy is to convert these values to values with accurate,
7847 conventional types that are constructed on the fly. */
7849 /* There is a subtle and tricky problem here. In general, we cannot
7850 determine the size of dynamic records without its data. However,
7851 the 'struct value' data structure, which GDB uses to represent
7852 quantities in the inferior process (the target), requires the size
7853 of the type at the time of its allocation in order to reserve space
7854 for GDB's internal copy of the data. That's why the
7855 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7856 rather than struct value*s.
7858 However, GDB's internal history variables ($1, $2, etc.) are
7859 struct value*s containing internal copies of the data that are not, in
7860 general, the same as the data at their corresponding addresses in
7861 the target. Fortunately, the types we give to these values are all
7862 conventional, fixed-size types (as per the strategy described
7863 above), so that we don't usually have to perform the
7864 'to_fixed_xxx_type' conversions to look at their values.
7865 Unfortunately, there is one exception: if one of the internal
7866 history variables is an array whose elements are unconstrained
7867 records, then we will need to create distinct fixed types for each
7868 element selected. */
7870 /* The upshot of all of this is that many routines take a (type, host
7871 address, target address) triple as arguments to represent a value.
7872 The host address, if non-null, is supposed to contain an internal
7873 copy of the relevant data; otherwise, the program is to consult the
7874 target at the target address. */
7876 /* Assuming that VAL0 represents a pointer value, the result of
7877 dereferencing it. Differs from value_ind in its treatment of
7878 dynamic-sized types. */
7881 ada_value_ind (struct value
*val0
)
7883 struct value
*val
= value_ind (val0
);
7885 if (ada_is_tagged_type (value_type (val
), 0))
7886 val
= ada_tag_value_at_base_address (val
);
7888 return ada_to_fixed_value (val
);
7891 /* The value resulting from dereferencing any "reference to"
7892 qualifiers on VAL0. */
7894 static struct value
*
7895 ada_coerce_ref (struct value
*val0
)
7897 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
7899 struct value
*val
= val0
;
7901 val
= coerce_ref (val
);
7903 if (ada_is_tagged_type (value_type (val
), 0))
7904 val
= ada_tag_value_at_base_address (val
);
7906 return ada_to_fixed_value (val
);
7912 /* Return OFF rounded upward if necessary to a multiple of
7913 ALIGNMENT (a power of 2). */
7916 align_value (unsigned int off
, unsigned int alignment
)
7918 return (off
+ alignment
- 1) & ~(alignment
- 1);
7921 /* Return the bit alignment required for field #F of template type TYPE. */
7924 field_alignment (struct type
*type
, int f
)
7926 const char *name
= TYPE_FIELD_NAME (type
, f
);
7930 /* The field name should never be null, unless the debugging information
7931 is somehow malformed. In this case, we assume the field does not
7932 require any alignment. */
7936 len
= strlen (name
);
7938 if (!isdigit (name
[len
- 1]))
7941 if (isdigit (name
[len
- 2]))
7942 align_offset
= len
- 2;
7944 align_offset
= len
- 1;
7946 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7947 return TARGET_CHAR_BIT
;
7949 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7952 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7954 static struct symbol
*
7955 ada_find_any_type_symbol (const char *name
)
7959 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7960 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7963 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7967 /* Find a type named NAME. Ignores ambiguity. This routine will look
7968 solely for types defined by debug info, it will not search the GDB
7971 static struct type
*
7972 ada_find_any_type (const char *name
)
7974 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7977 return SYMBOL_TYPE (sym
);
7982 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7983 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7984 symbol, in which case it is returned. Otherwise, this looks for
7985 symbols whose name is that of NAME_SYM suffixed with "___XR".
7986 Return symbol if found, and NULL otherwise. */
7989 ada_find_renaming_symbol (struct symbol
*name_sym
, const struct block
*block
)
7991 const char *name
= SYMBOL_LINKAGE_NAME (name_sym
);
7994 if (strstr (name
, "___XR") != NULL
)
7997 sym
= find_old_style_renaming_symbol (name
, block
);
8002 /* Not right yet. FIXME pnh 7/20/2007. */
8003 sym
= ada_find_any_type_symbol (name
);
8004 if (sym
!= NULL
&& strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR") != NULL
)
8010 static struct symbol
*
8011 find_old_style_renaming_symbol (const char *name
, const struct block
*block
)
8013 const struct symbol
*function_sym
= block_linkage_function (block
);
8016 if (function_sym
!= NULL
)
8018 /* If the symbol is defined inside a function, NAME is not fully
8019 qualified. This means we need to prepend the function name
8020 as well as adding the ``___XR'' suffix to build the name of
8021 the associated renaming symbol. */
8022 const char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
8023 /* Function names sometimes contain suffixes used
8024 for instance to qualify nested subprograms. When building
8025 the XR type name, we need to make sure that this suffix is
8026 not included. So do not include any suffix in the function
8027 name length below. */
8028 int function_name_len
= ada_name_prefix_len (function_name
);
8029 const int rename_len
= function_name_len
+ 2 /* "__" */
8030 + strlen (name
) + 6 /* "___XR\0" */ ;
8032 /* Strip the suffix if necessary. */
8033 ada_remove_trailing_digits (function_name
, &function_name_len
);
8034 ada_remove_po_subprogram_suffix (function_name
, &function_name_len
);
8035 ada_remove_Xbn_suffix (function_name
, &function_name_len
);
8037 /* Library-level functions are a special case, as GNAT adds
8038 a ``_ada_'' prefix to the function name to avoid namespace
8039 pollution. However, the renaming symbols themselves do not
8040 have this prefix, so we need to skip this prefix if present. */
8041 if (function_name_len
> 5 /* "_ada_" */
8042 && strstr (function_name
, "_ada_") == function_name
)
8045 function_name_len
-= 5;
8048 rename
= (char *) alloca (rename_len
* sizeof (char));
8049 strncpy (rename
, function_name
, function_name_len
);
8050 xsnprintf (rename
+ function_name_len
, rename_len
- function_name_len
,
8055 const int rename_len
= strlen (name
) + 6;
8057 rename
= (char *) alloca (rename_len
* sizeof (char));
8058 xsnprintf (rename
, rename_len
* sizeof (char), "%s___XR", name
);
8061 return ada_find_any_type_symbol (rename
);
8064 /* Because of GNAT encoding conventions, several GDB symbols may match a
8065 given type name. If the type denoted by TYPE0 is to be preferred to
8066 that of TYPE1 for purposes of type printing, return non-zero;
8067 otherwise return 0. */
8070 ada_prefer_type (struct type
*type0
, struct type
*type1
)
8074 else if (type0
== NULL
)
8076 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
8078 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
8080 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
8082 else if (ada_is_constrained_packed_array_type (type0
))
8084 else if (ada_is_array_descriptor_type (type0
)
8085 && !ada_is_array_descriptor_type (type1
))
8089 const char *type0_name
= TYPE_NAME (type0
);
8090 const char *type1_name
= TYPE_NAME (type1
);
8092 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
8093 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
8099 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
8103 ada_type_name (struct type
*type
)
8107 return TYPE_NAME (type
);
8110 /* Search the list of "descriptive" types associated to TYPE for a type
8111 whose name is NAME. */
8113 static struct type
*
8114 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
8116 struct type
*result
, *tmp
;
8118 if (ada_ignore_descriptive_types_p
)
8121 /* If there no descriptive-type info, then there is no parallel type
8123 if (!HAVE_GNAT_AUX_INFO (type
))
8126 result
= TYPE_DESCRIPTIVE_TYPE (type
);
8127 while (result
!= NULL
)
8129 const char *result_name
= ada_type_name (result
);
8131 if (result_name
== NULL
)
8133 warning (_("unexpected null name on descriptive type"));
8137 /* If the names match, stop. */
8138 if (strcmp (result_name
, name
) == 0)
8141 /* Otherwise, look at the next item on the list, if any. */
8142 if (HAVE_GNAT_AUX_INFO (result
))
8143 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
8147 /* If not found either, try after having resolved the typedef. */
8152 result
= check_typedef (result
);
8153 if (HAVE_GNAT_AUX_INFO (result
))
8154 result
= TYPE_DESCRIPTIVE_TYPE (result
);
8160 /* If we didn't find a match, see whether this is a packed array. With
8161 older compilers, the descriptive type information is either absent or
8162 irrelevant when it comes to packed arrays so the above lookup fails.
8163 Fall back to using a parallel lookup by name in this case. */
8164 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
8165 return ada_find_any_type (name
);
8170 /* Find a parallel type to TYPE with the specified NAME, using the
8171 descriptive type taken from the debugging information, if available,
8172 and otherwise using the (slower) name-based method. */
8174 static struct type
*
8175 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
8177 struct type
*result
= NULL
;
8179 if (HAVE_GNAT_AUX_INFO (type
))
8180 result
= find_parallel_type_by_descriptive_type (type
, name
);
8182 result
= ada_find_any_type (name
);
8187 /* Same as above, but specify the name of the parallel type by appending
8188 SUFFIX to the name of TYPE. */
8191 ada_find_parallel_type (struct type
*type
, const char *suffix
)
8194 const char *type_name
= ada_type_name (type
);
8197 if (type_name
== NULL
)
8200 len
= strlen (type_name
);
8202 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
8204 strcpy (name
, type_name
);
8205 strcpy (name
+ len
, suffix
);
8207 return ada_find_parallel_type_with_name (type
, name
);
8210 /* If TYPE is a variable-size record type, return the corresponding template
8211 type describing its fields. Otherwise, return NULL. */
8213 static struct type
*
8214 dynamic_template_type (struct type
*type
)
8216 type
= ada_check_typedef (type
);
8218 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
8219 || ada_type_name (type
) == NULL
)
8223 int len
= strlen (ada_type_name (type
));
8225 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
8228 return ada_find_parallel_type (type
, "___XVE");
8232 /* Assuming that TEMPL_TYPE is a union or struct type, returns
8233 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
8236 is_dynamic_field (struct type
*templ_type
, int field_num
)
8238 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
8241 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
8242 && strstr (name
, "___XVL") != NULL
;
8245 /* The index of the variant field of TYPE, or -1 if TYPE does not
8246 represent a variant record type. */
8249 variant_field_index (struct type
*type
)
8253 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
8256 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
8258 if (ada_is_variant_part (type
, f
))
8264 /* A record type with no fields. */
8266 static struct type
*
8267 empty_record (struct type
*templ
)
8269 struct type
*type
= alloc_type_copy (templ
);
8271 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
8272 TYPE_NFIELDS (type
) = 0;
8273 TYPE_FIELDS (type
) = NULL
;
8274 INIT_NONE_SPECIFIC (type
);
8275 TYPE_NAME (type
) = "<empty>";
8276 TYPE_LENGTH (type
) = 0;
8280 /* An ordinary record type (with fixed-length fields) that describes
8281 the value of type TYPE at VALADDR or ADDRESS (see comments at
8282 the beginning of this section) VAL according to GNAT conventions.
8283 DVAL0 should describe the (portion of a) record that contains any
8284 necessary discriminants. It should be NULL if value_type (VAL) is
8285 an outer-level type (i.e., as opposed to a branch of a variant.) A
8286 variant field (unless unchecked) is replaced by a particular branch
8289 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8290 length are not statically known are discarded. As a consequence,
8291 VALADDR, ADDRESS and DVAL0 are ignored.
8293 NOTE: Limitations: For now, we assume that dynamic fields and
8294 variants occupy whole numbers of bytes. However, they need not be
8298 ada_template_to_fixed_record_type_1 (struct type
*type
,
8299 const gdb_byte
*valaddr
,
8300 CORE_ADDR address
, struct value
*dval0
,
8301 int keep_dynamic_fields
)
8303 struct value
*mark
= value_mark ();
8306 int nfields
, bit_len
;
8312 /* Compute the number of fields in this record type that are going
8313 to be processed: unless keep_dynamic_fields, this includes only
8314 fields whose position and length are static will be processed. */
8315 if (keep_dynamic_fields
)
8316 nfields
= TYPE_NFIELDS (type
);
8320 while (nfields
< TYPE_NFIELDS (type
)
8321 && !ada_is_variant_part (type
, nfields
)
8322 && !is_dynamic_field (type
, nfields
))
8326 rtype
= alloc_type_copy (type
);
8327 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
8328 INIT_NONE_SPECIFIC (rtype
);
8329 TYPE_NFIELDS (rtype
) = nfields
;
8330 TYPE_FIELDS (rtype
) = (struct field
*)
8331 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8332 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
8333 TYPE_NAME (rtype
) = ada_type_name (type
);
8334 TYPE_FIXED_INSTANCE (rtype
) = 1;
8340 for (f
= 0; f
< nfields
; f
+= 1)
8342 off
= align_value (off
, field_alignment (type
, f
))
8343 + TYPE_FIELD_BITPOS (type
, f
);
8344 SET_FIELD_BITPOS (TYPE_FIELD (rtype
, f
), off
);
8345 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
8347 if (ada_is_variant_part (type
, f
))
8352 else if (is_dynamic_field (type
, f
))
8354 const gdb_byte
*field_valaddr
= valaddr
;
8355 CORE_ADDR field_address
= address
;
8356 struct type
*field_type
=
8357 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
));
8361 /* rtype's length is computed based on the run-time
8362 value of discriminants. If the discriminants are not
8363 initialized, the type size may be completely bogus and
8364 GDB may fail to allocate a value for it. So check the
8365 size first before creating the value. */
8366 ada_ensure_varsize_limit (rtype
);
8367 /* Using plain value_from_contents_and_address here
8368 causes problems because we will end up trying to
8369 resolve a type that is currently being
8371 dval
= value_from_contents_and_address_unresolved (rtype
,
8374 rtype
= value_type (dval
);
8379 /* If the type referenced by this field is an aligner type, we need
8380 to unwrap that aligner type, because its size might not be set.
8381 Keeping the aligner type would cause us to compute the wrong
8382 size for this field, impacting the offset of the all the fields
8383 that follow this one. */
8384 if (ada_is_aligner_type (field_type
))
8386 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
8388 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
8389 field_address
= cond_offset_target (field_address
, field_offset
);
8390 field_type
= ada_aligned_type (field_type
);
8393 field_valaddr
= cond_offset_host (field_valaddr
,
8394 off
/ TARGET_CHAR_BIT
);
8395 field_address
= cond_offset_target (field_address
,
8396 off
/ TARGET_CHAR_BIT
);
8398 /* Get the fixed type of the field. Note that, in this case,
8399 we do not want to get the real type out of the tag: if
8400 the current field is the parent part of a tagged record,
8401 we will get the tag of the object. Clearly wrong: the real
8402 type of the parent is not the real type of the child. We
8403 would end up in an infinite loop. */
8404 field_type
= ada_get_base_type (field_type
);
8405 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
8406 field_address
, dval
, 0);
8407 /* If the field size is already larger than the maximum
8408 object size, then the record itself will necessarily
8409 be larger than the maximum object size. We need to make
8410 this check now, because the size might be so ridiculously
8411 large (due to an uninitialized variable in the inferior)
8412 that it would cause an overflow when adding it to the
8414 ada_ensure_varsize_limit (field_type
);
8416 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
8417 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8418 /* The multiplication can potentially overflow. But because
8419 the field length has been size-checked just above, and
8420 assuming that the maximum size is a reasonable value,
8421 an overflow should not happen in practice. So rather than
8422 adding overflow recovery code to this already complex code,
8423 we just assume that it's not going to happen. */
8425 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
8429 /* Note: If this field's type is a typedef, it is important
8430 to preserve the typedef layer.
8432 Otherwise, we might be transforming a typedef to a fat
8433 pointer (encoding a pointer to an unconstrained array),
8434 into a basic fat pointer (encoding an unconstrained
8435 array). As both types are implemented using the same
8436 structure, the typedef is the only clue which allows us
8437 to distinguish between the two options. Stripping it
8438 would prevent us from printing this field appropriately. */
8439 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
8440 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8441 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
8443 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
8446 struct type
*field_type
= TYPE_FIELD_TYPE (type
, f
);
8448 /* We need to be careful of typedefs when computing
8449 the length of our field. If this is a typedef,
8450 get the length of the target type, not the length
8452 if (TYPE_CODE (field_type
) == TYPE_CODE_TYPEDEF
)
8453 field_type
= ada_typedef_target_type (field_type
);
8456 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
8459 if (off
+ fld_bit_len
> bit_len
)
8460 bit_len
= off
+ fld_bit_len
;
8462 TYPE_LENGTH (rtype
) =
8463 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8466 /* We handle the variant part, if any, at the end because of certain
8467 odd cases in which it is re-ordered so as NOT to be the last field of
8468 the record. This can happen in the presence of representation
8470 if (variant_field
>= 0)
8472 struct type
*branch_type
;
8474 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8478 /* Using plain value_from_contents_and_address here causes
8479 problems because we will end up trying to resolve a type
8480 that is currently being constructed. */
8481 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8483 rtype
= value_type (dval
);
8489 to_fixed_variant_branch_type
8490 (TYPE_FIELD_TYPE (type
, variant_field
),
8491 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8492 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8493 if (branch_type
== NULL
)
8495 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
8496 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
8497 TYPE_NFIELDS (rtype
) -= 1;
8501 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8502 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8504 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
8506 if (off
+ fld_bit_len
> bit_len
)
8507 bit_len
= off
+ fld_bit_len
;
8508 TYPE_LENGTH (rtype
) =
8509 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8513 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8514 should contain the alignment of that record, which should be a strictly
8515 positive value. If null or negative, then something is wrong, most
8516 probably in the debug info. In that case, we don't round up the size
8517 of the resulting type. If this record is not part of another structure,
8518 the current RTYPE length might be good enough for our purposes. */
8519 if (TYPE_LENGTH (type
) <= 0)
8521 if (TYPE_NAME (rtype
))
8522 warning (_("Invalid type size for `%s' detected: %s."),
8523 TYPE_NAME (rtype
), pulongest (TYPE_LENGTH (type
)));
8525 warning (_("Invalid type size for <unnamed> detected: %s."),
8526 pulongest (TYPE_LENGTH (type
)));
8530 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
8531 TYPE_LENGTH (type
));
8534 value_free_to_mark (mark
);
8535 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8536 error (_("record type with dynamic size is larger than varsize-limit"));
8540 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8543 static struct type
*
8544 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8545 CORE_ADDR address
, struct value
*dval0
)
8547 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8551 /* An ordinary record type in which ___XVL-convention fields and
8552 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8553 static approximations, containing all possible fields. Uses
8554 no runtime values. Useless for use in values, but that's OK,
8555 since the results are used only for type determinations. Works on both
8556 structs and unions. Representation note: to save space, we memorize
8557 the result of this function in the TYPE_TARGET_TYPE of the
8560 static struct type
*
8561 template_to_static_fixed_type (struct type
*type0
)
8567 /* No need no do anything if the input type is already fixed. */
8568 if (TYPE_FIXED_INSTANCE (type0
))
8571 /* Likewise if we already have computed the static approximation. */
8572 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8573 return TYPE_TARGET_TYPE (type0
);
8575 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8577 nfields
= TYPE_NFIELDS (type0
);
8579 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8580 recompute all over next time. */
8581 TYPE_TARGET_TYPE (type0
) = type
;
8583 for (f
= 0; f
< nfields
; f
+= 1)
8585 struct type
*field_type
= TYPE_FIELD_TYPE (type0
, f
);
8586 struct type
*new_type
;
8588 if (is_dynamic_field (type0
, f
))
8590 field_type
= ada_check_typedef (field_type
);
8591 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8594 new_type
= static_unwrap_type (field_type
);
8596 if (new_type
!= field_type
)
8598 /* Clone TYPE0 only the first time we get a new field type. */
8601 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8602 TYPE_CODE (type
) = TYPE_CODE (type0
);
8603 INIT_NONE_SPECIFIC (type
);
8604 TYPE_NFIELDS (type
) = nfields
;
8605 TYPE_FIELDS (type
) = (struct field
*)
8606 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
8607 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
8608 sizeof (struct field
) * nfields
);
8609 TYPE_NAME (type
) = ada_type_name (type0
);
8610 TYPE_FIXED_INSTANCE (type
) = 1;
8611 TYPE_LENGTH (type
) = 0;
8613 TYPE_FIELD_TYPE (type
, f
) = new_type
;
8614 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8621 /* Given an object of type TYPE whose contents are at VALADDR and
8622 whose address in memory is ADDRESS, returns a revision of TYPE,
8623 which should be a non-dynamic-sized record, in which the variant
8624 part, if any, is replaced with the appropriate branch. Looks
8625 for discriminant values in DVAL0, which can be NULL if the record
8626 contains the necessary discriminant values. */
8628 static struct type
*
8629 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8630 CORE_ADDR address
, struct value
*dval0
)
8632 struct value
*mark
= value_mark ();
8635 struct type
*branch_type
;
8636 int nfields
= TYPE_NFIELDS (type
);
8637 int variant_field
= variant_field_index (type
);
8639 if (variant_field
== -1)
8644 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8645 type
= value_type (dval
);
8650 rtype
= alloc_type_copy (type
);
8651 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
8652 INIT_NONE_SPECIFIC (rtype
);
8653 TYPE_NFIELDS (rtype
) = nfields
;
8654 TYPE_FIELDS (rtype
) =
8655 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8656 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
8657 sizeof (struct field
) * nfields
);
8658 TYPE_NAME (rtype
) = ada_type_name (type
);
8659 TYPE_FIXED_INSTANCE (rtype
) = 1;
8660 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8662 branch_type
= to_fixed_variant_branch_type
8663 (TYPE_FIELD_TYPE (type
, variant_field
),
8664 cond_offset_host (valaddr
,
8665 TYPE_FIELD_BITPOS (type
, variant_field
)
8667 cond_offset_target (address
,
8668 TYPE_FIELD_BITPOS (type
, variant_field
)
8669 / TARGET_CHAR_BIT
), dval
);
8670 if (branch_type
== NULL
)
8674 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8675 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
8676 TYPE_NFIELDS (rtype
) -= 1;
8680 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8681 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8682 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8683 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8685 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
8687 value_free_to_mark (mark
);
8691 /* An ordinary record type (with fixed-length fields) that describes
8692 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8693 beginning of this section]. Any necessary discriminants' values
8694 should be in DVAL, a record value; it may be NULL if the object
8695 at ADDR itself contains any necessary discriminant values.
8696 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8697 values from the record are needed. Except in the case that DVAL,
8698 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8699 unchecked) is replaced by a particular branch of the variant.
8701 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8702 is questionable and may be removed. It can arise during the
8703 processing of an unconstrained-array-of-record type where all the
8704 variant branches have exactly the same size. This is because in
8705 such cases, the compiler does not bother to use the XVS convention
8706 when encoding the record. I am currently dubious of this
8707 shortcut and suspect the compiler should be altered. FIXME. */
8709 static struct type
*
8710 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8711 CORE_ADDR address
, struct value
*dval
)
8713 struct type
*templ_type
;
8715 if (TYPE_FIXED_INSTANCE (type0
))
8718 templ_type
= dynamic_template_type (type0
);
8720 if (templ_type
!= NULL
)
8721 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8722 else if (variant_field_index (type0
) >= 0)
8724 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8726 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8731 TYPE_FIXED_INSTANCE (type0
) = 1;
8737 /* An ordinary record type (with fixed-length fields) that describes
8738 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8739 union type. Any necessary discriminants' values should be in DVAL,
8740 a record value. That is, this routine selects the appropriate
8741 branch of the union at ADDR according to the discriminant value
8742 indicated in the union's type name. Returns VAR_TYPE0 itself if
8743 it represents a variant subject to a pragma Unchecked_Union. */
8745 static struct type
*
8746 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8747 CORE_ADDR address
, struct value
*dval
)
8750 struct type
*templ_type
;
8751 struct type
*var_type
;
8753 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
8754 var_type
= TYPE_TARGET_TYPE (var_type0
);
8756 var_type
= var_type0
;
8758 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8760 if (templ_type
!= NULL
)
8761 var_type
= templ_type
;
8763 if (is_unchecked_variant (var_type
, value_type (dval
)))
8766 ada_which_variant_applies (var_type
,
8767 value_type (dval
), value_contents (dval
));
8770 return empty_record (var_type
);
8771 else if (is_dynamic_field (var_type
, which
))
8772 return to_fixed_record_type
8773 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
8774 valaddr
, address
, dval
);
8775 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
8777 to_fixed_record_type
8778 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
8780 return TYPE_FIELD_TYPE (var_type
, which
);
8783 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8784 ENCODING_TYPE, a type following the GNAT conventions for discrete
8785 type encodings, only carries redundant information. */
8788 ada_is_redundant_range_encoding (struct type
*range_type
,
8789 struct type
*encoding_type
)
8791 const char *bounds_str
;
8795 gdb_assert (TYPE_CODE (range_type
) == TYPE_CODE_RANGE
);
8797 if (TYPE_CODE (get_base_type (range_type
))
8798 != TYPE_CODE (get_base_type (encoding_type
)))
8800 /* The compiler probably used a simple base type to describe
8801 the range type instead of the range's actual base type,
8802 expecting us to get the real base type from the encoding
8803 anyway. In this situation, the encoding cannot be ignored
8808 if (is_dynamic_type (range_type
))
8811 if (TYPE_NAME (encoding_type
) == NULL
)
8814 bounds_str
= strstr (TYPE_NAME (encoding_type
), "___XDLU_");
8815 if (bounds_str
== NULL
)
8818 n
= 8; /* Skip "___XDLU_". */
8819 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8821 if (TYPE_LOW_BOUND (range_type
) != lo
)
8824 n
+= 2; /* Skip the "__" separator between the two bounds. */
8825 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8827 if (TYPE_HIGH_BOUND (range_type
) != hi
)
8833 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8834 a type following the GNAT encoding for describing array type
8835 indices, only carries redundant information. */
8838 ada_is_redundant_index_type_desc (struct type
*array_type
,
8839 struct type
*desc_type
)
8841 struct type
*this_layer
= check_typedef (array_type
);
8844 for (i
= 0; i
< TYPE_NFIELDS (desc_type
); i
++)
8846 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer
),
8847 TYPE_FIELD_TYPE (desc_type
, i
)))
8849 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8855 /* Assuming that TYPE0 is an array type describing the type of a value
8856 at ADDR, and that DVAL describes a record containing any
8857 discriminants used in TYPE0, returns a type for the value that
8858 contains no dynamic components (that is, no components whose sizes
8859 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8860 true, gives an error message if the resulting type's size is over
8863 static struct type
*
8864 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8867 struct type
*index_type_desc
;
8868 struct type
*result
;
8869 int constrained_packed_array_p
;
8870 static const char *xa_suffix
= "___XA";
8872 type0
= ada_check_typedef (type0
);
8873 if (TYPE_FIXED_INSTANCE (type0
))
8876 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8877 if (constrained_packed_array_p
)
8878 type0
= decode_constrained_packed_array_type (type0
);
8880 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8882 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8883 encoding suffixed with 'P' may still be generated. If so,
8884 it should be used to find the XA type. */
8886 if (index_type_desc
== NULL
)
8888 const char *type_name
= ada_type_name (type0
);
8890 if (type_name
!= NULL
)
8892 const int len
= strlen (type_name
);
8893 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8895 if (type_name
[len
- 1] == 'P')
8897 strcpy (name
, type_name
);
8898 strcpy (name
+ len
- 1, xa_suffix
);
8899 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8904 ada_fixup_array_indexes_type (index_type_desc
);
8905 if (index_type_desc
!= NULL
8906 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8908 /* Ignore this ___XA parallel type, as it does not bring any
8909 useful information. This allows us to avoid creating fixed
8910 versions of the array's index types, which would be identical
8911 to the original ones. This, in turn, can also help avoid
8912 the creation of fixed versions of the array itself. */
8913 index_type_desc
= NULL
;
8916 if (index_type_desc
== NULL
)
8918 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8920 /* NOTE: elt_type---the fixed version of elt_type0---should never
8921 depend on the contents of the array in properly constructed
8923 /* Create a fixed version of the array element type.
8924 We're not providing the address of an element here,
8925 and thus the actual object value cannot be inspected to do
8926 the conversion. This should not be a problem, since arrays of
8927 unconstrained objects are not allowed. In particular, all
8928 the elements of an array of a tagged type should all be of
8929 the same type specified in the debugging info. No need to
8930 consult the object tag. */
8931 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8933 /* Make sure we always create a new array type when dealing with
8934 packed array types, since we're going to fix-up the array
8935 type length and element bitsize a little further down. */
8936 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8939 result
= create_array_type (alloc_type_copy (type0
),
8940 elt_type
, TYPE_INDEX_TYPE (type0
));
8945 struct type
*elt_type0
;
8948 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
8949 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8951 /* NOTE: result---the fixed version of elt_type0---should never
8952 depend on the contents of the array in properly constructed
8954 /* Create a fixed version of the array element type.
8955 We're not providing the address of an element here,
8956 and thus the actual object value cannot be inspected to do
8957 the conversion. This should not be a problem, since arrays of
8958 unconstrained objects are not allowed. In particular, all
8959 the elements of an array of a tagged type should all be of
8960 the same type specified in the debugging info. No need to
8961 consult the object tag. */
8963 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8966 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
8968 struct type
*range_type
=
8969 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, i
), dval
);
8971 result
= create_array_type (alloc_type_copy (elt_type0
),
8972 result
, range_type
);
8973 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8975 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8976 error (_("array type with dynamic size is larger than varsize-limit"));
8979 /* We want to preserve the type name. This can be useful when
8980 trying to get the type name of a value that has already been
8981 printed (for instance, if the user did "print VAR; whatis $". */
8982 TYPE_NAME (result
) = TYPE_NAME (type0
);
8984 if (constrained_packed_array_p
)
8986 /* So far, the resulting type has been created as if the original
8987 type was a regular (non-packed) array type. As a result, the
8988 bitsize of the array elements needs to be set again, and the array
8989 length needs to be recomputed based on that bitsize. */
8990 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8991 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8993 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8994 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8995 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8996 TYPE_LENGTH (result
)++;
8999 TYPE_FIXED_INSTANCE (result
) = 1;
9004 /* A standard type (containing no dynamically sized components)
9005 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
9006 DVAL describes a record containing any discriminants used in TYPE0,
9007 and may be NULL if there are none, or if the object of type TYPE at
9008 ADDRESS or in VALADDR contains these discriminants.
9010 If CHECK_TAG is not null, in the case of tagged types, this function
9011 attempts to locate the object's tag and use it to compute the actual
9012 type. However, when ADDRESS is null, we cannot use it to determine the
9013 location of the tag, and therefore compute the tagged type's actual type.
9014 So we return the tagged type without consulting the tag. */
9016 static struct type
*
9017 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
9018 CORE_ADDR address
, struct value
*dval
, int check_tag
)
9020 type
= ada_check_typedef (type
);
9022 /* Only un-fixed types need to be handled here. */
9023 if (!HAVE_GNAT_AUX_INFO (type
))
9026 switch (TYPE_CODE (type
))
9030 case TYPE_CODE_STRUCT
:
9032 struct type
*static_type
= to_static_fixed_type (type
);
9033 struct type
*fixed_record_type
=
9034 to_fixed_record_type (type
, valaddr
, address
, NULL
);
9036 /* If STATIC_TYPE is a tagged type and we know the object's address,
9037 then we can determine its tag, and compute the object's actual
9038 type from there. Note that we have to use the fixed record
9039 type (the parent part of the record may have dynamic fields
9040 and the way the location of _tag is expressed may depend on
9043 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
9046 value_tag_from_contents_and_address
9050 struct type
*real_type
= type_from_tag (tag
);
9052 value_from_contents_and_address (fixed_record_type
,
9055 fixed_record_type
= value_type (obj
);
9056 if (real_type
!= NULL
)
9057 return to_fixed_record_type
9059 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
9062 /* Check to see if there is a parallel ___XVZ variable.
9063 If there is, then it provides the actual size of our type. */
9064 else if (ada_type_name (fixed_record_type
) != NULL
)
9066 const char *name
= ada_type_name (fixed_record_type
);
9068 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
9069 bool xvz_found
= false;
9072 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
9075 xvz_found
= get_int_var_value (xvz_name
, size
);
9077 catch (const gdb_exception_error
&except
)
9079 /* We found the variable, but somehow failed to read
9080 its value. Rethrow the same error, but with a little
9081 bit more information, to help the user understand
9082 what went wrong (Eg: the variable might have been
9084 throw_error (except
.error
,
9085 _("unable to read value of %s (%s)"),
9086 xvz_name
, except
.what ());
9089 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
9091 fixed_record_type
= copy_type (fixed_record_type
);
9092 TYPE_LENGTH (fixed_record_type
) = size
;
9094 /* The FIXED_RECORD_TYPE may have be a stub. We have
9095 observed this when the debugging info is STABS, and
9096 apparently it is something that is hard to fix.
9098 In practice, we don't need the actual type definition
9099 at all, because the presence of the XVZ variable allows us
9100 to assume that there must be a XVS type as well, which we
9101 should be able to use later, when we need the actual type
9104 In the meantime, pretend that the "fixed" type we are
9105 returning is NOT a stub, because this can cause trouble
9106 when using this type to create new types targeting it.
9107 Indeed, the associated creation routines often check
9108 whether the target type is a stub and will try to replace
9109 it, thus using a type with the wrong size. This, in turn,
9110 might cause the new type to have the wrong size too.
9111 Consider the case of an array, for instance, where the size
9112 of the array is computed from the number of elements in
9113 our array multiplied by the size of its element. */
9114 TYPE_STUB (fixed_record_type
) = 0;
9117 return fixed_record_type
;
9119 case TYPE_CODE_ARRAY
:
9120 return to_fixed_array_type (type
, dval
, 1);
9121 case TYPE_CODE_UNION
:
9125 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
9129 /* The same as ada_to_fixed_type_1, except that it preserves the type
9130 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
9132 The typedef layer needs be preserved in order to differentiate between
9133 arrays and array pointers when both types are implemented using the same
9134 fat pointer. In the array pointer case, the pointer is encoded as
9135 a typedef of the pointer type. For instance, considering:
9137 type String_Access is access String;
9138 S1 : String_Access := null;
9140 To the debugger, S1 is defined as a typedef of type String. But
9141 to the user, it is a pointer. So if the user tries to print S1,
9142 we should not dereference the array, but print the array address
9145 If we didn't preserve the typedef layer, we would lose the fact that
9146 the type is to be presented as a pointer (needs de-reference before
9147 being printed). And we would also use the source-level type name. */
9150 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
9151 CORE_ADDR address
, struct value
*dval
, int check_tag
)
9154 struct type
*fixed_type
=
9155 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
9157 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9158 then preserve the typedef layer.
9160 Implementation note: We can only check the main-type portion of
9161 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9162 from TYPE now returns a type that has the same instance flags
9163 as TYPE. For instance, if TYPE is a "typedef const", and its
9164 target type is a "struct", then the typedef elimination will return
9165 a "const" version of the target type. See check_typedef for more
9166 details about how the typedef layer elimination is done.
9168 brobecker/2010-11-19: It seems to me that the only case where it is
9169 useful to preserve the typedef layer is when dealing with fat pointers.
9170 Perhaps, we could add a check for that and preserve the typedef layer
9171 only in that situation. But this seems unecessary so far, probably
9172 because we call check_typedef/ada_check_typedef pretty much everywhere.
9174 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
9175 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
9176 == TYPE_MAIN_TYPE (fixed_type
)))
9182 /* A standard (static-sized) type corresponding as well as possible to
9183 TYPE0, but based on no runtime data. */
9185 static struct type
*
9186 to_static_fixed_type (struct type
*type0
)
9193 if (TYPE_FIXED_INSTANCE (type0
))
9196 type0
= ada_check_typedef (type0
);
9198 switch (TYPE_CODE (type0
))
9202 case TYPE_CODE_STRUCT
:
9203 type
= dynamic_template_type (type0
);
9205 return template_to_static_fixed_type (type
);
9207 return template_to_static_fixed_type (type0
);
9208 case TYPE_CODE_UNION
:
9209 type
= ada_find_parallel_type (type0
, "___XVU");
9211 return template_to_static_fixed_type (type
);
9213 return template_to_static_fixed_type (type0
);
9217 /* A static approximation of TYPE with all type wrappers removed. */
9219 static struct type
*
9220 static_unwrap_type (struct type
*type
)
9222 if (ada_is_aligner_type (type
))
9224 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
9225 if (ada_type_name (type1
) == NULL
)
9226 TYPE_NAME (type1
) = ada_type_name (type
);
9228 return static_unwrap_type (type1
);
9232 struct type
*raw_real_type
= ada_get_base_type (type
);
9234 if (raw_real_type
== type
)
9237 return to_static_fixed_type (raw_real_type
);
9241 /* In some cases, incomplete and private types require
9242 cross-references that are not resolved as records (for example,
9244 type FooP is access Foo;
9246 type Foo is array ...;
9247 ). In these cases, since there is no mechanism for producing
9248 cross-references to such types, we instead substitute for FooP a
9249 stub enumeration type that is nowhere resolved, and whose tag is
9250 the name of the actual type. Call these types "non-record stubs". */
9252 /* A type equivalent to TYPE that is not a non-record stub, if one
9253 exists, otherwise TYPE. */
9256 ada_check_typedef (struct type
*type
)
9261 /* If our type is an access to an unconstrained array, which is encoded
9262 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
9263 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9264 what allows us to distinguish between fat pointers that represent
9265 array types, and fat pointers that represent array access types
9266 (in both cases, the compiler implements them as fat pointers). */
9267 if (ada_is_access_to_unconstrained_array (type
))
9270 type
= check_typedef (type
);
9271 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
9272 || !TYPE_STUB (type
)
9273 || TYPE_NAME (type
) == NULL
)
9277 const char *name
= TYPE_NAME (type
);
9278 struct type
*type1
= ada_find_any_type (name
);
9283 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9284 stubs pointing to arrays, as we don't create symbols for array
9285 types, only for the typedef-to-array types). If that's the case,
9286 strip the typedef layer. */
9287 if (TYPE_CODE (type1
) == TYPE_CODE_TYPEDEF
)
9288 type1
= ada_check_typedef (type1
);
9294 /* A value representing the data at VALADDR/ADDRESS as described by
9295 type TYPE0, but with a standard (static-sized) type that correctly
9296 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9297 type, then return VAL0 [this feature is simply to avoid redundant
9298 creation of struct values]. */
9300 static struct value
*
9301 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
9304 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
9306 if (type
== type0
&& val0
!= NULL
)
9309 if (VALUE_LVAL (val0
) != lval_memory
)
9311 /* Our value does not live in memory; it could be a convenience
9312 variable, for instance. Create a not_lval value using val0's
9314 return value_from_contents (type
, value_contents (val0
));
9317 return value_from_contents_and_address (type
, 0, address
);
9320 /* A value representing VAL, but with a standard (static-sized) type
9321 that correctly describes it. Does not necessarily create a new
9325 ada_to_fixed_value (struct value
*val
)
9327 val
= unwrap_value (val
);
9328 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
9335 /* Table mapping attribute numbers to names.
9336 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
9338 static const char *attribute_names
[] = {
9356 ada_attribute_name (enum exp_opcode n
)
9358 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
9359 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
9361 return attribute_names
[0];
9364 /* Evaluate the 'POS attribute applied to ARG. */
9367 pos_atr (struct value
*arg
)
9369 struct value
*val
= coerce_ref (arg
);
9370 struct type
*type
= value_type (val
);
9373 if (!discrete_type_p (type
))
9374 error (_("'POS only defined on discrete types"));
9376 if (!discrete_position (type
, value_as_long (val
), &result
))
9377 error (_("enumeration value is invalid: can't find 'POS"));
9382 static struct value
*
9383 value_pos_atr (struct type
*type
, struct value
*arg
)
9385 return value_from_longest (type
, pos_atr (arg
));
9388 /* Evaluate the TYPE'VAL attribute applied to ARG. */
9390 static struct value
*
9391 value_val_atr (struct type
*type
, struct value
*arg
)
9393 if (!discrete_type_p (type
))
9394 error (_("'VAL only defined on discrete types"));
9395 if (!integer_type_p (value_type (arg
)))
9396 error (_("'VAL requires integral argument"));
9398 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
9400 long pos
= value_as_long (arg
);
9402 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
9403 error (_("argument to 'VAL out of range"));
9404 return value_from_longest (type
, TYPE_FIELD_ENUMVAL (type
, pos
));
9407 return value_from_longest (type
, value_as_long (arg
));
9413 /* True if TYPE appears to be an Ada character type.
9414 [At the moment, this is true only for Character and Wide_Character;
9415 It is a heuristic test that could stand improvement]. */
9418 ada_is_character_type (struct type
*type
)
9422 /* If the type code says it's a character, then assume it really is,
9423 and don't check any further. */
9424 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
9427 /* Otherwise, assume it's a character type iff it is a discrete type
9428 with a known character type name. */
9429 name
= ada_type_name (type
);
9430 return (name
!= NULL
9431 && (TYPE_CODE (type
) == TYPE_CODE_INT
9432 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
9433 && (strcmp (name
, "character") == 0
9434 || strcmp (name
, "wide_character") == 0
9435 || strcmp (name
, "wide_wide_character") == 0
9436 || strcmp (name
, "unsigned char") == 0));
9439 /* True if TYPE appears to be an Ada string type. */
9442 ada_is_string_type (struct type
*type
)
9444 type
= ada_check_typedef (type
);
9446 && TYPE_CODE (type
) != TYPE_CODE_PTR
9447 && (ada_is_simple_array_type (type
)
9448 || ada_is_array_descriptor_type (type
))
9449 && ada_array_arity (type
) == 1)
9451 struct type
*elttype
= ada_array_element_type (type
, 1);
9453 return ada_is_character_type (elttype
);
9459 /* The compiler sometimes provides a parallel XVS type for a given
9460 PAD type. Normally, it is safe to follow the PAD type directly,
9461 but older versions of the compiler have a bug that causes the offset
9462 of its "F" field to be wrong. Following that field in that case
9463 would lead to incorrect results, but this can be worked around
9464 by ignoring the PAD type and using the associated XVS type instead.
9466 Set to True if the debugger should trust the contents of PAD types.
9467 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9468 static int trust_pad_over_xvs
= 1;
9470 /* True if TYPE is a struct type introduced by the compiler to force the
9471 alignment of a value. Such types have a single field with a
9472 distinctive name. */
9475 ada_is_aligner_type (struct type
*type
)
9477 type
= ada_check_typedef (type
);
9479 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9482 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
9483 && TYPE_NFIELDS (type
) == 1
9484 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9487 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9488 the parallel type. */
9491 ada_get_base_type (struct type
*raw_type
)
9493 struct type
*real_type_namer
;
9494 struct type
*raw_real_type
;
9496 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
9499 if (ada_is_aligner_type (raw_type
))
9500 /* The encoding specifies that we should always use the aligner type.
9501 So, even if this aligner type has an associated XVS type, we should
9504 According to the compiler gurus, an XVS type parallel to an aligner
9505 type may exist because of a stabs limitation. In stabs, aligner
9506 types are empty because the field has a variable-sized type, and
9507 thus cannot actually be used as an aligner type. As a result,
9508 we need the associated parallel XVS type to decode the type.
9509 Since the policy in the compiler is to not change the internal
9510 representation based on the debugging info format, we sometimes
9511 end up having a redundant XVS type parallel to the aligner type. */
9514 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9515 if (real_type_namer
== NULL
9516 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
9517 || TYPE_NFIELDS (real_type_namer
) != 1)
9520 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer
, 0)) != TYPE_CODE_REF
)
9522 /* This is an older encoding form where the base type needs to be
9523 looked up by name. We prefer the newer enconding because it is
9525 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9526 if (raw_real_type
== NULL
)
9529 return raw_real_type
;
9532 /* The field in our XVS type is a reference to the base type. */
9533 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer
, 0));
9536 /* The type of value designated by TYPE, with all aligners removed. */
9539 ada_aligned_type (struct type
*type
)
9541 if (ada_is_aligner_type (type
))
9542 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
9544 return ada_get_base_type (type
);
9548 /* The address of the aligned value in an object at address VALADDR
9549 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9552 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9554 if (ada_is_aligner_type (type
))
9555 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
9557 TYPE_FIELD_BITPOS (type
,
9558 0) / TARGET_CHAR_BIT
);
9565 /* The printed representation of an enumeration literal with encoded
9566 name NAME. The value is good to the next call of ada_enum_name. */
9568 ada_enum_name (const char *name
)
9570 static char *result
;
9571 static size_t result_len
= 0;
9574 /* First, unqualify the enumeration name:
9575 1. Search for the last '.' character. If we find one, then skip
9576 all the preceding characters, the unqualified name starts
9577 right after that dot.
9578 2. Otherwise, we may be debugging on a target where the compiler
9579 translates dots into "__". Search forward for double underscores,
9580 but stop searching when we hit an overloading suffix, which is
9581 of the form "__" followed by digits. */
9583 tmp
= strrchr (name
, '.');
9588 while ((tmp
= strstr (name
, "__")) != NULL
)
9590 if (isdigit (tmp
[2]))
9601 if (name
[1] == 'U' || name
[1] == 'W')
9603 if (sscanf (name
+ 2, "%x", &v
) != 1)
9609 GROW_VECT (result
, result_len
, 16);
9610 if (isascii (v
) && isprint (v
))
9611 xsnprintf (result
, result_len
, "'%c'", v
);
9612 else if (name
[1] == 'U')
9613 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9615 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9621 tmp
= strstr (name
, "__");
9623 tmp
= strstr (name
, "$");
9626 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9627 strncpy (result
, name
, tmp
- name
);
9628 result
[tmp
- name
] = '\0';
9636 /* Evaluate the subexpression of EXP starting at *POS as for
9637 evaluate_type, updating *POS to point just past the evaluated
9640 static struct value
*
9641 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9643 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9646 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9649 static struct value
*
9650 unwrap_value (struct value
*val
)
9652 struct type
*type
= ada_check_typedef (value_type (val
));
9654 if (ada_is_aligner_type (type
))
9656 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9657 struct type
*val_type
= ada_check_typedef (value_type (v
));
9659 if (ada_type_name (val_type
) == NULL
)
9660 TYPE_NAME (val_type
) = ada_type_name (type
);
9662 return unwrap_value (v
);
9666 struct type
*raw_real_type
=
9667 ada_check_typedef (ada_get_base_type (type
));
9669 /* If there is no parallel XVS or XVE type, then the value is
9670 already unwrapped. Return it without further modification. */
9671 if ((type
== raw_real_type
)
9672 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9676 coerce_unspec_val_to_type
9677 (val
, ada_to_fixed_type (raw_real_type
, 0,
9678 value_address (val
),
9683 static struct value
*
9684 cast_from_fixed (struct type
*type
, struct value
*arg
)
9686 struct value
*scale
= ada_scaling_factor (value_type (arg
));
9687 arg
= value_cast (value_type (scale
), arg
);
9689 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9690 return value_cast (type
, arg
);
9693 static struct value
*
9694 cast_to_fixed (struct type
*type
, struct value
*arg
)
9696 if (type
== value_type (arg
))
9699 struct value
*scale
= ada_scaling_factor (type
);
9700 if (ada_is_fixed_point_type (value_type (arg
)))
9701 arg
= cast_from_fixed (value_type (scale
), arg
);
9703 arg
= value_cast (value_type (scale
), arg
);
9705 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9706 return value_cast (type
, arg
);
9709 /* Given two array types T1 and T2, return nonzero iff both arrays
9710 contain the same number of elements. */
9713 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9715 LONGEST lo1
, hi1
, lo2
, hi2
;
9717 /* Get the array bounds in order to verify that the size of
9718 the two arrays match. */
9719 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9720 || !get_array_bounds (t2
, &lo2
, &hi2
))
9721 error (_("unable to determine array bounds"));
9723 /* To make things easier for size comparison, normalize a bit
9724 the case of empty arrays by making sure that the difference
9725 between upper bound and lower bound is always -1. */
9731 return (hi1
- lo1
== hi2
- lo2
);
9734 /* Assuming that VAL is an array of integrals, and TYPE represents
9735 an array with the same number of elements, but with wider integral
9736 elements, return an array "casted" to TYPE. In practice, this
9737 means that the returned array is built by casting each element
9738 of the original array into TYPE's (wider) element type. */
9740 static struct value
*
9741 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9743 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9748 /* Verify that both val and type are arrays of scalars, and
9749 that the size of val's elements is smaller than the size
9750 of type's element. */
9751 gdb_assert (TYPE_CODE (type
) == TYPE_CODE_ARRAY
);
9752 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9753 gdb_assert (TYPE_CODE (value_type (val
)) == TYPE_CODE_ARRAY
);
9754 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9755 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9756 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9758 if (!get_array_bounds (type
, &lo
, &hi
))
9759 error (_("unable to determine array bounds"));
9761 res
= allocate_value (type
);
9763 /* Promote each array element. */
9764 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9766 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9768 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9769 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9775 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9776 return the converted value. */
9778 static struct value
*
9779 coerce_for_assign (struct type
*type
, struct value
*val
)
9781 struct type
*type2
= value_type (val
);
9786 type2
= ada_check_typedef (type2
);
9787 type
= ada_check_typedef (type
);
9789 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
9790 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9792 val
= ada_value_ind (val
);
9793 type2
= value_type (val
);
9796 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
9797 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9799 if (!ada_same_array_size_p (type
, type2
))
9800 error (_("cannot assign arrays of different length"));
9802 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9803 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9804 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9805 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9807 /* Allow implicit promotion of the array elements to
9809 return ada_promote_array_of_integrals (type
, val
);
9812 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9813 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9814 error (_("Incompatible types in assignment"));
9815 deprecated_set_value_type (val
, type
);
9820 static struct value
*
9821 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9824 struct type
*type1
, *type2
;
9827 arg1
= coerce_ref (arg1
);
9828 arg2
= coerce_ref (arg2
);
9829 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9830 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9832 if (TYPE_CODE (type1
) != TYPE_CODE_INT
9833 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
9834 return value_binop (arg1
, arg2
, op
);
9843 return value_binop (arg1
, arg2
, op
);
9846 v2
= value_as_long (arg2
);
9848 error (_("second operand of %s must not be zero."), op_string (op
));
9850 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
9851 return value_binop (arg1
, arg2
, op
);
9853 v1
= value_as_long (arg1
);
9858 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9859 v
+= v
> 0 ? -1 : 1;
9867 /* Should not reach this point. */
9871 val
= allocate_value (type1
);
9872 store_unsigned_integer (value_contents_raw (val
),
9873 TYPE_LENGTH (value_type (val
)),
9874 gdbarch_byte_order (get_type_arch (type1
)), v
);
9879 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9881 if (ada_is_direct_array_type (value_type (arg1
))
9882 || ada_is_direct_array_type (value_type (arg2
)))
9884 struct type
*arg1_type
, *arg2_type
;
9886 /* Automatically dereference any array reference before
9887 we attempt to perform the comparison. */
9888 arg1
= ada_coerce_ref (arg1
);
9889 arg2
= ada_coerce_ref (arg2
);
9891 arg1
= ada_coerce_to_simple_array (arg1
);
9892 arg2
= ada_coerce_to_simple_array (arg2
);
9894 arg1_type
= ada_check_typedef (value_type (arg1
));
9895 arg2_type
= ada_check_typedef (value_type (arg2
));
9897 if (TYPE_CODE (arg1_type
) != TYPE_CODE_ARRAY
9898 || TYPE_CODE (arg2_type
) != TYPE_CODE_ARRAY
)
9899 error (_("Attempt to compare array with non-array"));
9900 /* FIXME: The following works only for types whose
9901 representations use all bits (no padding or undefined bits)
9902 and do not have user-defined equality. */
9903 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9904 && memcmp (value_contents (arg1
), value_contents (arg2
),
9905 TYPE_LENGTH (arg1_type
)) == 0);
9907 return value_equal (arg1
, arg2
);
9910 /* Total number of component associations in the aggregate starting at
9911 index PC in EXP. Assumes that index PC is the start of an
9915 num_component_specs (struct expression
*exp
, int pc
)
9919 m
= exp
->elts
[pc
+ 1].longconst
;
9922 for (i
= 0; i
< m
; i
+= 1)
9924 switch (exp
->elts
[pc
].opcode
)
9930 n
+= exp
->elts
[pc
+ 1].longconst
;
9933 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9938 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9939 component of LHS (a simple array or a record), updating *POS past
9940 the expression, assuming that LHS is contained in CONTAINER. Does
9941 not modify the inferior's memory, nor does it modify LHS (unless
9942 LHS == CONTAINER). */
9945 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9946 struct expression
*exp
, int *pos
)
9948 struct value
*mark
= value_mark ();
9950 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9952 if (TYPE_CODE (lhs_type
) == TYPE_CODE_ARRAY
)
9954 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9955 struct value
*index_val
= value_from_longest (index_type
, index
);
9957 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9961 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9962 elt
= ada_to_fixed_value (elt
);
9965 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9966 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9968 value_assign_to_component (container
, elt
,
9969 ada_evaluate_subexp (NULL
, exp
, pos
,
9972 value_free_to_mark (mark
);
9975 /* Assuming that LHS represents an lvalue having a record or array
9976 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9977 of that aggregate's value to LHS, advancing *POS past the
9978 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9979 lvalue containing LHS (possibly LHS itself). Does not modify
9980 the inferior's memory, nor does it modify the contents of
9981 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9983 static struct value
*
9984 assign_aggregate (struct value
*container
,
9985 struct value
*lhs
, struct expression
*exp
,
9986 int *pos
, enum noside noside
)
9988 struct type
*lhs_type
;
9989 int n
= exp
->elts
[*pos
+1].longconst
;
9990 LONGEST low_index
, high_index
;
9993 int max_indices
, num_indices
;
9997 if (noside
!= EVAL_NORMAL
)
9999 for (i
= 0; i
< n
; i
+= 1)
10000 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
10004 container
= ada_coerce_ref (container
);
10005 if (ada_is_direct_array_type (value_type (container
)))
10006 container
= ada_coerce_to_simple_array (container
);
10007 lhs
= ada_coerce_ref (lhs
);
10008 if (!deprecated_value_modifiable (lhs
))
10009 error (_("Left operand of assignment is not a modifiable lvalue."));
10011 lhs_type
= check_typedef (value_type (lhs
));
10012 if (ada_is_direct_array_type (lhs_type
))
10014 lhs
= ada_coerce_to_simple_array (lhs
);
10015 lhs_type
= check_typedef (value_type (lhs
));
10016 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
10017 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
10019 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
10022 high_index
= num_visible_fields (lhs_type
) - 1;
10025 error (_("Left-hand side must be array or record."));
10027 num_specs
= num_component_specs (exp
, *pos
- 3);
10028 max_indices
= 4 * num_specs
+ 4;
10029 indices
= XALLOCAVEC (LONGEST
, max_indices
);
10030 indices
[0] = indices
[1] = low_index
- 1;
10031 indices
[2] = indices
[3] = high_index
+ 1;
10034 for (i
= 0; i
< n
; i
+= 1)
10036 switch (exp
->elts
[*pos
].opcode
)
10039 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
10040 &num_indices
, max_indices
,
10041 low_index
, high_index
);
10043 case OP_POSITIONAL
:
10044 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
10045 &num_indices
, max_indices
,
10046 low_index
, high_index
);
10050 error (_("Misplaced 'others' clause"));
10051 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
10052 num_indices
, low_index
, high_index
);
10055 error (_("Internal error: bad aggregate clause"));
10062 /* Assign into the component of LHS indexed by the OP_POSITIONAL
10063 construct at *POS, updating *POS past the construct, given that
10064 the positions are relative to lower bound LOW, where HIGH is the
10065 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
10066 updating *NUM_INDICES as needed. CONTAINER is as for
10067 assign_aggregate. */
10069 aggregate_assign_positional (struct value
*container
,
10070 struct value
*lhs
, struct expression
*exp
,
10071 int *pos
, LONGEST
*indices
, int *num_indices
,
10072 int max_indices
, LONGEST low
, LONGEST high
)
10074 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
10076 if (ind
- 1 == high
)
10077 warning (_("Extra components in aggregate ignored."));
10080 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
10082 assign_component (container
, lhs
, ind
, exp
, pos
);
10085 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
10088 /* Assign into the components of LHS indexed by the OP_CHOICES
10089 construct at *POS, updating *POS past the construct, given that
10090 the allowable indices are LOW..HIGH. Record the indices assigned
10091 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
10092 needed. CONTAINER is as for assign_aggregate. */
10094 aggregate_assign_from_choices (struct value
*container
,
10095 struct value
*lhs
, struct expression
*exp
,
10096 int *pos
, LONGEST
*indices
, int *num_indices
,
10097 int max_indices
, LONGEST low
, LONGEST high
)
10100 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
10101 int choice_pos
, expr_pc
;
10102 int is_array
= ada_is_direct_array_type (value_type (lhs
));
10104 choice_pos
= *pos
+= 3;
10106 for (j
= 0; j
< n_choices
; j
+= 1)
10107 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
10109 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
10111 for (j
= 0; j
< n_choices
; j
+= 1)
10113 LONGEST lower
, upper
;
10114 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
10116 if (op
== OP_DISCRETE_RANGE
)
10119 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
10121 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
10126 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
10138 name
= &exp
->elts
[choice_pos
+ 2].string
;
10141 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
10144 error (_("Invalid record component association."));
10146 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
10148 if (! find_struct_field (name
, value_type (lhs
), 0,
10149 NULL
, NULL
, NULL
, NULL
, &ind
))
10150 error (_("Unknown component name: %s."), name
);
10151 lower
= upper
= ind
;
10154 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
10155 error (_("Index in component association out of bounds."));
10157 add_component_interval (lower
, upper
, indices
, num_indices
,
10159 while (lower
<= upper
)
10164 assign_component (container
, lhs
, lower
, exp
, &pos1
);
10170 /* Assign the value of the expression in the OP_OTHERS construct in
10171 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10172 have not been previously assigned. The index intervals already assigned
10173 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
10174 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
10176 aggregate_assign_others (struct value
*container
,
10177 struct value
*lhs
, struct expression
*exp
,
10178 int *pos
, LONGEST
*indices
, int num_indices
,
10179 LONGEST low
, LONGEST high
)
10182 int expr_pc
= *pos
+ 1;
10184 for (i
= 0; i
< num_indices
- 2; i
+= 2)
10188 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
10192 localpos
= expr_pc
;
10193 assign_component (container
, lhs
, ind
, exp
, &localpos
);
10196 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
10199 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
10200 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10201 modifying *SIZE as needed. It is an error if *SIZE exceeds
10202 MAX_SIZE. The resulting intervals do not overlap. */
10204 add_component_interval (LONGEST low
, LONGEST high
,
10205 LONGEST
* indices
, int *size
, int max_size
)
10209 for (i
= 0; i
< *size
; i
+= 2) {
10210 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
10214 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
10215 if (high
< indices
[kh
])
10217 if (low
< indices
[i
])
10219 indices
[i
+ 1] = indices
[kh
- 1];
10220 if (high
> indices
[i
+ 1])
10221 indices
[i
+ 1] = high
;
10222 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
10223 *size
-= kh
- i
- 2;
10226 else if (high
< indices
[i
])
10230 if (*size
== max_size
)
10231 error (_("Internal error: miscounted aggregate components."));
10233 for (j
= *size
-1; j
>= i
+2; j
-= 1)
10234 indices
[j
] = indices
[j
- 2];
10236 indices
[i
+ 1] = high
;
10239 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10242 static struct value
*
10243 ada_value_cast (struct type
*type
, struct value
*arg2
)
10245 if (type
== ada_check_typedef (value_type (arg2
)))
10248 if (ada_is_fixed_point_type (type
))
10249 return cast_to_fixed (type
, arg2
);
10251 if (ada_is_fixed_point_type (value_type (arg2
)))
10252 return cast_from_fixed (type
, arg2
);
10254 return value_cast (type
, arg2
);
10257 /* Evaluating Ada expressions, and printing their result.
10258 ------------------------------------------------------
10263 We usually evaluate an Ada expression in order to print its value.
10264 We also evaluate an expression in order to print its type, which
10265 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10266 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10267 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10268 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10271 Evaluating expressions is a little more complicated for Ada entities
10272 than it is for entities in languages such as C. The main reason for
10273 this is that Ada provides types whose definition might be dynamic.
10274 One example of such types is variant records. Or another example
10275 would be an array whose bounds can only be known at run time.
10277 The following description is a general guide as to what should be
10278 done (and what should NOT be done) in order to evaluate an expression
10279 involving such types, and when. This does not cover how the semantic
10280 information is encoded by GNAT as this is covered separatly. For the
10281 document used as the reference for the GNAT encoding, see exp_dbug.ads
10282 in the GNAT sources.
10284 Ideally, we should embed each part of this description next to its
10285 associated code. Unfortunately, the amount of code is so vast right
10286 now that it's hard to see whether the code handling a particular
10287 situation might be duplicated or not. One day, when the code is
10288 cleaned up, this guide might become redundant with the comments
10289 inserted in the code, and we might want to remove it.
10291 2. ``Fixing'' an Entity, the Simple Case:
10292 -----------------------------------------
10294 When evaluating Ada expressions, the tricky issue is that they may
10295 reference entities whose type contents and size are not statically
10296 known. Consider for instance a variant record:
10298 type Rec (Empty : Boolean := True) is record
10301 when False => Value : Integer;
10304 Yes : Rec := (Empty => False, Value => 1);
10305 No : Rec := (empty => True);
10307 The size and contents of that record depends on the value of the
10308 descriminant (Rec.Empty). At this point, neither the debugging
10309 information nor the associated type structure in GDB are able to
10310 express such dynamic types. So what the debugger does is to create
10311 "fixed" versions of the type that applies to the specific object.
10312 We also informally refer to this opperation as "fixing" an object,
10313 which means creating its associated fixed type.
10315 Example: when printing the value of variable "Yes" above, its fixed
10316 type would look like this:
10323 On the other hand, if we printed the value of "No", its fixed type
10330 Things become a little more complicated when trying to fix an entity
10331 with a dynamic type that directly contains another dynamic type,
10332 such as an array of variant records, for instance. There are
10333 two possible cases: Arrays, and records.
10335 3. ``Fixing'' Arrays:
10336 ---------------------
10338 The type structure in GDB describes an array in terms of its bounds,
10339 and the type of its elements. By design, all elements in the array
10340 have the same type and we cannot represent an array of variant elements
10341 using the current type structure in GDB. When fixing an array,
10342 we cannot fix the array element, as we would potentially need one
10343 fixed type per element of the array. As a result, the best we can do
10344 when fixing an array is to produce an array whose bounds and size
10345 are correct (allowing us to read it from memory), but without having
10346 touched its element type. Fixing each element will be done later,
10347 when (if) necessary.
10349 Arrays are a little simpler to handle than records, because the same
10350 amount of memory is allocated for each element of the array, even if
10351 the amount of space actually used by each element differs from element
10352 to element. Consider for instance the following array of type Rec:
10354 type Rec_Array is array (1 .. 2) of Rec;
10356 The actual amount of memory occupied by each element might be different
10357 from element to element, depending on the value of their discriminant.
10358 But the amount of space reserved for each element in the array remains
10359 fixed regardless. So we simply need to compute that size using
10360 the debugging information available, from which we can then determine
10361 the array size (we multiply the number of elements of the array by
10362 the size of each element).
10364 The simplest case is when we have an array of a constrained element
10365 type. For instance, consider the following type declarations:
10367 type Bounded_String (Max_Size : Integer) is
10369 Buffer : String (1 .. Max_Size);
10371 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10373 In this case, the compiler describes the array as an array of
10374 variable-size elements (identified by its XVS suffix) for which
10375 the size can be read in the parallel XVZ variable.
10377 In the case of an array of an unconstrained element type, the compiler
10378 wraps the array element inside a private PAD type. This type should not
10379 be shown to the user, and must be "unwrap"'ed before printing. Note
10380 that we also use the adjective "aligner" in our code to designate
10381 these wrapper types.
10383 In some cases, the size allocated for each element is statically
10384 known. In that case, the PAD type already has the correct size,
10385 and the array element should remain unfixed.
10387 But there are cases when this size is not statically known.
10388 For instance, assuming that "Five" is an integer variable:
10390 type Dynamic is array (1 .. Five) of Integer;
10391 type Wrapper (Has_Length : Boolean := False) is record
10394 when True => Length : Integer;
10395 when False => null;
10398 type Wrapper_Array is array (1 .. 2) of Wrapper;
10400 Hello : Wrapper_Array := (others => (Has_Length => True,
10401 Data => (others => 17),
10405 The debugging info would describe variable Hello as being an
10406 array of a PAD type. The size of that PAD type is not statically
10407 known, but can be determined using a parallel XVZ variable.
10408 In that case, a copy of the PAD type with the correct size should
10409 be used for the fixed array.
10411 3. ``Fixing'' record type objects:
10412 ----------------------------------
10414 Things are slightly different from arrays in the case of dynamic
10415 record types. In this case, in order to compute the associated
10416 fixed type, we need to determine the size and offset of each of
10417 its components. This, in turn, requires us to compute the fixed
10418 type of each of these components.
10420 Consider for instance the example:
10422 type Bounded_String (Max_Size : Natural) is record
10423 Str : String (1 .. Max_Size);
10426 My_String : Bounded_String (Max_Size => 10);
10428 In that case, the position of field "Length" depends on the size
10429 of field Str, which itself depends on the value of the Max_Size
10430 discriminant. In order to fix the type of variable My_String,
10431 we need to fix the type of field Str. Therefore, fixing a variant
10432 record requires us to fix each of its components.
10434 However, if a component does not have a dynamic size, the component
10435 should not be fixed. In particular, fields that use a PAD type
10436 should not fixed. Here is an example where this might happen
10437 (assuming type Rec above):
10439 type Container (Big : Boolean) is record
10443 when True => Another : Integer;
10444 when False => null;
10447 My_Container : Container := (Big => False,
10448 First => (Empty => True),
10451 In that example, the compiler creates a PAD type for component First,
10452 whose size is constant, and then positions the component After just
10453 right after it. The offset of component After is therefore constant
10456 The debugger computes the position of each field based on an algorithm
10457 that uses, among other things, the actual position and size of the field
10458 preceding it. Let's now imagine that the user is trying to print
10459 the value of My_Container. If the type fixing was recursive, we would
10460 end up computing the offset of field After based on the size of the
10461 fixed version of field First. And since in our example First has
10462 only one actual field, the size of the fixed type is actually smaller
10463 than the amount of space allocated to that field, and thus we would
10464 compute the wrong offset of field After.
10466 To make things more complicated, we need to watch out for dynamic
10467 components of variant records (identified by the ___XVL suffix in
10468 the component name). Even if the target type is a PAD type, the size
10469 of that type might not be statically known. So the PAD type needs
10470 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10471 we might end up with the wrong size for our component. This can be
10472 observed with the following type declarations:
10474 type Octal is new Integer range 0 .. 7;
10475 type Octal_Array is array (Positive range <>) of Octal;
10476 pragma Pack (Octal_Array);
10478 type Octal_Buffer (Size : Positive) is record
10479 Buffer : Octal_Array (1 .. Size);
10483 In that case, Buffer is a PAD type whose size is unset and needs
10484 to be computed by fixing the unwrapped type.
10486 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10487 ----------------------------------------------------------
10489 Lastly, when should the sub-elements of an entity that remained unfixed
10490 thus far, be actually fixed?
10492 The answer is: Only when referencing that element. For instance
10493 when selecting one component of a record, this specific component
10494 should be fixed at that point in time. Or when printing the value
10495 of a record, each component should be fixed before its value gets
10496 printed. Similarly for arrays, the element of the array should be
10497 fixed when printing each element of the array, or when extracting
10498 one element out of that array. On the other hand, fixing should
10499 not be performed on the elements when taking a slice of an array!
10501 Note that one of the side effects of miscomputing the offset and
10502 size of each field is that we end up also miscomputing the size
10503 of the containing type. This can have adverse results when computing
10504 the value of an entity. GDB fetches the value of an entity based
10505 on the size of its type, and thus a wrong size causes GDB to fetch
10506 the wrong amount of memory. In the case where the computed size is
10507 too small, GDB fetches too little data to print the value of our
10508 entity. Results in this case are unpredictable, as we usually read
10509 past the buffer containing the data =:-o. */
10511 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10512 for that subexpression cast to TO_TYPE. Advance *POS over the
10516 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
10517 enum noside noside
, struct type
*to_type
)
10521 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
10522 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
10527 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
10529 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10530 return value_zero (to_type
, not_lval
);
10532 val
= evaluate_var_msym_value (noside
,
10533 exp
->elts
[pc
+ 1].objfile
,
10534 exp
->elts
[pc
+ 2].msymbol
);
10537 val
= evaluate_var_value (noside
,
10538 exp
->elts
[pc
+ 1].block
,
10539 exp
->elts
[pc
+ 2].symbol
);
10541 if (noside
== EVAL_SKIP
)
10542 return eval_skip_value (exp
);
10544 val
= ada_value_cast (to_type
, val
);
10546 /* Follow the Ada language semantics that do not allow taking
10547 an address of the result of a cast (view conversion in Ada). */
10548 if (VALUE_LVAL (val
) == lval_memory
)
10550 if (value_lazy (val
))
10551 value_fetch_lazy (val
);
10552 VALUE_LVAL (val
) = not_lval
;
10557 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
10558 if (noside
== EVAL_SKIP
)
10559 return eval_skip_value (exp
);
10560 return ada_value_cast (to_type
, val
);
10563 /* Implement the evaluate_exp routine in the exp_descriptor structure
10564 for the Ada language. */
10566 static struct value
*
10567 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10568 int *pos
, enum noside noside
)
10570 enum exp_opcode op
;
10574 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10577 struct value
**argvec
;
10581 op
= exp
->elts
[pc
].opcode
;
10587 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10589 if (noside
== EVAL_NORMAL
)
10590 arg1
= unwrap_value (arg1
);
10592 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10593 then we need to perform the conversion manually, because
10594 evaluate_subexp_standard doesn't do it. This conversion is
10595 necessary in Ada because the different kinds of float/fixed
10596 types in Ada have different representations.
10598 Similarly, we need to perform the conversion from OP_LONG
10600 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10601 arg1
= ada_value_cast (expect_type
, arg1
);
10607 struct value
*result
;
10610 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10611 /* The result type will have code OP_STRING, bashed there from
10612 OP_ARRAY. Bash it back. */
10613 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
10614 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
10620 type
= exp
->elts
[pc
+ 1].type
;
10621 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10625 type
= exp
->elts
[pc
+ 1].type
;
10626 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10629 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10630 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10632 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10633 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10635 return ada_value_assign (arg1
, arg1
);
10637 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10638 except if the lhs of our assignment is a convenience variable.
10639 In the case of assigning to a convenience variable, the lhs
10640 should be exactly the result of the evaluation of the rhs. */
10641 type
= value_type (arg1
);
10642 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10644 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10645 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10647 if (ada_is_fixed_point_type (value_type (arg1
)))
10648 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
10649 else if (ada_is_fixed_point_type (value_type (arg2
)))
10651 (_("Fixed-point values must be assigned to fixed-point variables"));
10653 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10654 return ada_value_assign (arg1
, arg2
);
10657 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10658 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10659 if (noside
== EVAL_SKIP
)
10661 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
10662 return (value_from_longest
10663 (value_type (arg1
),
10664 value_as_long (arg1
) + value_as_long (arg2
)));
10665 if (TYPE_CODE (value_type (arg2
)) == TYPE_CODE_PTR
)
10666 return (value_from_longest
10667 (value_type (arg2
),
10668 value_as_long (arg1
) + value_as_long (arg2
)));
10669 if ((ada_is_fixed_point_type (value_type (arg1
))
10670 || ada_is_fixed_point_type (value_type (arg2
)))
10671 && value_type (arg1
) != value_type (arg2
))
10672 error (_("Operands of fixed-point addition must have the same type"));
10673 /* Do the addition, and cast the result to the type of the first
10674 argument. We cannot cast the result to a reference type, so if
10675 ARG1 is a reference type, find its underlying type. */
10676 type
= value_type (arg1
);
10677 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
10678 type
= TYPE_TARGET_TYPE (type
);
10679 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10680 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10683 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10684 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10685 if (noside
== EVAL_SKIP
)
10687 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
10688 return (value_from_longest
10689 (value_type (arg1
),
10690 value_as_long (arg1
) - value_as_long (arg2
)));
10691 if (TYPE_CODE (value_type (arg2
)) == TYPE_CODE_PTR
)
10692 return (value_from_longest
10693 (value_type (arg2
),
10694 value_as_long (arg1
) - value_as_long (arg2
)));
10695 if ((ada_is_fixed_point_type (value_type (arg1
))
10696 || ada_is_fixed_point_type (value_type (arg2
)))
10697 && value_type (arg1
) != value_type (arg2
))
10698 error (_("Operands of fixed-point subtraction "
10699 "must have the same type"));
10700 /* Do the substraction, and cast the result to the type of the first
10701 argument. We cannot cast the result to a reference type, so if
10702 ARG1 is a reference type, find its underlying type. */
10703 type
= value_type (arg1
);
10704 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
10705 type
= TYPE_TARGET_TYPE (type
);
10706 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10707 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10713 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10714 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10715 if (noside
== EVAL_SKIP
)
10717 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10719 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10720 return value_zero (value_type (arg1
), not_lval
);
10724 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10725 if (ada_is_fixed_point_type (value_type (arg1
)))
10726 arg1
= cast_from_fixed (type
, arg1
);
10727 if (ada_is_fixed_point_type (value_type (arg2
)))
10728 arg2
= cast_from_fixed (type
, arg2
);
10729 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10730 return ada_value_binop (arg1
, arg2
, op
);
10734 case BINOP_NOTEQUAL
:
10735 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10736 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10737 if (noside
== EVAL_SKIP
)
10739 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10743 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10744 tem
= ada_value_equal (arg1
, arg2
);
10746 if (op
== BINOP_NOTEQUAL
)
10748 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10749 return value_from_longest (type
, (LONGEST
) tem
);
10752 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10753 if (noside
== EVAL_SKIP
)
10755 else if (ada_is_fixed_point_type (value_type (arg1
)))
10756 return value_cast (value_type (arg1
), value_neg (arg1
));
10759 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10760 return value_neg (arg1
);
10763 case BINOP_LOGICAL_AND
:
10764 case BINOP_LOGICAL_OR
:
10765 case UNOP_LOGICAL_NOT
:
10770 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10771 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10772 return value_cast (type
, val
);
10775 case BINOP_BITWISE_AND
:
10776 case BINOP_BITWISE_IOR
:
10777 case BINOP_BITWISE_XOR
:
10781 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10783 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10785 return value_cast (value_type (arg1
), val
);
10791 if (noside
== EVAL_SKIP
)
10797 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10798 /* Only encountered when an unresolved symbol occurs in a
10799 context other than a function call, in which case, it is
10801 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10802 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
10804 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10806 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10807 /* Check to see if this is a tagged type. We also need to handle
10808 the case where the type is a reference to a tagged type, but
10809 we have to be careful to exclude pointers to tagged types.
10810 The latter should be shown as usual (as a pointer), whereas
10811 a reference should mostly be transparent to the user. */
10812 if (ada_is_tagged_type (type
, 0)
10813 || (TYPE_CODE (type
) == TYPE_CODE_REF
10814 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10816 /* Tagged types are a little special in the fact that the real
10817 type is dynamic and can only be determined by inspecting the
10818 object's tag. This means that we need to get the object's
10819 value first (EVAL_NORMAL) and then extract the actual object
10822 Note that we cannot skip the final step where we extract
10823 the object type from its tag, because the EVAL_NORMAL phase
10824 results in dynamic components being resolved into fixed ones.
10825 This can cause problems when trying to print the type
10826 description of tagged types whose parent has a dynamic size:
10827 We use the type name of the "_parent" component in order
10828 to print the name of the ancestor type in the type description.
10829 If that component had a dynamic size, the resolution into
10830 a fixed type would result in the loss of that type name,
10831 thus preventing us from printing the name of the ancestor
10832 type in the type description. */
10833 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
10835 if (TYPE_CODE (type
) != TYPE_CODE_REF
)
10837 struct type
*actual_type
;
10839 actual_type
= type_from_tag (ada_value_tag (arg1
));
10840 if (actual_type
== NULL
)
10841 /* If, for some reason, we were unable to determine
10842 the actual type from the tag, then use the static
10843 approximation that we just computed as a fallback.
10844 This can happen if the debugging information is
10845 incomplete, for instance. */
10846 actual_type
= type
;
10847 return value_zero (actual_type
, not_lval
);
10851 /* In the case of a ref, ada_coerce_ref takes care
10852 of determining the actual type. But the evaluation
10853 should return a ref as it should be valid to ask
10854 for its address; so rebuild a ref after coerce. */
10855 arg1
= ada_coerce_ref (arg1
);
10856 return value_ref (arg1
, TYPE_CODE_REF
);
10860 /* Records and unions for which GNAT encodings have been
10861 generated need to be statically fixed as well.
10862 Otherwise, non-static fixing produces a type where
10863 all dynamic properties are removed, which prevents "ptype"
10864 from being able to completely describe the type.
10865 For instance, a case statement in a variant record would be
10866 replaced by the relevant components based on the actual
10867 value of the discriminants. */
10868 if ((TYPE_CODE (type
) == TYPE_CODE_STRUCT
10869 && dynamic_template_type (type
) != NULL
)
10870 || (TYPE_CODE (type
) == TYPE_CODE_UNION
10871 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10874 return value_zero (to_static_fixed_type (type
), not_lval
);
10878 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10879 return ada_to_fixed_value (arg1
);
10884 /* Allocate arg vector, including space for the function to be
10885 called in argvec[0] and a terminating NULL. */
10886 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10887 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10889 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10890 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10891 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10892 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
10895 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10896 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10899 if (noside
== EVAL_SKIP
)
10903 if (ada_is_constrained_packed_array_type
10904 (desc_base_type (value_type (argvec
[0]))))
10905 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10906 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
10907 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10908 /* This is a packed array that has already been fixed, and
10909 therefore already coerced to a simple array. Nothing further
10912 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
)
10914 /* Make sure we dereference references so that all the code below
10915 feels like it's really handling the referenced value. Wrapping
10916 types (for alignment) may be there, so make sure we strip them as
10918 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10920 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
10921 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10922 argvec
[0] = value_addr (argvec
[0]);
10924 type
= ada_check_typedef (value_type (argvec
[0]));
10926 /* Ada allows us to implicitly dereference arrays when subscripting
10927 them. So, if this is an array typedef (encoding use for array
10928 access types encoded as fat pointers), strip it now. */
10929 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
10930 type
= ada_typedef_target_type (type
);
10932 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
10934 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
10936 case TYPE_CODE_FUNC
:
10937 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10939 case TYPE_CODE_ARRAY
:
10941 case TYPE_CODE_STRUCT
:
10942 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10943 argvec
[0] = ada_value_ind (argvec
[0]);
10944 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10947 error (_("cannot subscript or call something of type `%s'"),
10948 ada_type_name (value_type (argvec
[0])));
10953 switch (TYPE_CODE (type
))
10955 case TYPE_CODE_FUNC
:
10956 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10958 if (TYPE_TARGET_TYPE (type
) == NULL
)
10959 error_call_unknown_return_type (NULL
);
10960 return allocate_value (TYPE_TARGET_TYPE (type
));
10962 return call_function_by_hand (argvec
[0], NULL
,
10963 gdb::make_array_view (argvec
+ 1,
10965 case TYPE_CODE_INTERNAL_FUNCTION
:
10966 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10967 /* We don't know anything about what the internal
10968 function might return, but we have to return
10970 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10973 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10974 argvec
[0], nargs
, argvec
+ 1);
10976 case TYPE_CODE_STRUCT
:
10980 arity
= ada_array_arity (type
);
10981 type
= ada_array_element_type (type
, nargs
);
10983 error (_("cannot subscript or call a record"));
10984 if (arity
!= nargs
)
10985 error (_("wrong number of subscripts; expecting %d"), arity
);
10986 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10987 return value_zero (ada_aligned_type (type
), lval_memory
);
10989 unwrap_value (ada_value_subscript
10990 (argvec
[0], nargs
, argvec
+ 1));
10992 case TYPE_CODE_ARRAY
:
10993 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10995 type
= ada_array_element_type (type
, nargs
);
10997 error (_("element type of array unknown"));
10999 return value_zero (ada_aligned_type (type
), lval_memory
);
11002 unwrap_value (ada_value_subscript
11003 (ada_coerce_to_simple_array (argvec
[0]),
11004 nargs
, argvec
+ 1));
11005 case TYPE_CODE_PTR
: /* Pointer to array */
11006 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11008 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
11009 type
= ada_array_element_type (type
, nargs
);
11011 error (_("element type of array unknown"));
11013 return value_zero (ada_aligned_type (type
), lval_memory
);
11016 unwrap_value (ada_value_ptr_subscript (argvec
[0],
11017 nargs
, argvec
+ 1));
11020 error (_("Attempt to index or call something other than an "
11021 "array or function"));
11026 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11027 struct value
*low_bound_val
=
11028 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11029 struct value
*high_bound_val
=
11030 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11032 LONGEST high_bound
;
11034 low_bound_val
= coerce_ref (low_bound_val
);
11035 high_bound_val
= coerce_ref (high_bound_val
);
11036 low_bound
= value_as_long (low_bound_val
);
11037 high_bound
= value_as_long (high_bound_val
);
11039 if (noside
== EVAL_SKIP
)
11042 /* If this is a reference to an aligner type, then remove all
11044 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
11045 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
11046 TYPE_TARGET_TYPE (value_type (array
)) =
11047 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
11049 if (ada_is_constrained_packed_array_type (value_type (array
)))
11050 error (_("cannot slice a packed array"));
11052 /* If this is a reference to an array or an array lvalue,
11053 convert to a pointer. */
11054 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
11055 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
11056 && VALUE_LVAL (array
) == lval_memory
))
11057 array
= value_addr (array
);
11059 if (noside
== EVAL_AVOID_SIDE_EFFECTS
11060 && ada_is_array_descriptor_type (ada_check_typedef
11061 (value_type (array
))))
11062 return empty_array (ada_type_of_array (array
, 0), low_bound
,
11065 array
= ada_coerce_to_simple_array_ptr (array
);
11067 /* If we have more than one level of pointer indirection,
11068 dereference the value until we get only one level. */
11069 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
11070 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
11072 array
= value_ind (array
);
11074 /* Make sure we really do have an array type before going further,
11075 to avoid a SEGV when trying to get the index type or the target
11076 type later down the road if the debug info generated by
11077 the compiler is incorrect or incomplete. */
11078 if (!ada_is_simple_array_type (value_type (array
)))
11079 error (_("cannot take slice of non-array"));
11081 if (TYPE_CODE (ada_check_typedef (value_type (array
)))
11084 struct type
*type0
= ada_check_typedef (value_type (array
));
11086 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
11087 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
11090 struct type
*arr_type0
=
11091 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
11093 return ada_value_slice_from_ptr (array
, arr_type0
,
11094 longest_to_int (low_bound
),
11095 longest_to_int (high_bound
));
11098 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11100 else if (high_bound
< low_bound
)
11101 return empty_array (value_type (array
), low_bound
, high_bound
);
11103 return ada_value_slice (array
, longest_to_int (low_bound
),
11104 longest_to_int (high_bound
));
11107 case UNOP_IN_RANGE
:
11109 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11110 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
11112 if (noside
== EVAL_SKIP
)
11115 switch (TYPE_CODE (type
))
11118 lim_warning (_("Membership test incompletely implemented; "
11119 "always returns true"));
11120 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
11121 return value_from_longest (type
, (LONGEST
) 1);
11123 case TYPE_CODE_RANGE
:
11124 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
11125 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
11126 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11127 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
11128 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
11130 value_from_longest (type
,
11131 (value_less (arg1
, arg3
)
11132 || value_equal (arg1
, arg3
))
11133 && (value_less (arg2
, arg1
)
11134 || value_equal (arg2
, arg1
)));
11137 case BINOP_IN_BOUNDS
:
11139 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11140 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11142 if (noside
== EVAL_SKIP
)
11145 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11147 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
11148 return value_zero (type
, not_lval
);
11151 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11153 type
= ada_index_type (value_type (arg2
), tem
, "range");
11155 type
= value_type (arg1
);
11157 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
11158 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
11160 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11161 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
11162 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
11164 value_from_longest (type
,
11165 (value_less (arg1
, arg3
)
11166 || value_equal (arg1
, arg3
))
11167 && (value_less (arg2
, arg1
)
11168 || value_equal (arg2
, arg1
)));
11170 case TERNOP_IN_RANGE
:
11171 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11172 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11173 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11175 if (noside
== EVAL_SKIP
)
11178 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11179 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
11180 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
11182 value_from_longest (type
,
11183 (value_less (arg1
, arg3
)
11184 || value_equal (arg1
, arg3
))
11185 && (value_less (arg2
, arg1
)
11186 || value_equal (arg2
, arg1
)));
11190 case OP_ATR_LENGTH
:
11192 struct type
*type_arg
;
11194 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
11196 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11198 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
11202 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11206 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
11207 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
11208 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
11211 if (noside
== EVAL_SKIP
)
11214 if (type_arg
== NULL
)
11216 arg1
= ada_coerce_ref (arg1
);
11218 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
11219 arg1
= ada_coerce_to_simple_array (arg1
);
11221 if (op
== OP_ATR_LENGTH
)
11222 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11225 type
= ada_index_type (value_type (arg1
), tem
,
11226 ada_attribute_name (op
));
11228 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11231 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11232 return allocate_value (type
);
11236 default: /* Should never happen. */
11237 error (_("unexpected attribute encountered"));
11239 return value_from_longest
11240 (type
, ada_array_bound (arg1
, tem
, 0));
11242 return value_from_longest
11243 (type
, ada_array_bound (arg1
, tem
, 1));
11244 case OP_ATR_LENGTH
:
11245 return value_from_longest
11246 (type
, ada_array_length (arg1
, tem
));
11249 else if (discrete_type_p (type_arg
))
11251 struct type
*range_type
;
11252 const char *name
= ada_type_name (type_arg
);
11255 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
11256 range_type
= to_fixed_range_type (type_arg
, NULL
);
11257 if (range_type
== NULL
)
11258 range_type
= type_arg
;
11262 error (_("unexpected attribute encountered"));
11264 return value_from_longest
11265 (range_type
, ada_discrete_type_low_bound (range_type
));
11267 return value_from_longest
11268 (range_type
, ada_discrete_type_high_bound (range_type
));
11269 case OP_ATR_LENGTH
:
11270 error (_("the 'length attribute applies only to array types"));
11273 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
11274 error (_("unimplemented type attribute"));
11279 if (ada_is_constrained_packed_array_type (type_arg
))
11280 type_arg
= decode_constrained_packed_array_type (type_arg
);
11282 if (op
== OP_ATR_LENGTH
)
11283 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11286 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
11288 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11291 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11292 return allocate_value (type
);
11297 error (_("unexpected attribute encountered"));
11299 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
11300 return value_from_longest (type
, low
);
11302 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
11303 return value_from_longest (type
, high
);
11304 case OP_ATR_LENGTH
:
11305 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
11306 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
11307 return value_from_longest (type
, high
- low
+ 1);
11313 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11314 if (noside
== EVAL_SKIP
)
11317 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11318 return value_zero (ada_tag_type (arg1
), not_lval
);
11320 return ada_value_tag (arg1
);
11324 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11325 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11326 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11327 if (noside
== EVAL_SKIP
)
11329 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11330 return value_zero (value_type (arg1
), not_lval
);
11333 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11334 return value_binop (arg1
, arg2
,
11335 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
11338 case OP_ATR_MODULUS
:
11340 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
11342 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11343 if (noside
== EVAL_SKIP
)
11346 if (!ada_is_modular_type (type_arg
))
11347 error (_("'modulus must be applied to modular type"));
11349 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
11350 ada_modulus (type_arg
));
11355 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11356 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11357 if (noside
== EVAL_SKIP
)
11359 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11360 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11361 return value_zero (type
, not_lval
);
11363 return value_pos_atr (type
, arg1
);
11366 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11367 type
= value_type (arg1
);
11369 /* If the argument is a reference, then dereference its type, since
11370 the user is really asking for the size of the actual object,
11371 not the size of the pointer. */
11372 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
11373 type
= TYPE_TARGET_TYPE (type
);
11375 if (noside
== EVAL_SKIP
)
11377 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11378 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
11380 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
11381 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
11384 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11385 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11386 type
= exp
->elts
[pc
+ 2].type
;
11387 if (noside
== EVAL_SKIP
)
11389 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11390 return value_zero (type
, not_lval
);
11392 return value_val_atr (type
, arg1
);
11395 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11396 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11397 if (noside
== EVAL_SKIP
)
11399 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11400 return value_zero (value_type (arg1
), not_lval
);
11403 /* For integer exponentiation operations,
11404 only promote the first argument. */
11405 if (is_integral_type (value_type (arg2
)))
11406 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11408 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11410 return value_binop (arg1
, arg2
, op
);
11414 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11415 if (noside
== EVAL_SKIP
)
11421 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11422 if (noside
== EVAL_SKIP
)
11424 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11425 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
11426 return value_neg (arg1
);
11431 preeval_pos
= *pos
;
11432 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11433 if (noside
== EVAL_SKIP
)
11435 type
= ada_check_typedef (value_type (arg1
));
11436 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11438 if (ada_is_array_descriptor_type (type
))
11439 /* GDB allows dereferencing GNAT array descriptors. */
11441 struct type
*arrType
= ada_type_of_array (arg1
, 0);
11443 if (arrType
== NULL
)
11444 error (_("Attempt to dereference null array pointer."));
11445 return value_at_lazy (arrType
, 0);
11447 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
11448 || TYPE_CODE (type
) == TYPE_CODE_REF
11449 /* In C you can dereference an array to get the 1st elt. */
11450 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
11452 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11453 only be determined by inspecting the object's tag.
11454 This means that we need to evaluate completely the
11455 expression in order to get its type. */
11457 if ((TYPE_CODE (type
) == TYPE_CODE_REF
11458 || TYPE_CODE (type
) == TYPE_CODE_PTR
)
11459 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
11461 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11463 type
= value_type (ada_value_ind (arg1
));
11467 type
= to_static_fixed_type
11469 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
11471 ada_ensure_varsize_limit (type
);
11472 return value_zero (type
, lval_memory
);
11474 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
11476 /* GDB allows dereferencing an int. */
11477 if (expect_type
== NULL
)
11478 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11483 to_static_fixed_type (ada_aligned_type (expect_type
));
11484 return value_zero (expect_type
, lval_memory
);
11488 error (_("Attempt to take contents of a non-pointer value."));
11490 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11491 type
= ada_check_typedef (value_type (arg1
));
11493 if (TYPE_CODE (type
) == TYPE_CODE_INT
)
11494 /* GDB allows dereferencing an int. If we were given
11495 the expect_type, then use that as the target type.
11496 Otherwise, assume that the target type is an int. */
11498 if (expect_type
!= NULL
)
11499 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11502 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11503 (CORE_ADDR
) value_as_address (arg1
));
11506 if (ada_is_array_descriptor_type (type
))
11507 /* GDB allows dereferencing GNAT array descriptors. */
11508 return ada_coerce_to_simple_array (arg1
);
11510 return ada_value_ind (arg1
);
11512 case STRUCTOP_STRUCT
:
11513 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11514 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11515 preeval_pos
= *pos
;
11516 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11517 if (noside
== EVAL_SKIP
)
11519 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11521 struct type
*type1
= value_type (arg1
);
11523 if (ada_is_tagged_type (type1
, 1))
11525 type
= ada_lookup_struct_elt_type (type1
,
11526 &exp
->elts
[pc
+ 2].string
,
11529 /* If the field is not found, check if it exists in the
11530 extension of this object's type. This means that we
11531 need to evaluate completely the expression. */
11535 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11537 arg1
= ada_value_struct_elt (arg1
,
11538 &exp
->elts
[pc
+ 2].string
,
11540 arg1
= unwrap_value (arg1
);
11541 type
= value_type (ada_to_fixed_value (arg1
));
11546 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11549 return value_zero (ada_aligned_type (type
), lval_memory
);
11553 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11554 arg1
= unwrap_value (arg1
);
11555 return ada_to_fixed_value (arg1
);
11559 /* The value is not supposed to be used. This is here to make it
11560 easier to accommodate expressions that contain types. */
11562 if (noside
== EVAL_SKIP
)
11564 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11565 return allocate_value (exp
->elts
[pc
+ 1].type
);
11567 error (_("Attempt to use a type name as an expression"));
11572 case OP_DISCRETE_RANGE
:
11573 case OP_POSITIONAL
:
11575 if (noside
== EVAL_NORMAL
)
11579 error (_("Undefined name, ambiguous name, or renaming used in "
11580 "component association: %s."), &exp
->elts
[pc
+2].string
);
11582 error (_("Aggregates only allowed on the right of an assignment"));
11584 internal_error (__FILE__
, __LINE__
,
11585 _("aggregate apparently mangled"));
11588 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11590 for (tem
= 0; tem
< nargs
; tem
+= 1)
11591 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11596 return eval_skip_value (exp
);
11602 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11603 type name that encodes the 'small and 'delta information.
11604 Otherwise, return NULL. */
11606 static const char *
11607 fixed_type_info (struct type
*type
)
11609 const char *name
= ada_type_name (type
);
11610 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
11612 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11614 const char *tail
= strstr (name
, "___XF_");
11621 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11622 return fixed_type_info (TYPE_TARGET_TYPE (type
));
11627 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11630 ada_is_fixed_point_type (struct type
*type
)
11632 return fixed_type_info (type
) != NULL
;
11635 /* Return non-zero iff TYPE represents a System.Address type. */
11638 ada_is_system_address_type (struct type
*type
)
11640 return (TYPE_NAME (type
)
11641 && strcmp (TYPE_NAME (type
), "system__address") == 0);
11644 /* Assuming that TYPE is the representation of an Ada fixed-point
11645 type, return the target floating-point type to be used to represent
11646 of this type during internal computation. */
11648 static struct type
*
11649 ada_scaling_type (struct type
*type
)
11651 return builtin_type (get_type_arch (type
))->builtin_long_double
;
11654 /* Assuming that TYPE is the representation of an Ada fixed-point
11655 type, return its delta, or NULL if the type is malformed and the
11656 delta cannot be determined. */
11659 ada_delta (struct type
*type
)
11661 const char *encoding
= fixed_type_info (type
);
11662 struct type
*scale_type
= ada_scaling_type (type
);
11664 long long num
, den
;
11666 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11669 return value_binop (value_from_longest (scale_type
, num
),
11670 value_from_longest (scale_type
, den
), BINOP_DIV
);
11673 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11674 factor ('SMALL value) associated with the type. */
11677 ada_scaling_factor (struct type
*type
)
11679 const char *encoding
= fixed_type_info (type
);
11680 struct type
*scale_type
= ada_scaling_type (type
);
11682 long long num0
, den0
, num1
, den1
;
11685 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11686 &num0
, &den0
, &num1
, &den1
);
11689 return value_from_longest (scale_type
, 1);
11691 return value_binop (value_from_longest (scale_type
, num1
),
11692 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11694 return value_binop (value_from_longest (scale_type
, num0
),
11695 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11702 /* Scan STR beginning at position K for a discriminant name, and
11703 return the value of that discriminant field of DVAL in *PX. If
11704 PNEW_K is not null, put the position of the character beyond the
11705 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11706 not alter *PX and *PNEW_K if unsuccessful. */
11709 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11712 static char *bound_buffer
= NULL
;
11713 static size_t bound_buffer_len
= 0;
11714 const char *pstart
, *pend
, *bound
;
11715 struct value
*bound_val
;
11717 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11721 pend
= strstr (pstart
, "__");
11725 k
+= strlen (bound
);
11729 int len
= pend
- pstart
;
11731 /* Strip __ and beyond. */
11732 GROW_VECT (bound_buffer
, bound_buffer_len
, len
+ 1);
11733 strncpy (bound_buffer
, pstart
, len
);
11734 bound_buffer
[len
] = '\0';
11736 bound
= bound_buffer
;
11740 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11741 if (bound_val
== NULL
)
11744 *px
= value_as_long (bound_val
);
11745 if (pnew_k
!= NULL
)
11750 /* Value of variable named NAME in the current environment. If
11751 no such variable found, then if ERR_MSG is null, returns 0, and
11752 otherwise causes an error with message ERR_MSG. */
11754 static struct value
*
11755 get_var_value (const char *name
, const char *err_msg
)
11757 lookup_name_info
lookup_name (name
, symbol_name_match_type::FULL
);
11759 std::vector
<struct block_symbol
> syms
;
11760 int nsyms
= ada_lookup_symbol_list_worker (lookup_name
,
11761 get_selected_block (0),
11762 VAR_DOMAIN
, &syms
, 1);
11766 if (err_msg
== NULL
)
11769 error (("%s"), err_msg
);
11772 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11775 /* Value of integer variable named NAME in the current environment.
11776 If no such variable is found, returns false. Otherwise, sets VALUE
11777 to the variable's value and returns true. */
11780 get_int_var_value (const char *name
, LONGEST
&value
)
11782 struct value
*var_val
= get_var_value (name
, 0);
11787 value
= value_as_long (var_val
);
11792 /* Return a range type whose base type is that of the range type named
11793 NAME in the current environment, and whose bounds are calculated
11794 from NAME according to the GNAT range encoding conventions.
11795 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11796 corresponding range type from debug information; fall back to using it
11797 if symbol lookup fails. If a new type must be created, allocate it
11798 like ORIG_TYPE was. The bounds information, in general, is encoded
11799 in NAME, the base type given in the named range type. */
11801 static struct type
*
11802 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11805 struct type
*base_type
;
11806 const char *subtype_info
;
11808 gdb_assert (raw_type
!= NULL
);
11809 gdb_assert (TYPE_NAME (raw_type
) != NULL
);
11811 if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
11812 base_type
= TYPE_TARGET_TYPE (raw_type
);
11814 base_type
= raw_type
;
11816 name
= TYPE_NAME (raw_type
);
11817 subtype_info
= strstr (name
, "___XD");
11818 if (subtype_info
== NULL
)
11820 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11821 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11823 if (L
< INT_MIN
|| U
> INT_MAX
)
11826 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11831 static char *name_buf
= NULL
;
11832 static size_t name_len
= 0;
11833 int prefix_len
= subtype_info
- name
;
11836 const char *bounds_str
;
11839 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11840 strncpy (name_buf
, name
, prefix_len
);
11841 name_buf
[prefix_len
] = '\0';
11844 bounds_str
= strchr (subtype_info
, '_');
11847 if (*subtype_info
== 'L')
11849 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11850 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11852 if (bounds_str
[n
] == '_')
11854 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11860 strcpy (name_buf
+ prefix_len
, "___L");
11861 if (!get_int_var_value (name_buf
, L
))
11863 lim_warning (_("Unknown lower bound, using 1."));
11868 if (*subtype_info
== 'U')
11870 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11871 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11876 strcpy (name_buf
+ prefix_len
, "___U");
11877 if (!get_int_var_value (name_buf
, U
))
11879 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11884 type
= create_static_range_type (alloc_type_copy (raw_type
),
11886 /* create_static_range_type alters the resulting type's length
11887 to match the size of the base_type, which is not what we want.
11888 Set it back to the original range type's length. */
11889 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11890 TYPE_NAME (type
) = name
;
11895 /* True iff NAME is the name of a range type. */
11898 ada_is_range_type_name (const char *name
)
11900 return (name
!= NULL
&& strstr (name
, "___XD"));
11904 /* Modular types */
11906 /* True iff TYPE is an Ada modular type. */
11909 ada_is_modular_type (struct type
*type
)
11911 struct type
*subranged_type
= get_base_type (type
);
11913 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
11914 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
11915 && TYPE_UNSIGNED (subranged_type
));
11918 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11921 ada_modulus (struct type
*type
)
11923 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
11927 /* Ada exception catchpoint support:
11928 ---------------------------------
11930 We support 3 kinds of exception catchpoints:
11931 . catchpoints on Ada exceptions
11932 . catchpoints on unhandled Ada exceptions
11933 . catchpoints on failed assertions
11935 Exceptions raised during failed assertions, or unhandled exceptions
11936 could perfectly be caught with the general catchpoint on Ada exceptions.
11937 However, we can easily differentiate these two special cases, and having
11938 the option to distinguish these two cases from the rest can be useful
11939 to zero-in on certain situations.
11941 Exception catchpoints are a specialized form of breakpoint,
11942 since they rely on inserting breakpoints inside known routines
11943 of the GNAT runtime. The implementation therefore uses a standard
11944 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11947 Support in the runtime for exception catchpoints have been changed
11948 a few times already, and these changes affect the implementation
11949 of these catchpoints. In order to be able to support several
11950 variants of the runtime, we use a sniffer that will determine
11951 the runtime variant used by the program being debugged. */
11953 /* Ada's standard exceptions.
11955 The Ada 83 standard also defined Numeric_Error. But there so many
11956 situations where it was unclear from the Ada 83 Reference Manual
11957 (RM) whether Constraint_Error or Numeric_Error should be raised,
11958 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11959 Interpretation saying that anytime the RM says that Numeric_Error
11960 should be raised, the implementation may raise Constraint_Error.
11961 Ada 95 went one step further and pretty much removed Numeric_Error
11962 from the list of standard exceptions (it made it a renaming of
11963 Constraint_Error, to help preserve compatibility when compiling
11964 an Ada83 compiler). As such, we do not include Numeric_Error from
11965 this list of standard exceptions. */
11967 static const char *standard_exc
[] = {
11968 "constraint_error",
11974 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11976 /* A structure that describes how to support exception catchpoints
11977 for a given executable. */
11979 struct exception_support_info
11981 /* The name of the symbol to break on in order to insert
11982 a catchpoint on exceptions. */
11983 const char *catch_exception_sym
;
11985 /* The name of the symbol to break on in order to insert
11986 a catchpoint on unhandled exceptions. */
11987 const char *catch_exception_unhandled_sym
;
11989 /* The name of the symbol to break on in order to insert
11990 a catchpoint on failed assertions. */
11991 const char *catch_assert_sym
;
11993 /* The name of the symbol to break on in order to insert
11994 a catchpoint on exception handling. */
11995 const char *catch_handlers_sym
;
11997 /* Assuming that the inferior just triggered an unhandled exception
11998 catchpoint, this function is responsible for returning the address
11999 in inferior memory where the name of that exception is stored.
12000 Return zero if the address could not be computed. */
12001 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
12004 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
12005 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
12007 /* The following exception support info structure describes how to
12008 implement exception catchpoints with the latest version of the
12009 Ada runtime (as of 2007-03-06). */
12011 static const struct exception_support_info default_exception_support_info
=
12013 "__gnat_debug_raise_exception", /* catch_exception_sym */
12014 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12015 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
12016 "__gnat_begin_handler", /* catch_handlers_sym */
12017 ada_unhandled_exception_name_addr
12020 /* The following exception support info structure describes how to
12021 implement exception catchpoints with a slightly older version
12022 of the Ada runtime. */
12024 static const struct exception_support_info exception_support_info_fallback
=
12026 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
12027 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12028 "system__assertions__raise_assert_failure", /* catch_assert_sym */
12029 "__gnat_begin_handler", /* catch_handlers_sym */
12030 ada_unhandled_exception_name_addr_from_raise
12033 /* Return nonzero if we can detect the exception support routines
12034 described in EINFO.
12036 This function errors out if an abnormal situation is detected
12037 (for instance, if we find the exception support routines, but
12038 that support is found to be incomplete). */
12041 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
12043 struct symbol
*sym
;
12045 /* The symbol we're looking up is provided by a unit in the GNAT runtime
12046 that should be compiled with debugging information. As a result, we
12047 expect to find that symbol in the symtabs. */
12049 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
12052 /* Perhaps we did not find our symbol because the Ada runtime was
12053 compiled without debugging info, or simply stripped of it.
12054 It happens on some GNU/Linux distributions for instance, where
12055 users have to install a separate debug package in order to get
12056 the runtime's debugging info. In that situation, let the user
12057 know why we cannot insert an Ada exception catchpoint.
12059 Note: Just for the purpose of inserting our Ada exception
12060 catchpoint, we could rely purely on the associated minimal symbol.
12061 But we would be operating in degraded mode anyway, since we are
12062 still lacking the debugging info needed later on to extract
12063 the name of the exception being raised (this name is printed in
12064 the catchpoint message, and is also used when trying to catch
12065 a specific exception). We do not handle this case for now. */
12066 struct bound_minimal_symbol msym
12067 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
12069 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
12070 error (_("Your Ada runtime appears to be missing some debugging "
12071 "information.\nCannot insert Ada exception catchpoint "
12072 "in this configuration."));
12077 /* Make sure that the symbol we found corresponds to a function. */
12079 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12080 error (_("Symbol \"%s\" is not a function (class = %d)"),
12081 SYMBOL_LINKAGE_NAME (sym
), SYMBOL_CLASS (sym
));
12086 /* Inspect the Ada runtime and determine which exception info structure
12087 should be used to provide support for exception catchpoints.
12089 This function will always set the per-inferior exception_info,
12090 or raise an error. */
12093 ada_exception_support_info_sniffer (void)
12095 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12097 /* If the exception info is already known, then no need to recompute it. */
12098 if (data
->exception_info
!= NULL
)
12101 /* Check the latest (default) exception support info. */
12102 if (ada_has_this_exception_support (&default_exception_support_info
))
12104 data
->exception_info
= &default_exception_support_info
;
12108 /* Try our fallback exception suport info. */
12109 if (ada_has_this_exception_support (&exception_support_info_fallback
))
12111 data
->exception_info
= &exception_support_info_fallback
;
12115 /* Sometimes, it is normal for us to not be able to find the routine
12116 we are looking for. This happens when the program is linked with
12117 the shared version of the GNAT runtime, and the program has not been
12118 started yet. Inform the user of these two possible causes if
12121 if (ada_update_initial_language (language_unknown
) != language_ada
)
12122 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
12124 /* If the symbol does not exist, then check that the program is
12125 already started, to make sure that shared libraries have been
12126 loaded. If it is not started, this may mean that the symbol is
12127 in a shared library. */
12129 if (inferior_ptid
.pid () == 0)
12130 error (_("Unable to insert catchpoint. Try to start the program first."));
12132 /* At this point, we know that we are debugging an Ada program and
12133 that the inferior has been started, but we still are not able to
12134 find the run-time symbols. That can mean that we are in
12135 configurable run time mode, or that a-except as been optimized
12136 out by the linker... In any case, at this point it is not worth
12137 supporting this feature. */
12139 error (_("Cannot insert Ada exception catchpoints in this configuration."));
12142 /* True iff FRAME is very likely to be that of a function that is
12143 part of the runtime system. This is all very heuristic, but is
12144 intended to be used as advice as to what frames are uninteresting
12148 is_known_support_routine (struct frame_info
*frame
)
12150 enum language func_lang
;
12152 const char *fullname
;
12154 /* If this code does not have any debugging information (no symtab),
12155 This cannot be any user code. */
12157 symtab_and_line sal
= find_frame_sal (frame
);
12158 if (sal
.symtab
== NULL
)
12161 /* If there is a symtab, but the associated source file cannot be
12162 located, then assume this is not user code: Selecting a frame
12163 for which we cannot display the code would not be very helpful
12164 for the user. This should also take care of case such as VxWorks
12165 where the kernel has some debugging info provided for a few units. */
12167 fullname
= symtab_to_fullname (sal
.symtab
);
12168 if (access (fullname
, R_OK
) != 0)
12171 /* Check the unit filename againt the Ada runtime file naming.
12172 We also check the name of the objfile against the name of some
12173 known system libraries that sometimes come with debugging info
12176 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
12178 re_comp (known_runtime_file_name_patterns
[i
]);
12179 if (re_exec (lbasename (sal
.symtab
->filename
)))
12181 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
12182 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
12186 /* Check whether the function is a GNAT-generated entity. */
12188 gdb::unique_xmalloc_ptr
<char> func_name
12189 = find_frame_funname (frame
, &func_lang
, NULL
);
12190 if (func_name
== NULL
)
12193 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
12195 re_comp (known_auxiliary_function_name_patterns
[i
]);
12196 if (re_exec (func_name
.get ()))
12203 /* Find the first frame that contains debugging information and that is not
12204 part of the Ada run-time, starting from FI and moving upward. */
12207 ada_find_printable_frame (struct frame_info
*fi
)
12209 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
12211 if (!is_known_support_routine (fi
))
12220 /* Assuming that the inferior just triggered an unhandled exception
12221 catchpoint, return the address in inferior memory where the name
12222 of the exception is stored.
12224 Return zero if the address could not be computed. */
12227 ada_unhandled_exception_name_addr (void)
12229 return parse_and_eval_address ("e.full_name");
12232 /* Same as ada_unhandled_exception_name_addr, except that this function
12233 should be used when the inferior uses an older version of the runtime,
12234 where the exception name needs to be extracted from a specific frame
12235 several frames up in the callstack. */
12238 ada_unhandled_exception_name_addr_from_raise (void)
12241 struct frame_info
*fi
;
12242 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12244 /* To determine the name of this exception, we need to select
12245 the frame corresponding to RAISE_SYM_NAME. This frame is
12246 at least 3 levels up, so we simply skip the first 3 frames
12247 without checking the name of their associated function. */
12248 fi
= get_current_frame ();
12249 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
12251 fi
= get_prev_frame (fi
);
12255 enum language func_lang
;
12257 gdb::unique_xmalloc_ptr
<char> func_name
12258 = find_frame_funname (fi
, &func_lang
, NULL
);
12259 if (func_name
!= NULL
)
12261 if (strcmp (func_name
.get (),
12262 data
->exception_info
->catch_exception_sym
) == 0)
12263 break; /* We found the frame we were looking for... */
12265 fi
= get_prev_frame (fi
);
12272 return parse_and_eval_address ("id.full_name");
12275 /* Assuming the inferior just triggered an Ada exception catchpoint
12276 (of any type), return the address in inferior memory where the name
12277 of the exception is stored, if applicable.
12279 Assumes the selected frame is the current frame.
12281 Return zero if the address could not be computed, or if not relevant. */
12284 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
12285 struct breakpoint
*b
)
12287 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12291 case ada_catch_exception
:
12292 return (parse_and_eval_address ("e.full_name"));
12295 case ada_catch_exception_unhandled
:
12296 return data
->exception_info
->unhandled_exception_name_addr ();
12299 case ada_catch_handlers
:
12300 return 0; /* The runtimes does not provide access to the exception
12304 case ada_catch_assert
:
12305 return 0; /* Exception name is not relevant in this case. */
12309 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12313 return 0; /* Should never be reached. */
12316 /* Assuming the inferior is stopped at an exception catchpoint,
12317 return the message which was associated to the exception, if
12318 available. Return NULL if the message could not be retrieved.
12320 Note: The exception message can be associated to an exception
12321 either through the use of the Raise_Exception function, or
12322 more simply (Ada 2005 and later), via:
12324 raise Exception_Name with "exception message";
12328 static gdb::unique_xmalloc_ptr
<char>
12329 ada_exception_message_1 (void)
12331 struct value
*e_msg_val
;
12334 /* For runtimes that support this feature, the exception message
12335 is passed as an unbounded string argument called "message". */
12336 e_msg_val
= parse_and_eval ("message");
12337 if (e_msg_val
== NULL
)
12338 return NULL
; /* Exception message not supported. */
12340 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
12341 gdb_assert (e_msg_val
!= NULL
);
12342 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
12344 /* If the message string is empty, then treat it as if there was
12345 no exception message. */
12346 if (e_msg_len
<= 0)
12349 gdb::unique_xmalloc_ptr
<char> e_msg ((char *) xmalloc (e_msg_len
+ 1));
12350 read_memory_string (value_address (e_msg_val
), e_msg
.get (), e_msg_len
+ 1);
12351 e_msg
.get ()[e_msg_len
] = '\0';
12356 /* Same as ada_exception_message_1, except that all exceptions are
12357 contained here (returning NULL instead). */
12359 static gdb::unique_xmalloc_ptr
<char>
12360 ada_exception_message (void)
12362 gdb::unique_xmalloc_ptr
<char> e_msg
;
12366 e_msg
= ada_exception_message_1 ();
12368 catch (const gdb_exception_error
&e
)
12370 e_msg
.reset (nullptr);
12376 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12377 any error that ada_exception_name_addr_1 might cause to be thrown.
12378 When an error is intercepted, a warning with the error message is printed,
12379 and zero is returned. */
12382 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
12383 struct breakpoint
*b
)
12385 CORE_ADDR result
= 0;
12389 result
= ada_exception_name_addr_1 (ex
, b
);
12392 catch (const gdb_exception_error
&e
)
12394 warning (_("failed to get exception name: %s"), e
.what ());
12401 static std::string ada_exception_catchpoint_cond_string
12402 (const char *excep_string
,
12403 enum ada_exception_catchpoint_kind ex
);
12405 /* Ada catchpoints.
12407 In the case of catchpoints on Ada exceptions, the catchpoint will
12408 stop the target on every exception the program throws. When a user
12409 specifies the name of a specific exception, we translate this
12410 request into a condition expression (in text form), and then parse
12411 it into an expression stored in each of the catchpoint's locations.
12412 We then use this condition to check whether the exception that was
12413 raised is the one the user is interested in. If not, then the
12414 target is resumed again. We store the name of the requested
12415 exception, in order to be able to re-set the condition expression
12416 when symbols change. */
12418 /* An instance of this type is used to represent an Ada catchpoint
12419 breakpoint location. */
12421 class ada_catchpoint_location
: public bp_location
12424 ada_catchpoint_location (breakpoint
*owner
)
12425 : bp_location (owner
)
12428 /* The condition that checks whether the exception that was raised
12429 is the specific exception the user specified on catchpoint
12431 expression_up excep_cond_expr
;
12434 /* An instance of this type is used to represent an Ada catchpoint. */
12436 struct ada_catchpoint
: public breakpoint
12438 /* The name of the specific exception the user specified. */
12439 std::string excep_string
;
12442 /* Parse the exception condition string in the context of each of the
12443 catchpoint's locations, and store them for later evaluation. */
12446 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12447 enum ada_exception_catchpoint_kind ex
)
12449 /* Nothing to do if there's no specific exception to catch. */
12450 if (c
->excep_string
.empty ())
12453 /* Same if there are no locations... */
12454 if (c
->loc
== NULL
)
12457 /* We have to compute the expression once for each program space,
12458 because the expression may hold the addresses of multiple symbols
12460 std::multimap
<program_space
*, struct bp_location
*> loc_map
;
12461 for (bp_location
*bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
12462 loc_map
.emplace (bl
->pspace
, bl
);
12464 scoped_restore_current_program_space save_pspace
;
12466 std::string cond_string
;
12467 program_space
*last_ps
= nullptr;
12468 for (auto iter
: loc_map
)
12470 struct ada_catchpoint_location
*ada_loc
12471 = (struct ada_catchpoint_location
*) iter
.second
;
12473 if (ada_loc
->pspace
!= last_ps
)
12475 last_ps
= ada_loc
->pspace
;
12476 set_current_program_space (last_ps
);
12478 /* Compute the condition expression in text form, from the
12479 specific expection we want to catch. */
12481 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (),
12487 if (!ada_loc
->shlib_disabled
)
12491 s
= cond_string
.c_str ();
12494 exp
= parse_exp_1 (&s
, ada_loc
->address
,
12495 block_for_pc (ada_loc
->address
),
12498 catch (const gdb_exception_error
&e
)
12500 warning (_("failed to reevaluate internal exception condition "
12501 "for catchpoint %d: %s"),
12502 c
->number
, e
.what ());
12506 ada_loc
->excep_cond_expr
= std::move (exp
);
12510 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12511 structure for all exception catchpoint kinds. */
12513 static struct bp_location
*
12514 allocate_location_exception (enum ada_exception_catchpoint_kind ex
,
12515 struct breakpoint
*self
)
12517 return new ada_catchpoint_location (self
);
12520 /* Implement the RE_SET method in the breakpoint_ops structure for all
12521 exception catchpoint kinds. */
12524 re_set_exception (enum ada_exception_catchpoint_kind ex
, struct breakpoint
*b
)
12526 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12528 /* Call the base class's method. This updates the catchpoint's
12530 bkpt_breakpoint_ops
.re_set (b
);
12532 /* Reparse the exception conditional expressions. One for each
12534 create_excep_cond_exprs (c
, ex
);
12537 /* Returns true if we should stop for this breakpoint hit. If the
12538 user specified a specific exception, we only want to cause a stop
12539 if the program thrown that exception. */
12542 should_stop_exception (const struct bp_location
*bl
)
12544 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12545 const struct ada_catchpoint_location
*ada_loc
12546 = (const struct ada_catchpoint_location
*) bl
;
12549 /* With no specific exception, should always stop. */
12550 if (c
->excep_string
.empty ())
12553 if (ada_loc
->excep_cond_expr
== NULL
)
12555 /* We will have a NULL expression if back when we were creating
12556 the expressions, this location's had failed to parse. */
12563 struct value
*mark
;
12565 mark
= value_mark ();
12566 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12567 value_free_to_mark (mark
);
12569 catch (const gdb_exception
&ex
)
12571 exception_fprintf (gdb_stderr
, ex
,
12572 _("Error in testing exception condition:\n"));
12578 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12579 for all exception catchpoint kinds. */
12582 check_status_exception (enum ada_exception_catchpoint_kind ex
, bpstat bs
)
12584 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
12587 /* Implement the PRINT_IT method in the breakpoint_ops structure
12588 for all exception catchpoint kinds. */
12590 static enum print_stop_action
12591 print_it_exception (enum ada_exception_catchpoint_kind ex
, bpstat bs
)
12593 struct ui_out
*uiout
= current_uiout
;
12594 struct breakpoint
*b
= bs
->breakpoint_at
;
12596 annotate_catchpoint (b
->number
);
12598 if (uiout
->is_mi_like_p ())
12600 uiout
->field_string ("reason",
12601 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12602 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12605 uiout
->text (b
->disposition
== disp_del
12606 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12607 uiout
->field_int ("bkptno", b
->number
);
12608 uiout
->text (", ");
12610 /* ada_exception_name_addr relies on the selected frame being the
12611 current frame. Need to do this here because this function may be
12612 called more than once when printing a stop, and below, we'll
12613 select the first frame past the Ada run-time (see
12614 ada_find_printable_frame). */
12615 select_frame (get_current_frame ());
12619 case ada_catch_exception
:
12620 case ada_catch_exception_unhandled
:
12621 case ada_catch_handlers
:
12623 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
12624 char exception_name
[256];
12628 read_memory (addr
, (gdb_byte
*) exception_name
,
12629 sizeof (exception_name
) - 1);
12630 exception_name
[sizeof (exception_name
) - 1] = '\0';
12634 /* For some reason, we were unable to read the exception
12635 name. This could happen if the Runtime was compiled
12636 without debugging info, for instance. In that case,
12637 just replace the exception name by the generic string
12638 "exception" - it will read as "an exception" in the
12639 notification we are about to print. */
12640 memcpy (exception_name
, "exception", sizeof ("exception"));
12642 /* In the case of unhandled exception breakpoints, we print
12643 the exception name as "unhandled EXCEPTION_NAME", to make
12644 it clearer to the user which kind of catchpoint just got
12645 hit. We used ui_out_text to make sure that this extra
12646 info does not pollute the exception name in the MI case. */
12647 if (ex
== ada_catch_exception_unhandled
)
12648 uiout
->text ("unhandled ");
12649 uiout
->field_string ("exception-name", exception_name
);
12652 case ada_catch_assert
:
12653 /* In this case, the name of the exception is not really
12654 important. Just print "failed assertion" to make it clearer
12655 that his program just hit an assertion-failure catchpoint.
12656 We used ui_out_text because this info does not belong in
12658 uiout
->text ("failed assertion");
12662 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12663 if (exception_message
!= NULL
)
12665 uiout
->text (" (");
12666 uiout
->field_string ("exception-message", exception_message
.get ());
12670 uiout
->text (" at ");
12671 ada_find_printable_frame (get_current_frame ());
12673 return PRINT_SRC_AND_LOC
;
12676 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12677 for all exception catchpoint kinds. */
12680 print_one_exception (enum ada_exception_catchpoint_kind ex
,
12681 struct breakpoint
*b
, struct bp_location
**last_loc
)
12683 struct ui_out
*uiout
= current_uiout
;
12684 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12685 struct value_print_options opts
;
12687 get_user_print_options (&opts
);
12688 if (opts
.addressprint
)
12690 annotate_field (4);
12691 uiout
->field_core_addr ("addr", b
->loc
->gdbarch
, b
->loc
->address
);
12694 annotate_field (5);
12695 *last_loc
= b
->loc
;
12698 case ada_catch_exception
:
12699 if (!c
->excep_string
.empty ())
12701 std::string msg
= string_printf (_("`%s' Ada exception"),
12702 c
->excep_string
.c_str ());
12704 uiout
->field_string ("what", msg
);
12707 uiout
->field_string ("what", "all Ada exceptions");
12711 case ada_catch_exception_unhandled
:
12712 uiout
->field_string ("what", "unhandled Ada exceptions");
12715 case ada_catch_handlers
:
12716 if (!c
->excep_string
.empty ())
12718 uiout
->field_fmt ("what",
12719 _("`%s' Ada exception handlers"),
12720 c
->excep_string
.c_str ());
12723 uiout
->field_string ("what", "all Ada exceptions handlers");
12726 case ada_catch_assert
:
12727 uiout
->field_string ("what", "failed Ada assertions");
12731 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12736 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12737 for all exception catchpoint kinds. */
12740 print_mention_exception (enum ada_exception_catchpoint_kind ex
,
12741 struct breakpoint
*b
)
12743 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12744 struct ui_out
*uiout
= current_uiout
;
12746 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12747 : _("Catchpoint "));
12748 uiout
->field_int ("bkptno", b
->number
);
12749 uiout
->text (": ");
12753 case ada_catch_exception
:
12754 if (!c
->excep_string
.empty ())
12756 std::string info
= string_printf (_("`%s' Ada exception"),
12757 c
->excep_string
.c_str ());
12758 uiout
->text (info
.c_str ());
12761 uiout
->text (_("all Ada exceptions"));
12764 case ada_catch_exception_unhandled
:
12765 uiout
->text (_("unhandled Ada exceptions"));
12768 case ada_catch_handlers
:
12769 if (!c
->excep_string
.empty ())
12772 = string_printf (_("`%s' Ada exception handlers"),
12773 c
->excep_string
.c_str ());
12774 uiout
->text (info
.c_str ());
12777 uiout
->text (_("all Ada exceptions handlers"));
12780 case ada_catch_assert
:
12781 uiout
->text (_("failed Ada assertions"));
12785 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12790 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12791 for all exception catchpoint kinds. */
12794 print_recreate_exception (enum ada_exception_catchpoint_kind ex
,
12795 struct breakpoint
*b
, struct ui_file
*fp
)
12797 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12801 case ada_catch_exception
:
12802 fprintf_filtered (fp
, "catch exception");
12803 if (!c
->excep_string
.empty ())
12804 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12807 case ada_catch_exception_unhandled
:
12808 fprintf_filtered (fp
, "catch exception unhandled");
12811 case ada_catch_handlers
:
12812 fprintf_filtered (fp
, "catch handlers");
12815 case ada_catch_assert
:
12816 fprintf_filtered (fp
, "catch assert");
12820 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12822 print_recreate_thread (b
, fp
);
12825 /* Virtual table for "catch exception" breakpoints. */
12827 static struct bp_location
*
12828 allocate_location_catch_exception (struct breakpoint
*self
)
12830 return allocate_location_exception (ada_catch_exception
, self
);
12834 re_set_catch_exception (struct breakpoint
*b
)
12836 re_set_exception (ada_catch_exception
, b
);
12840 check_status_catch_exception (bpstat bs
)
12842 check_status_exception (ada_catch_exception
, bs
);
12845 static enum print_stop_action
12846 print_it_catch_exception (bpstat bs
)
12848 return print_it_exception (ada_catch_exception
, bs
);
12852 print_one_catch_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12854 print_one_exception (ada_catch_exception
, b
, last_loc
);
12858 print_mention_catch_exception (struct breakpoint
*b
)
12860 print_mention_exception (ada_catch_exception
, b
);
12864 print_recreate_catch_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12866 print_recreate_exception (ada_catch_exception
, b
, fp
);
12869 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12871 /* Virtual table for "catch exception unhandled" breakpoints. */
12873 static struct bp_location
*
12874 allocate_location_catch_exception_unhandled (struct breakpoint
*self
)
12876 return allocate_location_exception (ada_catch_exception_unhandled
, self
);
12880 re_set_catch_exception_unhandled (struct breakpoint
*b
)
12882 re_set_exception (ada_catch_exception_unhandled
, b
);
12886 check_status_catch_exception_unhandled (bpstat bs
)
12888 check_status_exception (ada_catch_exception_unhandled
, bs
);
12891 static enum print_stop_action
12892 print_it_catch_exception_unhandled (bpstat bs
)
12894 return print_it_exception (ada_catch_exception_unhandled
, bs
);
12898 print_one_catch_exception_unhandled (struct breakpoint
*b
,
12899 struct bp_location
**last_loc
)
12901 print_one_exception (ada_catch_exception_unhandled
, b
, last_loc
);
12905 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
12907 print_mention_exception (ada_catch_exception_unhandled
, b
);
12911 print_recreate_catch_exception_unhandled (struct breakpoint
*b
,
12912 struct ui_file
*fp
)
12914 print_recreate_exception (ada_catch_exception_unhandled
, b
, fp
);
12917 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12919 /* Virtual table for "catch assert" breakpoints. */
12921 static struct bp_location
*
12922 allocate_location_catch_assert (struct breakpoint
*self
)
12924 return allocate_location_exception (ada_catch_assert
, self
);
12928 re_set_catch_assert (struct breakpoint
*b
)
12930 re_set_exception (ada_catch_assert
, b
);
12934 check_status_catch_assert (bpstat bs
)
12936 check_status_exception (ada_catch_assert
, bs
);
12939 static enum print_stop_action
12940 print_it_catch_assert (bpstat bs
)
12942 return print_it_exception (ada_catch_assert
, bs
);
12946 print_one_catch_assert (struct breakpoint
*b
, struct bp_location
**last_loc
)
12948 print_one_exception (ada_catch_assert
, b
, last_loc
);
12952 print_mention_catch_assert (struct breakpoint
*b
)
12954 print_mention_exception (ada_catch_assert
, b
);
12958 print_recreate_catch_assert (struct breakpoint
*b
, struct ui_file
*fp
)
12960 print_recreate_exception (ada_catch_assert
, b
, fp
);
12963 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12965 /* Virtual table for "catch handlers" breakpoints. */
12967 static struct bp_location
*
12968 allocate_location_catch_handlers (struct breakpoint
*self
)
12970 return allocate_location_exception (ada_catch_handlers
, self
);
12974 re_set_catch_handlers (struct breakpoint
*b
)
12976 re_set_exception (ada_catch_handlers
, b
);
12980 check_status_catch_handlers (bpstat bs
)
12982 check_status_exception (ada_catch_handlers
, bs
);
12985 static enum print_stop_action
12986 print_it_catch_handlers (bpstat bs
)
12988 return print_it_exception (ada_catch_handlers
, bs
);
12992 print_one_catch_handlers (struct breakpoint
*b
,
12993 struct bp_location
**last_loc
)
12995 print_one_exception (ada_catch_handlers
, b
, last_loc
);
12999 print_mention_catch_handlers (struct breakpoint
*b
)
13001 print_mention_exception (ada_catch_handlers
, b
);
13005 print_recreate_catch_handlers (struct breakpoint
*b
,
13006 struct ui_file
*fp
)
13008 print_recreate_exception (ada_catch_handlers
, b
, fp
);
13011 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
13013 /* Split the arguments specified in a "catch exception" command.
13014 Set EX to the appropriate catchpoint type.
13015 Set EXCEP_STRING to the name of the specific exception if
13016 specified by the user.
13017 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
13018 "catch handlers" command. False otherwise.
13019 If a condition is found at the end of the arguments, the condition
13020 expression is stored in COND_STRING (memory must be deallocated
13021 after use). Otherwise COND_STRING is set to NULL. */
13024 catch_ada_exception_command_split (const char *args
,
13025 bool is_catch_handlers_cmd
,
13026 enum ada_exception_catchpoint_kind
*ex
,
13027 std::string
*excep_string
,
13028 std::string
*cond_string
)
13030 std::string exception_name
;
13032 exception_name
= extract_arg (&args
);
13033 if (exception_name
== "if")
13035 /* This is not an exception name; this is the start of a condition
13036 expression for a catchpoint on all exceptions. So, "un-get"
13037 this token, and set exception_name to NULL. */
13038 exception_name
.clear ();
13042 /* Check to see if we have a condition. */
13044 args
= skip_spaces (args
);
13045 if (startswith (args
, "if")
13046 && (isspace (args
[2]) || args
[2] == '\0'))
13049 args
= skip_spaces (args
);
13051 if (args
[0] == '\0')
13052 error (_("Condition missing after `if' keyword"));
13053 *cond_string
= args
;
13055 args
+= strlen (args
);
13058 /* Check that we do not have any more arguments. Anything else
13061 if (args
[0] != '\0')
13062 error (_("Junk at end of expression"));
13064 if (is_catch_handlers_cmd
)
13066 /* Catch handling of exceptions. */
13067 *ex
= ada_catch_handlers
;
13068 *excep_string
= exception_name
;
13070 else if (exception_name
.empty ())
13072 /* Catch all exceptions. */
13073 *ex
= ada_catch_exception
;
13074 excep_string
->clear ();
13076 else if (exception_name
== "unhandled")
13078 /* Catch unhandled exceptions. */
13079 *ex
= ada_catch_exception_unhandled
;
13080 excep_string
->clear ();
13084 /* Catch a specific exception. */
13085 *ex
= ada_catch_exception
;
13086 *excep_string
= exception_name
;
13090 /* Return the name of the symbol on which we should break in order to
13091 implement a catchpoint of the EX kind. */
13093 static const char *
13094 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
13096 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
13098 gdb_assert (data
->exception_info
!= NULL
);
13102 case ada_catch_exception
:
13103 return (data
->exception_info
->catch_exception_sym
);
13105 case ada_catch_exception_unhandled
:
13106 return (data
->exception_info
->catch_exception_unhandled_sym
);
13108 case ada_catch_assert
:
13109 return (data
->exception_info
->catch_assert_sym
);
13111 case ada_catch_handlers
:
13112 return (data
->exception_info
->catch_handlers_sym
);
13115 internal_error (__FILE__
, __LINE__
,
13116 _("unexpected catchpoint kind (%d)"), ex
);
13120 /* Return the breakpoint ops "virtual table" used for catchpoints
13123 static const struct breakpoint_ops
*
13124 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
13128 case ada_catch_exception
:
13129 return (&catch_exception_breakpoint_ops
);
13131 case ada_catch_exception_unhandled
:
13132 return (&catch_exception_unhandled_breakpoint_ops
);
13134 case ada_catch_assert
:
13135 return (&catch_assert_breakpoint_ops
);
13137 case ada_catch_handlers
:
13138 return (&catch_handlers_breakpoint_ops
);
13141 internal_error (__FILE__
, __LINE__
,
13142 _("unexpected catchpoint kind (%d)"), ex
);
13146 /* Return the condition that will be used to match the current exception
13147 being raised with the exception that the user wants to catch. This
13148 assumes that this condition is used when the inferior just triggered
13149 an exception catchpoint.
13150 EX: the type of catchpoints used for catching Ada exceptions. */
13153 ada_exception_catchpoint_cond_string (const char *excep_string
,
13154 enum ada_exception_catchpoint_kind ex
)
13157 std::string result
;
13160 if (ex
== ada_catch_handlers
)
13162 /* For exception handlers catchpoints, the condition string does
13163 not use the same parameter as for the other exceptions. */
13164 name
= ("long_integer (GNAT_GCC_exception_Access"
13165 "(gcc_exception).all.occurrence.id)");
13168 name
= "long_integer (e)";
13170 /* The standard exceptions are a special case. They are defined in
13171 runtime units that have been compiled without debugging info; if
13172 EXCEP_STRING is the not-fully-qualified name of a standard
13173 exception (e.g. "constraint_error") then, during the evaluation
13174 of the condition expression, the symbol lookup on this name would
13175 *not* return this standard exception. The catchpoint condition
13176 may then be set only on user-defined exceptions which have the
13177 same not-fully-qualified name (e.g. my_package.constraint_error).
13179 To avoid this unexcepted behavior, these standard exceptions are
13180 systematically prefixed by "standard". This means that "catch
13181 exception constraint_error" is rewritten into "catch exception
13182 standard.constraint_error".
13184 If an exception named contraint_error is defined in another package of
13185 the inferior program, then the only way to specify this exception as a
13186 breakpoint condition is to use its fully-qualified named:
13187 e.g. my_package.constraint_error.
13189 Furthermore, in some situations a standard exception's symbol may
13190 be present in more than one objfile, because the compiler may
13191 choose to emit copy relocations for them. So, we have to compare
13192 against all the possible addresses. */
13194 /* Storage for a rewritten symbol name. */
13195 std::string std_name
;
13196 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
13198 if (strcmp (standard_exc
[i
], excep_string
) == 0)
13200 std_name
= std::string ("standard.") + excep_string
;
13201 excep_string
= std_name
.c_str ();
13206 excep_string
= ada_encode (excep_string
);
13207 std::vector
<struct bound_minimal_symbol
> symbols
13208 = ada_lookup_simple_minsyms (excep_string
);
13209 for (const bound_minimal_symbol
&msym
: symbols
)
13211 if (!result
.empty ())
13213 string_appendf (result
, "%s = %s", name
,
13214 pulongest (BMSYMBOL_VALUE_ADDRESS (msym
)));
13220 /* Return the symtab_and_line that should be used to insert an exception
13221 catchpoint of the TYPE kind.
13223 ADDR_STRING returns the name of the function where the real
13224 breakpoint that implements the catchpoints is set, depending on the
13225 type of catchpoint we need to create. */
13227 static struct symtab_and_line
13228 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
13229 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
13231 const char *sym_name
;
13232 struct symbol
*sym
;
13234 /* First, find out which exception support info to use. */
13235 ada_exception_support_info_sniffer ();
13237 /* Then lookup the function on which we will break in order to catch
13238 the Ada exceptions requested by the user. */
13239 sym_name
= ada_exception_sym_name (ex
);
13240 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
13243 error (_("Catchpoint symbol not found: %s"), sym_name
);
13245 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
13246 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
13248 /* Set ADDR_STRING. */
13249 *addr_string
= sym_name
;
13252 *ops
= ada_exception_breakpoint_ops (ex
);
13254 return find_function_start_sal (sym
, 1);
13257 /* Create an Ada exception catchpoint.
13259 EX_KIND is the kind of exception catchpoint to be created.
13261 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
13262 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
13263 of the exception to which this catchpoint applies.
13265 COND_STRING, if not empty, is the catchpoint condition.
13267 TEMPFLAG, if nonzero, means that the underlying breakpoint
13268 should be temporary.
13270 FROM_TTY is the usual argument passed to all commands implementations. */
13273 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
13274 enum ada_exception_catchpoint_kind ex_kind
,
13275 const std::string
&excep_string
,
13276 const std::string
&cond_string
,
13281 std::string addr_string
;
13282 const struct breakpoint_ops
*ops
= NULL
;
13283 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
13285 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint ());
13286 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
13287 ops
, tempflag
, disabled
, from_tty
);
13288 c
->excep_string
= excep_string
;
13289 create_excep_cond_exprs (c
.get (), ex_kind
);
13290 if (!cond_string
.empty ())
13291 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
);
13292 install_breakpoint (0, std::move (c
), 1);
13295 /* Implement the "catch exception" command. */
13298 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
13299 struct cmd_list_element
*command
)
13301 const char *arg
= arg_entry
;
13302 struct gdbarch
*gdbarch
= get_current_arch ();
13304 enum ada_exception_catchpoint_kind ex_kind
;
13305 std::string excep_string
;
13306 std::string cond_string
;
13308 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
13312 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
13314 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
13315 excep_string
, cond_string
,
13316 tempflag
, 1 /* enabled */,
13320 /* Implement the "catch handlers" command. */
13323 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
13324 struct cmd_list_element
*command
)
13326 const char *arg
= arg_entry
;
13327 struct gdbarch
*gdbarch
= get_current_arch ();
13329 enum ada_exception_catchpoint_kind ex_kind
;
13330 std::string excep_string
;
13331 std::string cond_string
;
13333 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
13337 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
13339 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
13340 excep_string
, cond_string
,
13341 tempflag
, 1 /* enabled */,
13345 /* Completion function for the Ada "catch" commands. */
13348 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
13349 const char *text
, const char *word
)
13351 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
13353 for (const ada_exc_info
&info
: exceptions
)
13355 if (startswith (info
.name
, word
))
13356 tracker
.add_completion
13357 (gdb::unique_xmalloc_ptr
<char> (xstrdup (info
.name
)));
13361 /* Split the arguments specified in a "catch assert" command.
13363 ARGS contains the command's arguments (or the empty string if
13364 no arguments were passed).
13366 If ARGS contains a condition, set COND_STRING to that condition
13367 (the memory needs to be deallocated after use). */
13370 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
13372 args
= skip_spaces (args
);
13374 /* Check whether a condition was provided. */
13375 if (startswith (args
, "if")
13376 && (isspace (args
[2]) || args
[2] == '\0'))
13379 args
= skip_spaces (args
);
13380 if (args
[0] == '\0')
13381 error (_("condition missing after `if' keyword"));
13382 cond_string
.assign (args
);
13385 /* Otherwise, there should be no other argument at the end of
13387 else if (args
[0] != '\0')
13388 error (_("Junk at end of arguments."));
13391 /* Implement the "catch assert" command. */
13394 catch_assert_command (const char *arg_entry
, int from_tty
,
13395 struct cmd_list_element
*command
)
13397 const char *arg
= arg_entry
;
13398 struct gdbarch
*gdbarch
= get_current_arch ();
13400 std::string cond_string
;
13402 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
13406 catch_ada_assert_command_split (arg
, cond_string
);
13407 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
13409 tempflag
, 1 /* enabled */,
13413 /* Return non-zero if the symbol SYM is an Ada exception object. */
13416 ada_is_exception_sym (struct symbol
*sym
)
13418 const char *type_name
= TYPE_NAME (SYMBOL_TYPE (sym
));
13420 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
13421 && SYMBOL_CLASS (sym
) != LOC_BLOCK
13422 && SYMBOL_CLASS (sym
) != LOC_CONST
13423 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
13424 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
13427 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13428 Ada exception object. This matches all exceptions except the ones
13429 defined by the Ada language. */
13432 ada_is_non_standard_exception_sym (struct symbol
*sym
)
13436 if (!ada_is_exception_sym (sym
))
13439 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
13440 if (strcmp (SYMBOL_LINKAGE_NAME (sym
), standard_exc
[i
]) == 0)
13441 return 0; /* A standard exception. */
13443 /* Numeric_Error is also a standard exception, so exclude it.
13444 See the STANDARD_EXC description for more details as to why
13445 this exception is not listed in that array. */
13446 if (strcmp (SYMBOL_LINKAGE_NAME (sym
), "numeric_error") == 0)
13452 /* A helper function for std::sort, comparing two struct ada_exc_info
13455 The comparison is determined first by exception name, and then
13456 by exception address. */
13459 ada_exc_info::operator< (const ada_exc_info
&other
) const
13463 result
= strcmp (name
, other
.name
);
13466 if (result
== 0 && addr
< other
.addr
)
13472 ada_exc_info::operator== (const ada_exc_info
&other
) const
13474 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
13477 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13478 routine, but keeping the first SKIP elements untouched.
13480 All duplicates are also removed. */
13483 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
13486 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
13487 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
13488 exceptions
->end ());
13491 /* Add all exceptions defined by the Ada standard whose name match
13492 a regular expression.
13494 If PREG is not NULL, then this regexp_t object is used to
13495 perform the symbol name matching. Otherwise, no name-based
13496 filtering is performed.
13498 EXCEPTIONS is a vector of exceptions to which matching exceptions
13502 ada_add_standard_exceptions (compiled_regex
*preg
,
13503 std::vector
<ada_exc_info
> *exceptions
)
13507 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
13510 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
13512 struct bound_minimal_symbol msymbol
13513 = ada_lookup_simple_minsym (standard_exc
[i
]);
13515 if (msymbol
.minsym
!= NULL
)
13517 struct ada_exc_info info
13518 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
13520 exceptions
->push_back (info
);
13526 /* Add all Ada exceptions defined locally and accessible from the given
13529 If PREG is not NULL, then this regexp_t object is used to
13530 perform the symbol name matching. Otherwise, no name-based
13531 filtering is performed.
13533 EXCEPTIONS is a vector of exceptions to which matching exceptions
13537 ada_add_exceptions_from_frame (compiled_regex
*preg
,
13538 struct frame_info
*frame
,
13539 std::vector
<ada_exc_info
> *exceptions
)
13541 const struct block
*block
= get_frame_block (frame
, 0);
13545 struct block_iterator iter
;
13546 struct symbol
*sym
;
13548 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
13550 switch (SYMBOL_CLASS (sym
))
13557 if (ada_is_exception_sym (sym
))
13559 struct ada_exc_info info
= {SYMBOL_PRINT_NAME (sym
),
13560 SYMBOL_VALUE_ADDRESS (sym
)};
13562 exceptions
->push_back (info
);
13566 if (BLOCK_FUNCTION (block
) != NULL
)
13568 block
= BLOCK_SUPERBLOCK (block
);
13572 /* Return true if NAME matches PREG or if PREG is NULL. */
13575 name_matches_regex (const char *name
, compiled_regex
*preg
)
13577 return (preg
== NULL
13578 || preg
->exec (ada_decode (name
), 0, NULL
, 0) == 0);
13581 /* Add all exceptions defined globally whose name name match
13582 a regular expression, excluding standard exceptions.
13584 The reason we exclude standard exceptions is that they need
13585 to be handled separately: Standard exceptions are defined inside
13586 a runtime unit which is normally not compiled with debugging info,
13587 and thus usually do not show up in our symbol search. However,
13588 if the unit was in fact built with debugging info, we need to
13589 exclude them because they would duplicate the entry we found
13590 during the special loop that specifically searches for those
13591 standard exceptions.
13593 If PREG is not NULL, then this regexp_t object is used to
13594 perform the symbol name matching. Otherwise, no name-based
13595 filtering is performed.
13597 EXCEPTIONS is a vector of exceptions to which matching exceptions
13601 ada_add_global_exceptions (compiled_regex
*preg
,
13602 std::vector
<ada_exc_info
> *exceptions
)
13604 /* In Ada, the symbol "search name" is a linkage name, whereas the
13605 regular expression used to do the matching refers to the natural
13606 name. So match against the decoded name. */
13607 expand_symtabs_matching (NULL
,
13608 lookup_name_info::match_any (),
13609 [&] (const char *search_name
)
13611 const char *decoded
= ada_decode (search_name
);
13612 return name_matches_regex (decoded
, preg
);
13617 for (objfile
*objfile
: current_program_space
->objfiles ())
13619 for (compunit_symtab
*s
: objfile
->compunits ())
13621 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13624 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13626 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13627 struct block_iterator iter
;
13628 struct symbol
*sym
;
13630 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13631 if (ada_is_non_standard_exception_sym (sym
)
13632 && name_matches_regex (SYMBOL_NATURAL_NAME (sym
), preg
))
13634 struct ada_exc_info info
13635 = {SYMBOL_PRINT_NAME (sym
), SYMBOL_VALUE_ADDRESS (sym
)};
13637 exceptions
->push_back (info
);
13644 /* Implements ada_exceptions_list with the regular expression passed
13645 as a regex_t, rather than a string.
13647 If not NULL, PREG is used to filter out exceptions whose names
13648 do not match. Otherwise, all exceptions are listed. */
13650 static std::vector
<ada_exc_info
>
13651 ada_exceptions_list_1 (compiled_regex
*preg
)
13653 std::vector
<ada_exc_info
> result
;
13656 /* First, list the known standard exceptions. These exceptions
13657 need to be handled separately, as they are usually defined in
13658 runtime units that have been compiled without debugging info. */
13660 ada_add_standard_exceptions (preg
, &result
);
13662 /* Next, find all exceptions whose scope is local and accessible
13663 from the currently selected frame. */
13665 if (has_stack_frames ())
13667 prev_len
= result
.size ();
13668 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13670 if (result
.size () > prev_len
)
13671 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13674 /* Add all exceptions whose scope is global. */
13676 prev_len
= result
.size ();
13677 ada_add_global_exceptions (preg
, &result
);
13678 if (result
.size () > prev_len
)
13679 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13684 /* Return a vector of ada_exc_info.
13686 If REGEXP is NULL, all exceptions are included in the result.
13687 Otherwise, it should contain a valid regular expression,
13688 and only the exceptions whose names match that regular expression
13689 are included in the result.
13691 The exceptions are sorted in the following order:
13692 - Standard exceptions (defined by the Ada language), in
13693 alphabetical order;
13694 - Exceptions only visible from the current frame, in
13695 alphabetical order;
13696 - Exceptions whose scope is global, in alphabetical order. */
13698 std::vector
<ada_exc_info
>
13699 ada_exceptions_list (const char *regexp
)
13701 if (regexp
== NULL
)
13702 return ada_exceptions_list_1 (NULL
);
13704 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13705 return ada_exceptions_list_1 (®
);
13708 /* Implement the "info exceptions" command. */
13711 info_exceptions_command (const char *regexp
, int from_tty
)
13713 struct gdbarch
*gdbarch
= get_current_arch ();
13715 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13717 if (regexp
!= NULL
)
13719 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13721 printf_filtered (_("All defined Ada exceptions:\n"));
13723 for (const ada_exc_info
&info
: exceptions
)
13724 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13728 /* Information about operators given special treatment in functions
13730 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13732 #define ADA_OPERATORS \
13733 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13734 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13735 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13736 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13737 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13738 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13739 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13740 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13741 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13742 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13743 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13744 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13745 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13746 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13747 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13748 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13749 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13750 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13751 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13754 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13757 switch (exp
->elts
[pc
- 1].opcode
)
13760 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13763 #define OP_DEFN(op, len, args, binop) \
13764 case op: *oplenp = len; *argsp = args; break;
13770 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13775 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13780 /* Implementation of the exp_descriptor method operator_check. */
13783 ada_operator_check (struct expression
*exp
, int pos
,
13784 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13787 const union exp_element
*const elts
= exp
->elts
;
13788 struct type
*type
= NULL
;
13790 switch (elts
[pos
].opcode
)
13792 case UNOP_IN_RANGE
:
13794 type
= elts
[pos
+ 1].type
;
13798 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13801 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13803 if (type
&& TYPE_OBJFILE (type
)
13804 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13810 static const char *
13811 ada_op_name (enum exp_opcode opcode
)
13816 return op_name_standard (opcode
);
13818 #define OP_DEFN(op, len, args, binop) case op: return #op;
13823 return "OP_AGGREGATE";
13825 return "OP_CHOICES";
13831 /* As for operator_length, but assumes PC is pointing at the first
13832 element of the operator, and gives meaningful results only for the
13833 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13836 ada_forward_operator_length (struct expression
*exp
, int pc
,
13837 int *oplenp
, int *argsp
)
13839 switch (exp
->elts
[pc
].opcode
)
13842 *oplenp
= *argsp
= 0;
13845 #define OP_DEFN(op, len, args, binop) \
13846 case op: *oplenp = len; *argsp = args; break;
13852 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13857 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13863 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13865 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13873 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13875 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13880 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13884 /* Ada attributes ('Foo). */
13887 case OP_ATR_LENGTH
:
13891 case OP_ATR_MODULUS
:
13898 case UNOP_IN_RANGE
:
13900 /* XXX: gdb_sprint_host_address, type_sprint */
13901 fprintf_filtered (stream
, _("Type @"));
13902 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13903 fprintf_filtered (stream
, " (");
13904 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13905 fprintf_filtered (stream
, ")");
13907 case BINOP_IN_BOUNDS
:
13908 fprintf_filtered (stream
, " (%d)",
13909 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13911 case TERNOP_IN_RANGE
:
13916 case OP_DISCRETE_RANGE
:
13917 case OP_POSITIONAL
:
13924 char *name
= &exp
->elts
[elt
+ 2].string
;
13925 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13927 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13932 return dump_subexp_body_standard (exp
, stream
, elt
);
13936 for (i
= 0; i
< nargs
; i
+= 1)
13937 elt
= dump_subexp (exp
, stream
, elt
);
13942 /* The Ada extension of print_subexp (q.v.). */
13945 ada_print_subexp (struct expression
*exp
, int *pos
,
13946 struct ui_file
*stream
, enum precedence prec
)
13948 int oplen
, nargs
, i
;
13950 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13952 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13959 print_subexp_standard (exp
, pos
, stream
, prec
);
13963 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
13966 case BINOP_IN_BOUNDS
:
13967 /* XXX: sprint_subexp */
13968 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13969 fputs_filtered (" in ", stream
);
13970 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13971 fputs_filtered ("'range", stream
);
13972 if (exp
->elts
[pc
+ 1].longconst
> 1)
13973 fprintf_filtered (stream
, "(%ld)",
13974 (long) exp
->elts
[pc
+ 1].longconst
);
13977 case TERNOP_IN_RANGE
:
13978 if (prec
>= PREC_EQUAL
)
13979 fputs_filtered ("(", stream
);
13980 /* XXX: sprint_subexp */
13981 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13982 fputs_filtered (" in ", stream
);
13983 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13984 fputs_filtered (" .. ", stream
);
13985 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13986 if (prec
>= PREC_EQUAL
)
13987 fputs_filtered (")", stream
);
13992 case OP_ATR_LENGTH
:
13996 case OP_ATR_MODULUS
:
14001 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
14003 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
14004 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
14005 &type_print_raw_options
);
14009 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
14010 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
14015 for (tem
= 1; tem
< nargs
; tem
+= 1)
14017 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
14018 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
14020 fputs_filtered (")", stream
);
14025 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
14026 fputs_filtered ("'(", stream
);
14027 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
14028 fputs_filtered (")", stream
);
14031 case UNOP_IN_RANGE
:
14032 /* XXX: sprint_subexp */
14033 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
14034 fputs_filtered (" in ", stream
);
14035 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
14036 &type_print_raw_options
);
14039 case OP_DISCRETE_RANGE
:
14040 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
14041 fputs_filtered ("..", stream
);
14042 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
14046 fputs_filtered ("others => ", stream
);
14047 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
14051 for (i
= 0; i
< nargs
-1; i
+= 1)
14054 fputs_filtered ("|", stream
);
14055 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
14057 fputs_filtered (" => ", stream
);
14058 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
14061 case OP_POSITIONAL
:
14062 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
14066 fputs_filtered ("(", stream
);
14067 for (i
= 0; i
< nargs
; i
+= 1)
14070 fputs_filtered (", ", stream
);
14071 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
14073 fputs_filtered (")", stream
);
14078 /* Table mapping opcodes into strings for printing operators
14079 and precedences of the operators. */
14081 static const struct op_print ada_op_print_tab
[] = {
14082 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
14083 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
14084 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
14085 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
14086 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
14087 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
14088 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
14089 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
14090 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
14091 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
14092 {">", BINOP_GTR
, PREC_ORDER
, 0},
14093 {"<", BINOP_LESS
, PREC_ORDER
, 0},
14094 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
14095 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
14096 {"+", BINOP_ADD
, PREC_ADD
, 0},
14097 {"-", BINOP_SUB
, PREC_ADD
, 0},
14098 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
14099 {"*", BINOP_MUL
, PREC_MUL
, 0},
14100 {"/", BINOP_DIV
, PREC_MUL
, 0},
14101 {"rem", BINOP_REM
, PREC_MUL
, 0},
14102 {"mod", BINOP_MOD
, PREC_MUL
, 0},
14103 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
14104 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
14105 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
14106 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
14107 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
14108 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
14109 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
14110 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
14111 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
14112 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
14113 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
14116 enum ada_primitive_types
{
14117 ada_primitive_type_int
,
14118 ada_primitive_type_long
,
14119 ada_primitive_type_short
,
14120 ada_primitive_type_char
,
14121 ada_primitive_type_float
,
14122 ada_primitive_type_double
,
14123 ada_primitive_type_void
,
14124 ada_primitive_type_long_long
,
14125 ada_primitive_type_long_double
,
14126 ada_primitive_type_natural
,
14127 ada_primitive_type_positive
,
14128 ada_primitive_type_system_address
,
14129 ada_primitive_type_storage_offset
,
14130 nr_ada_primitive_types
14134 ada_language_arch_info (struct gdbarch
*gdbarch
,
14135 struct language_arch_info
*lai
)
14137 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
14139 lai
->primitive_type_vector
14140 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
14143 lai
->primitive_type_vector
[ada_primitive_type_int
]
14144 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
14146 lai
->primitive_type_vector
[ada_primitive_type_long
]
14147 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
14148 0, "long_integer");
14149 lai
->primitive_type_vector
[ada_primitive_type_short
]
14150 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
14151 0, "short_integer");
14152 lai
->string_char_type
14153 = lai
->primitive_type_vector
[ada_primitive_type_char
]
14154 = arch_character_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
14155 lai
->primitive_type_vector
[ada_primitive_type_float
]
14156 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
14157 "float", gdbarch_float_format (gdbarch
));
14158 lai
->primitive_type_vector
[ada_primitive_type_double
]
14159 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
14160 "long_float", gdbarch_double_format (gdbarch
));
14161 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
14162 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
14163 0, "long_long_integer");
14164 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
14165 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
14166 "long_long_float", gdbarch_long_double_format (gdbarch
));
14167 lai
->primitive_type_vector
[ada_primitive_type_natural
]
14168 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
14170 lai
->primitive_type_vector
[ada_primitive_type_positive
]
14171 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
14173 lai
->primitive_type_vector
[ada_primitive_type_void
]
14174 = builtin
->builtin_void
;
14176 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
14177 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
14179 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
14180 = "system__address";
14182 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14183 type. This is a signed integral type whose size is the same as
14184 the size of addresses. */
14186 unsigned int addr_length
= TYPE_LENGTH
14187 (lai
->primitive_type_vector
[ada_primitive_type_system_address
]);
14189 lai
->primitive_type_vector
[ada_primitive_type_storage_offset
]
14190 = arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
14194 lai
->bool_type_symbol
= NULL
;
14195 lai
->bool_type_default
= builtin
->builtin_bool
;
14198 /* Language vector */
14200 /* Not really used, but needed in the ada_language_defn. */
14203 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
14205 ada_emit_char (c
, type
, stream
, quoter
, 1);
14209 parse (struct parser_state
*ps
)
14211 warnings_issued
= 0;
14212 return ada_parse (ps
);
14215 static const struct exp_descriptor ada_exp_descriptor
= {
14217 ada_operator_length
,
14218 ada_operator_check
,
14220 ada_dump_subexp_body
,
14221 ada_evaluate_subexp
14224 /* symbol_name_matcher_ftype adapter for wild_match. */
14227 do_wild_match (const char *symbol_search_name
,
14228 const lookup_name_info
&lookup_name
,
14229 completion_match_result
*comp_match_res
)
14231 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
14234 /* symbol_name_matcher_ftype adapter for full_match. */
14237 do_full_match (const char *symbol_search_name
,
14238 const lookup_name_info
&lookup_name
,
14239 completion_match_result
*comp_match_res
)
14241 return full_match (symbol_search_name
, ada_lookup_name (lookup_name
));
14244 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
14247 do_exact_match (const char *symbol_search_name
,
14248 const lookup_name_info
&lookup_name
,
14249 completion_match_result
*comp_match_res
)
14251 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
14254 /* Build the Ada lookup name for LOOKUP_NAME. */
14256 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
14258 const std::string
&user_name
= lookup_name
.name ();
14260 if (user_name
[0] == '<')
14262 if (user_name
.back () == '>')
14263 m_encoded_name
= user_name
.substr (1, user_name
.size () - 2);
14265 m_encoded_name
= user_name
.substr (1, user_name
.size () - 1);
14266 m_encoded_p
= true;
14267 m_verbatim_p
= true;
14268 m_wild_match_p
= false;
14269 m_standard_p
= false;
14273 m_verbatim_p
= false;
14275 m_encoded_p
= user_name
.find ("__") != std::string::npos
;
14279 const char *folded
= ada_fold_name (user_name
.c_str ());
14280 const char *encoded
= ada_encode_1 (folded
, false);
14281 if (encoded
!= NULL
)
14282 m_encoded_name
= encoded
;
14284 m_encoded_name
= user_name
;
14287 m_encoded_name
= user_name
;
14289 /* Handle the 'package Standard' special case. See description
14290 of m_standard_p. */
14291 if (startswith (m_encoded_name
.c_str (), "standard__"))
14293 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
14294 m_standard_p
= true;
14297 m_standard_p
= false;
14299 /* If the name contains a ".", then the user is entering a fully
14300 qualified entity name, and the match must not be done in wild
14301 mode. Similarly, if the user wants to complete what looks
14302 like an encoded name, the match must not be done in wild
14303 mode. Also, in the standard__ special case always do
14304 non-wild matching. */
14306 = (lookup_name
.match_type () != symbol_name_match_type::FULL
14309 && user_name
.find ('.') == std::string::npos
);
14313 /* symbol_name_matcher_ftype method for Ada. This only handles
14314 completion mode. */
14317 ada_symbol_name_matches (const char *symbol_search_name
,
14318 const lookup_name_info
&lookup_name
,
14319 completion_match_result
*comp_match_res
)
14321 return lookup_name
.ada ().matches (symbol_search_name
,
14322 lookup_name
.match_type (),
14326 /* A name matcher that matches the symbol name exactly, with
14330 literal_symbol_name_matcher (const char *symbol_search_name
,
14331 const lookup_name_info
&lookup_name
,
14332 completion_match_result
*comp_match_res
)
14334 const std::string
&name
= lookup_name
.name ();
14336 int cmp
= (lookup_name
.completion_mode ()
14337 ? strncmp (symbol_search_name
, name
.c_str (), name
.size ())
14338 : strcmp (symbol_search_name
, name
.c_str ()));
14341 if (comp_match_res
!= NULL
)
14342 comp_match_res
->set_match (symbol_search_name
);
14349 /* Implement the "la_get_symbol_name_matcher" language_defn method for
14352 static symbol_name_matcher_ftype
*
14353 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
14355 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
14356 return literal_symbol_name_matcher
;
14358 if (lookup_name
.completion_mode ())
14359 return ada_symbol_name_matches
;
14362 if (lookup_name
.ada ().wild_match_p ())
14363 return do_wild_match
;
14364 else if (lookup_name
.ada ().verbatim_p ())
14365 return do_exact_match
;
14367 return do_full_match
;
14371 /* Implement the "la_read_var_value" language_defn method for Ada. */
14373 static struct value
*
14374 ada_read_var_value (struct symbol
*var
, const struct block
*var_block
,
14375 struct frame_info
*frame
)
14377 const struct block
*frame_block
= NULL
;
14378 struct symbol
*renaming_sym
= NULL
;
14380 /* The only case where default_read_var_value is not sufficient
14381 is when VAR is a renaming... */
14383 frame_block
= get_frame_block (frame
, NULL
);
14385 renaming_sym
= ada_find_renaming_symbol (var
, frame_block
);
14386 if (renaming_sym
!= NULL
)
14387 return ada_read_renaming_var_value (renaming_sym
, frame_block
);
14389 /* This is a typical case where we expect the default_read_var_value
14390 function to work. */
14391 return default_read_var_value (var
, var_block
, frame
);
14394 static const char *ada_extensions
[] =
14396 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14399 extern const struct language_defn ada_language_defn
= {
14400 "ada", /* Language name */
14404 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
14405 that's not quite what this means. */
14407 macro_expansion_no
,
14409 &ada_exp_descriptor
,
14412 ada_printchar
, /* Print a character constant */
14413 ada_printstr
, /* Function to print string constant */
14414 emit_char
, /* Function to print single char (not used) */
14415 ada_print_type
, /* Print a type using appropriate syntax */
14416 ada_print_typedef
, /* Print a typedef using appropriate syntax */
14417 ada_val_print
, /* Print a value using appropriate syntax */
14418 ada_value_print
, /* Print a top-level value */
14419 ada_read_var_value
, /* la_read_var_value */
14420 NULL
, /* Language specific skip_trampoline */
14421 NULL
, /* name_of_this */
14422 true, /* la_store_sym_names_in_linkage_form_p */
14423 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
14424 basic_lookup_transparent_type
, /* lookup_transparent_type */
14425 ada_la_decode
, /* Language specific symbol demangler */
14426 ada_sniff_from_mangled_name
,
14427 NULL
, /* Language specific
14428 class_name_from_physname */
14429 ada_op_print_tab
, /* expression operators for printing */
14430 0, /* c-style arrays */
14431 1, /* String lower bound */
14432 ada_get_gdb_completer_word_break_characters
,
14433 ada_collect_symbol_completion_matches
,
14434 ada_language_arch_info
,
14435 ada_print_array_index
,
14436 default_pass_by_reference
,
14438 ada_watch_location_expression
,
14439 ada_get_symbol_name_matcher
, /* la_get_symbol_name_matcher */
14440 ada_iterate_over_symbols
,
14441 default_search_name_hash
,
14445 ada_is_string_type
,
14446 "(...)" /* la_struct_too_deep_ellipsis */
14449 /* Command-list for the "set/show ada" prefix command. */
14450 static struct cmd_list_element
*set_ada_list
;
14451 static struct cmd_list_element
*show_ada_list
;
14453 /* Implement the "set ada" prefix command. */
14456 set_ada_command (const char *arg
, int from_tty
)
14458 printf_unfiltered (_(\
14459 "\"set ada\" must be followed by the name of a setting.\n"));
14460 help_list (set_ada_list
, "set ada ", all_commands
, gdb_stdout
);
14463 /* Implement the "show ada" prefix command. */
14466 show_ada_command (const char *args
, int from_tty
)
14468 cmd_show_list (show_ada_list
, from_tty
, "");
14472 initialize_ada_catchpoint_ops (void)
14474 struct breakpoint_ops
*ops
;
14476 initialize_breakpoint_ops ();
14478 ops
= &catch_exception_breakpoint_ops
;
14479 *ops
= bkpt_breakpoint_ops
;
14480 ops
->allocate_location
= allocate_location_catch_exception
;
14481 ops
->re_set
= re_set_catch_exception
;
14482 ops
->check_status
= check_status_catch_exception
;
14483 ops
->print_it
= print_it_catch_exception
;
14484 ops
->print_one
= print_one_catch_exception
;
14485 ops
->print_mention
= print_mention_catch_exception
;
14486 ops
->print_recreate
= print_recreate_catch_exception
;
14488 ops
= &catch_exception_unhandled_breakpoint_ops
;
14489 *ops
= bkpt_breakpoint_ops
;
14490 ops
->allocate_location
= allocate_location_catch_exception_unhandled
;
14491 ops
->re_set
= re_set_catch_exception_unhandled
;
14492 ops
->check_status
= check_status_catch_exception_unhandled
;
14493 ops
->print_it
= print_it_catch_exception_unhandled
;
14494 ops
->print_one
= print_one_catch_exception_unhandled
;
14495 ops
->print_mention
= print_mention_catch_exception_unhandled
;
14496 ops
->print_recreate
= print_recreate_catch_exception_unhandled
;
14498 ops
= &catch_assert_breakpoint_ops
;
14499 *ops
= bkpt_breakpoint_ops
;
14500 ops
->allocate_location
= allocate_location_catch_assert
;
14501 ops
->re_set
= re_set_catch_assert
;
14502 ops
->check_status
= check_status_catch_assert
;
14503 ops
->print_it
= print_it_catch_assert
;
14504 ops
->print_one
= print_one_catch_assert
;
14505 ops
->print_mention
= print_mention_catch_assert
;
14506 ops
->print_recreate
= print_recreate_catch_assert
;
14508 ops
= &catch_handlers_breakpoint_ops
;
14509 *ops
= bkpt_breakpoint_ops
;
14510 ops
->allocate_location
= allocate_location_catch_handlers
;
14511 ops
->re_set
= re_set_catch_handlers
;
14512 ops
->check_status
= check_status_catch_handlers
;
14513 ops
->print_it
= print_it_catch_handlers
;
14514 ops
->print_one
= print_one_catch_handlers
;
14515 ops
->print_mention
= print_mention_catch_handlers
;
14516 ops
->print_recreate
= print_recreate_catch_handlers
;
14519 /* This module's 'new_objfile' observer. */
14522 ada_new_objfile_observer (struct objfile
*objfile
)
14524 ada_clear_symbol_cache ();
14527 /* This module's 'free_objfile' observer. */
14530 ada_free_objfile_observer (struct objfile
*objfile
)
14532 ada_clear_symbol_cache ();
14536 _initialize_ada_language (void)
14538 initialize_ada_catchpoint_ops ();
14540 add_prefix_cmd ("ada", no_class
, set_ada_command
,
14541 _("Prefix command for changing Ada-specific settings"),
14542 &set_ada_list
, "set ada ", 0, &setlist
);
14544 add_prefix_cmd ("ada", no_class
, show_ada_command
,
14545 _("Generic command for showing Ada-specific settings."),
14546 &show_ada_list
, "show ada ", 0, &showlist
);
14548 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14549 &trust_pad_over_xvs
, _("\
14550 Enable or disable an optimization trusting PAD types over XVS types"), _("\
14551 Show whether an optimization trusting PAD types over XVS types is activated"),
14553 This is related to the encoding used by the GNAT compiler. The debugger\n\
14554 should normally trust the contents of PAD types, but certain older versions\n\
14555 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14556 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14557 work around this bug. It is always safe to turn this option \"off\", but\n\
14558 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14559 this option to \"off\" unless necessary."),
14560 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14562 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14563 &print_signatures
, _("\
14564 Enable or disable the output of formal and return types for functions in the \
14565 overloads selection menu"), _("\
14566 Show whether the output of formal and return types for functions in the \
14567 overloads selection menu is activated"),
14568 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14570 add_catch_command ("exception", _("\
14571 Catch Ada exceptions, when raised.\n\
14572 Usage: catch exception [ ARG ]\n\
14574 Without any argument, stop when any Ada exception is raised.\n\
14575 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14576 being raised does not have a handler (and will therefore lead to the task's\n\
14578 Otherwise, the catchpoint only stops when the name of the exception being\n\
14579 raised is the same as ARG."),
14580 catch_ada_exception_command
,
14581 catch_ada_completer
,
14585 add_catch_command ("handlers", _("\
14586 Catch Ada exceptions, when handled.\n\
14587 With an argument, catch only exceptions with the given name."),
14588 catch_ada_handlers_command
,
14589 catch_ada_completer
,
14592 add_catch_command ("assert", _("\
14593 Catch failed Ada assertions, when raised.\n\
14594 With an argument, catch only exceptions with the given name."),
14595 catch_assert_command
,
14600 varsize_limit
= 65536;
14601 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14602 &varsize_limit
, _("\
14603 Set the maximum number of bytes allowed in a variable-size object."), _("\
14604 Show the maximum number of bytes allowed in a variable-size object."), _("\
14605 Attempts to access an object whose size is not a compile-time constant\n\
14606 and exceeds this limit will cause an error."),
14607 NULL
, NULL
, &setlist
, &showlist
);
14609 add_info ("exceptions", info_exceptions_command
,
14611 List all Ada exception names.\n\
14612 If a regular expression is passed as an argument, only those matching\n\
14613 the regular expression are listed."));
14615 add_prefix_cmd ("ada", class_maintenance
, maint_set_ada_cmd
,
14616 _("Set Ada maintenance-related variables."),
14617 &maint_set_ada_cmdlist
, "maintenance set ada ",
14618 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14620 add_prefix_cmd ("ada", class_maintenance
, maint_show_ada_cmd
,
14621 _("Show Ada maintenance-related variables"),
14622 &maint_show_ada_cmdlist
, "maintenance show ada ",
14623 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14625 add_setshow_boolean_cmd
14626 ("ignore-descriptive-types", class_maintenance
,
14627 &ada_ignore_descriptive_types_p
,
14628 _("Set whether descriptive types generated by GNAT should be ignored."),
14629 _("Show whether descriptive types generated by GNAT should be ignored."),
14631 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14632 DWARF attribute."),
14633 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14635 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14636 NULL
, xcalloc
, xfree
);
14638 /* The ada-lang observers. */
14639 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14640 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14641 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);