1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2020 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
23 #include "gdb_regex.h"
28 #include "expression.h"
29 #include "parser-defs.h"
35 #include "breakpoint.h"
38 #include "gdb_obstack.h"
40 #include "completer.h"
47 #include "observable.h"
49 #include "typeprint.h"
50 #include "namespace.h"
51 #include "cli/cli-style.h"
54 #include "mi/mi-common.h"
55 #include "arch-utils.h"
56 #include "cli/cli-utils.h"
57 #include "gdbsupport/function-view.h"
58 #include "gdbsupport/byte-vector.h"
61 /* Define whether or not the C operator '/' truncates towards zero for
62 differently signed operands (truncation direction is undefined in C).
63 Copied from valarith.c. */
65 #ifndef TRUNCATION_TOWARDS_ZERO
66 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
69 static struct type
*desc_base_type (struct type
*);
71 static struct type
*desc_bounds_type (struct type
*);
73 static struct value
*desc_bounds (struct value
*);
75 static int fat_pntr_bounds_bitpos (struct type
*);
77 static int fat_pntr_bounds_bitsize (struct type
*);
79 static struct type
*desc_data_target_type (struct type
*);
81 static struct value
*desc_data (struct value
*);
83 static int fat_pntr_data_bitpos (struct type
*);
85 static int fat_pntr_data_bitsize (struct type
*);
87 static struct value
*desc_one_bound (struct value
*, int, int);
89 static int desc_bound_bitpos (struct type
*, int, int);
91 static int desc_bound_bitsize (struct type
*, int, int);
93 static struct type
*desc_index_type (struct type
*, int);
95 static int desc_arity (struct type
*);
97 static int ada_type_match (struct type
*, struct type
*, int);
99 static int ada_args_match (struct symbol
*, struct value
**, int);
101 static struct value
*make_array_descriptor (struct type
*, struct value
*);
103 static void ada_add_block_symbols (struct obstack
*,
104 const struct block
*,
105 const lookup_name_info
&lookup_name
,
106 domain_enum
, struct objfile
*);
108 static void ada_add_all_symbols (struct obstack
*, const struct block
*,
109 const lookup_name_info
&lookup_name
,
110 domain_enum
, int, int *);
112 static int is_nonfunction (struct block_symbol
*, int);
114 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
115 const struct block
*);
117 static int num_defns_collected (struct obstack
*);
119 static struct block_symbol
*defns_collected (struct obstack
*, int);
121 static struct value
*resolve_subexp (expression_up
*, int *, int,
123 innermost_block_tracker
*);
125 static void replace_operator_with_call (expression_up
*, int, int, int,
126 struct symbol
*, const struct block
*);
128 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
130 static const char *ada_op_name (enum exp_opcode
);
132 static const char *ada_decoded_op_name (enum exp_opcode
);
134 static int numeric_type_p (struct type
*);
136 static int integer_type_p (struct type
*);
138 static int scalar_type_p (struct type
*);
140 static int discrete_type_p (struct type
*);
142 static struct type
*ada_lookup_struct_elt_type (struct type
*, const char *,
145 static struct value
*evaluate_subexp_type (struct expression
*, int *);
147 static struct type
*ada_find_parallel_type_with_name (struct type
*,
150 static int is_dynamic_field (struct type
*, int);
152 static struct type
*to_fixed_variant_branch_type (struct type
*,
154 CORE_ADDR
, struct value
*);
156 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
158 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
160 static struct type
*to_static_fixed_type (struct type
*);
161 static struct type
*static_unwrap_type (struct type
*type
);
163 static struct value
*unwrap_value (struct value
*);
165 static struct type
*constrained_packed_array_type (struct type
*, long *);
167 static struct type
*decode_constrained_packed_array_type (struct type
*);
169 static long decode_packed_array_bitsize (struct type
*);
171 static struct value
*decode_constrained_packed_array (struct value
*);
173 static int ada_is_packed_array_type (struct type
*);
175 static int ada_is_unconstrained_packed_array_type (struct type
*);
177 static struct value
*value_subscript_packed (struct value
*, int,
180 static struct value
*coerce_unspec_val_to_type (struct value
*,
183 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
185 static int equiv_types (struct type
*, struct type
*);
187 static int is_name_suffix (const char *);
189 static int advance_wild_match (const char **, const char *, int);
191 static bool wild_match (const char *name
, const char *patn
);
193 static struct value
*ada_coerce_ref (struct value
*);
195 static LONGEST
pos_atr (struct value
*);
197 static struct value
*value_pos_atr (struct type
*, struct value
*);
199 static struct value
*val_atr (struct type
*, LONGEST
);
201 static struct value
*value_val_atr (struct type
*, struct value
*);
203 static struct symbol
*standard_lookup (const char *, const struct block
*,
206 static struct value
*ada_search_struct_field (const char *, struct value
*, int,
209 static int find_struct_field (const char *, struct type
*, int,
210 struct type
**, int *, int *, int *, int *);
212 static int ada_resolve_function (struct block_symbol
*, int,
213 struct value
**, int, const char *,
216 static int ada_is_direct_array_type (struct type
*);
218 static struct value
*ada_index_struct_field (int, struct value
*, int,
221 static struct value
*assign_aggregate (struct value
*, struct value
*,
225 static void aggregate_assign_from_choices (struct value
*, struct value
*,
227 int *, LONGEST
*, int *,
228 int, LONGEST
, LONGEST
);
230 static void aggregate_assign_positional (struct value
*, struct value
*,
232 int *, LONGEST
*, int *, int,
236 static void aggregate_assign_others (struct value
*, struct value
*,
238 int *, LONGEST
*, int, LONGEST
, LONGEST
);
241 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
244 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
247 static void ada_forward_operator_length (struct expression
*, int, int *,
250 static struct type
*ada_find_any_type (const char *name
);
252 static symbol_name_matcher_ftype
*ada_get_symbol_name_matcher
253 (const lookup_name_info
&lookup_name
);
257 /* The result of a symbol lookup to be stored in our symbol cache. */
261 /* The name used to perform the lookup. */
263 /* The namespace used during the lookup. */
265 /* The symbol returned by the lookup, or NULL if no matching symbol
268 /* The block where the symbol was found, or NULL if no matching
270 const struct block
*block
;
271 /* A pointer to the next entry with the same hash. */
272 struct cache_entry
*next
;
275 /* The Ada symbol cache, used to store the result of Ada-mode symbol
276 lookups in the course of executing the user's commands.
278 The cache is implemented using a simple, fixed-sized hash.
279 The size is fixed on the grounds that there are not likely to be
280 all that many symbols looked up during any given session, regardless
281 of the size of the symbol table. If we decide to go to a resizable
282 table, let's just use the stuff from libiberty instead. */
284 #define HASH_SIZE 1009
286 struct ada_symbol_cache
288 /* An obstack used to store the entries in our cache. */
289 struct obstack cache_space
;
291 /* The root of the hash table used to implement our symbol cache. */
292 struct cache_entry
*root
[HASH_SIZE
];
295 static void ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
);
297 /* Maximum-sized dynamic type. */
298 static unsigned int varsize_limit
;
300 static const char ada_completer_word_break_characters
[] =
302 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
304 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
307 /* The name of the symbol to use to get the name of the main subprogram. */
308 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
309 = "__gnat_ada_main_program_name";
311 /* Limit on the number of warnings to raise per expression evaluation. */
312 static int warning_limit
= 2;
314 /* Number of warning messages issued; reset to 0 by cleanups after
315 expression evaluation. */
316 static int warnings_issued
= 0;
318 static const char *known_runtime_file_name_patterns
[] = {
319 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
322 static const char *known_auxiliary_function_name_patterns
[] = {
323 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
326 /* Maintenance-related settings for this module. */
328 static struct cmd_list_element
*maint_set_ada_cmdlist
;
329 static struct cmd_list_element
*maint_show_ada_cmdlist
;
331 /* The "maintenance ada set/show ignore-descriptive-type" value. */
333 static bool ada_ignore_descriptive_types_p
= false;
335 /* Inferior-specific data. */
337 /* Per-inferior data for this module. */
339 struct ada_inferior_data
341 /* The ada__tags__type_specific_data type, which is used when decoding
342 tagged types. With older versions of GNAT, this type was directly
343 accessible through a component ("tsd") in the object tag. But this
344 is no longer the case, so we cache it for each inferior. */
345 struct type
*tsd_type
= nullptr;
347 /* The exception_support_info data. This data is used to determine
348 how to implement support for Ada exception catchpoints in a given
350 const struct exception_support_info
*exception_info
= nullptr;
353 /* Our key to this module's inferior data. */
354 static const struct inferior_key
<ada_inferior_data
> ada_inferior_data
;
356 /* Return our inferior data for the given inferior (INF).
358 This function always returns a valid pointer to an allocated
359 ada_inferior_data structure. If INF's inferior data has not
360 been previously set, this functions creates a new one with all
361 fields set to zero, sets INF's inferior to it, and then returns
362 a pointer to that newly allocated ada_inferior_data. */
364 static struct ada_inferior_data
*
365 get_ada_inferior_data (struct inferior
*inf
)
367 struct ada_inferior_data
*data
;
369 data
= ada_inferior_data
.get (inf
);
371 data
= ada_inferior_data
.emplace (inf
);
376 /* Perform all necessary cleanups regarding our module's inferior data
377 that is required after the inferior INF just exited. */
380 ada_inferior_exit (struct inferior
*inf
)
382 ada_inferior_data
.clear (inf
);
386 /* program-space-specific data. */
388 /* This module's per-program-space data. */
389 struct ada_pspace_data
393 if (sym_cache
!= NULL
)
394 ada_free_symbol_cache (sym_cache
);
397 /* The Ada symbol cache. */
398 struct ada_symbol_cache
*sym_cache
= nullptr;
401 /* Key to our per-program-space data. */
402 static const struct program_space_key
<ada_pspace_data
> ada_pspace_data_handle
;
404 /* Return this module's data for the given program space (PSPACE).
405 If not is found, add a zero'ed one now.
407 This function always returns a valid object. */
409 static struct ada_pspace_data
*
410 get_ada_pspace_data (struct program_space
*pspace
)
412 struct ada_pspace_data
*data
;
414 data
= ada_pspace_data_handle
.get (pspace
);
416 data
= ada_pspace_data_handle
.emplace (pspace
);
423 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
424 all typedef layers have been peeled. Otherwise, return TYPE.
426 Normally, we really expect a typedef type to only have 1 typedef layer.
427 In other words, we really expect the target type of a typedef type to be
428 a non-typedef type. This is particularly true for Ada units, because
429 the language does not have a typedef vs not-typedef distinction.
430 In that respect, the Ada compiler has been trying to eliminate as many
431 typedef definitions in the debugging information, since they generally
432 do not bring any extra information (we still use typedef under certain
433 circumstances related mostly to the GNAT encoding).
435 Unfortunately, we have seen situations where the debugging information
436 generated by the compiler leads to such multiple typedef layers. For
437 instance, consider the following example with stabs:
439 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
440 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
442 This is an error in the debugging information which causes type
443 pck__float_array___XUP to be defined twice, and the second time,
444 it is defined as a typedef of a typedef.
446 This is on the fringe of legality as far as debugging information is
447 concerned, and certainly unexpected. But it is easy to handle these
448 situations correctly, so we can afford to be lenient in this case. */
451 ada_typedef_target_type (struct type
*type
)
453 while (type
->code () == TYPE_CODE_TYPEDEF
)
454 type
= TYPE_TARGET_TYPE (type
);
458 /* Given DECODED_NAME a string holding a symbol name in its
459 decoded form (ie using the Ada dotted notation), returns
460 its unqualified name. */
463 ada_unqualified_name (const char *decoded_name
)
467 /* If the decoded name starts with '<', it means that the encoded
468 name does not follow standard naming conventions, and thus that
469 it is not your typical Ada symbol name. Trying to unqualify it
470 is therefore pointless and possibly erroneous. */
471 if (decoded_name
[0] == '<')
474 result
= strrchr (decoded_name
, '.');
476 result
++; /* Skip the dot... */
478 result
= decoded_name
;
483 /* Return a string starting with '<', followed by STR, and '>'. */
486 add_angle_brackets (const char *str
)
488 return string_printf ("<%s>", str
);
491 /* la_watch_location_expression for Ada. */
493 static gdb::unique_xmalloc_ptr
<char>
494 ada_watch_location_expression (struct type
*type
, CORE_ADDR addr
)
496 type
= check_typedef (TYPE_TARGET_TYPE (check_typedef (type
)));
497 std::string name
= type_to_string (type
);
498 return gdb::unique_xmalloc_ptr
<char>
499 (xstrprintf ("{%s} %s", name
.c_str (), core_addr_to_string (addr
)));
502 /* Assuming V points to an array of S objects, make sure that it contains at
503 least M objects, updating V and S as necessary. */
505 #define GROW_VECT(v, s, m) \
506 if ((s) < (m)) (v) = (char *) grow_vect (v, &(s), m, sizeof *(v));
508 /* Assuming VECT points to an array of *SIZE objects of size
509 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
510 updating *SIZE as necessary and returning the (new) array. */
513 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
515 if (*size
< min_size
)
518 if (*size
< min_size
)
520 vect
= xrealloc (vect
, *size
* element_size
);
525 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
526 suffix of FIELD_NAME beginning "___". */
529 field_name_match (const char *field_name
, const char *target
)
531 int len
= strlen (target
);
534 (strncmp (field_name
, target
, len
) == 0
535 && (field_name
[len
] == '\0'
536 || (startswith (field_name
+ len
, "___")
537 && strcmp (field_name
+ strlen (field_name
) - 6,
542 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
543 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
544 and return its index. This function also handles fields whose name
545 have ___ suffixes because the compiler sometimes alters their name
546 by adding such a suffix to represent fields with certain constraints.
547 If the field could not be found, return a negative number if
548 MAYBE_MISSING is set. Otherwise raise an error. */
551 ada_get_field_index (const struct type
*type
, const char *field_name
,
555 struct type
*struct_type
= check_typedef ((struct type
*) type
);
557 for (fieldno
= 0; fieldno
< struct_type
->num_fields (); fieldno
++)
558 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
562 error (_("Unable to find field %s in struct %s. Aborting"),
563 field_name
, struct_type
->name ());
568 /* The length of the prefix of NAME prior to any "___" suffix. */
571 ada_name_prefix_len (const char *name
)
577 const char *p
= strstr (name
, "___");
580 return strlen (name
);
586 /* Return non-zero if SUFFIX is a suffix of STR.
587 Return zero if STR is null. */
590 is_suffix (const char *str
, const char *suffix
)
597 len2
= strlen (suffix
);
598 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
601 /* The contents of value VAL, treated as a value of type TYPE. The
602 result is an lval in memory if VAL is. */
604 static struct value
*
605 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
607 type
= ada_check_typedef (type
);
608 if (value_type (val
) == type
)
612 struct value
*result
;
614 /* Make sure that the object size is not unreasonable before
615 trying to allocate some memory for it. */
616 ada_ensure_varsize_limit (type
);
619 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
620 result
= allocate_value_lazy (type
);
623 result
= allocate_value (type
);
624 value_contents_copy_raw (result
, 0, val
, 0, TYPE_LENGTH (type
));
626 set_value_component_location (result
, val
);
627 set_value_bitsize (result
, value_bitsize (val
));
628 set_value_bitpos (result
, value_bitpos (val
));
629 if (VALUE_LVAL (result
) == lval_memory
)
630 set_value_address (result
, value_address (val
));
635 static const gdb_byte
*
636 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
641 return valaddr
+ offset
;
645 cond_offset_target (CORE_ADDR address
, long offset
)
650 return address
+ offset
;
653 /* Issue a warning (as for the definition of warning in utils.c, but
654 with exactly one argument rather than ...), unless the limit on the
655 number of warnings has passed during the evaluation of the current
658 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
659 provided by "complaint". */
660 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
663 lim_warning (const char *format
, ...)
667 va_start (args
, format
);
668 warnings_issued
+= 1;
669 if (warnings_issued
<= warning_limit
)
670 vwarning (format
, args
);
675 /* Issue an error if the size of an object of type T is unreasonable,
676 i.e. if it would be a bad idea to allocate a value of this type in
680 ada_ensure_varsize_limit (const struct type
*type
)
682 if (TYPE_LENGTH (type
) > varsize_limit
)
683 error (_("object size is larger than varsize-limit"));
686 /* Maximum value of a SIZE-byte signed integer type. */
688 max_of_size (int size
)
690 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
692 return top_bit
| (top_bit
- 1);
695 /* Minimum value of a SIZE-byte signed integer type. */
697 min_of_size (int size
)
699 return -max_of_size (size
) - 1;
702 /* Maximum value of a SIZE-byte unsigned integer type. */
704 umax_of_size (int size
)
706 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
708 return top_bit
| (top_bit
- 1);
711 /* Maximum value of integral type T, as a signed quantity. */
713 max_of_type (struct type
*t
)
715 if (TYPE_UNSIGNED (t
))
716 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
718 return max_of_size (TYPE_LENGTH (t
));
721 /* Minimum value of integral type T, as a signed quantity. */
723 min_of_type (struct type
*t
)
725 if (TYPE_UNSIGNED (t
))
728 return min_of_size (TYPE_LENGTH (t
));
731 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
733 ada_discrete_type_high_bound (struct type
*type
)
735 type
= resolve_dynamic_type (type
, {}, 0);
736 switch (type
->code ())
738 case TYPE_CODE_RANGE
:
739 return TYPE_HIGH_BOUND (type
);
741 return TYPE_FIELD_ENUMVAL (type
, type
->num_fields () - 1);
746 return max_of_type (type
);
748 error (_("Unexpected type in ada_discrete_type_high_bound."));
752 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
754 ada_discrete_type_low_bound (struct type
*type
)
756 type
= resolve_dynamic_type (type
, {}, 0);
757 switch (type
->code ())
759 case TYPE_CODE_RANGE
:
760 return TYPE_LOW_BOUND (type
);
762 return TYPE_FIELD_ENUMVAL (type
, 0);
767 return min_of_type (type
);
769 error (_("Unexpected type in ada_discrete_type_low_bound."));
773 /* The identity on non-range types. For range types, the underlying
774 non-range scalar type. */
777 get_base_type (struct type
*type
)
779 while (type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
)
781 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
783 type
= TYPE_TARGET_TYPE (type
);
788 /* Return a decoded version of the given VALUE. This means returning
789 a value whose type is obtained by applying all the GNAT-specific
790 encodings, making the resulting type a static but standard description
791 of the initial type. */
794 ada_get_decoded_value (struct value
*value
)
796 struct type
*type
= ada_check_typedef (value_type (value
));
798 if (ada_is_array_descriptor_type (type
)
799 || (ada_is_constrained_packed_array_type (type
)
800 && type
->code () != TYPE_CODE_PTR
))
802 if (type
->code () == TYPE_CODE_TYPEDEF
) /* array access type. */
803 value
= ada_coerce_to_simple_array_ptr (value
);
805 value
= ada_coerce_to_simple_array (value
);
808 value
= ada_to_fixed_value (value
);
813 /* Same as ada_get_decoded_value, but with the given TYPE.
814 Because there is no associated actual value for this type,
815 the resulting type might be a best-effort approximation in
816 the case of dynamic types. */
819 ada_get_decoded_type (struct type
*type
)
821 type
= to_static_fixed_type (type
);
822 if (ada_is_constrained_packed_array_type (type
))
823 type
= ada_coerce_to_simple_array_type (type
);
829 /* Language Selection */
831 /* If the main program is in Ada, return language_ada, otherwise return LANG
832 (the main program is in Ada iif the adainit symbol is found). */
835 ada_update_initial_language (enum language lang
)
837 if (lookup_minimal_symbol ("adainit", NULL
, NULL
).minsym
!= NULL
)
843 /* If the main procedure is written in Ada, then return its name.
844 The result is good until the next call. Return NULL if the main
845 procedure doesn't appear to be in Ada. */
850 struct bound_minimal_symbol msym
;
851 static gdb::unique_xmalloc_ptr
<char> main_program_name
;
853 /* For Ada, the name of the main procedure is stored in a specific
854 string constant, generated by the binder. Look for that symbol,
855 extract its address, and then read that string. If we didn't find
856 that string, then most probably the main procedure is not written
858 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
860 if (msym
.minsym
!= NULL
)
862 CORE_ADDR main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
863 if (main_program_name_addr
== 0)
864 error (_("Invalid address for Ada main program name."));
866 main_program_name
= target_read_string (main_program_name_addr
, 1024);
867 return main_program_name
.get ();
870 /* The main procedure doesn't seem to be in Ada. */
876 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
879 const struct ada_opname_map ada_opname_table
[] = {
880 {"Oadd", "\"+\"", BINOP_ADD
},
881 {"Osubtract", "\"-\"", BINOP_SUB
},
882 {"Omultiply", "\"*\"", BINOP_MUL
},
883 {"Odivide", "\"/\"", BINOP_DIV
},
884 {"Omod", "\"mod\"", BINOP_MOD
},
885 {"Orem", "\"rem\"", BINOP_REM
},
886 {"Oexpon", "\"**\"", BINOP_EXP
},
887 {"Olt", "\"<\"", BINOP_LESS
},
888 {"Ole", "\"<=\"", BINOP_LEQ
},
889 {"Ogt", "\">\"", BINOP_GTR
},
890 {"Oge", "\">=\"", BINOP_GEQ
},
891 {"Oeq", "\"=\"", BINOP_EQUAL
},
892 {"One", "\"/=\"", BINOP_NOTEQUAL
},
893 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
894 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
895 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
896 {"Oconcat", "\"&\"", BINOP_CONCAT
},
897 {"Oabs", "\"abs\"", UNOP_ABS
},
898 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
899 {"Oadd", "\"+\"", UNOP_PLUS
},
900 {"Osubtract", "\"-\"", UNOP_NEG
},
904 /* The "encoded" form of DECODED, according to GNAT conventions. The
905 result is valid until the next call to ada_encode. If
906 THROW_ERRORS, throw an error if invalid operator name is found.
907 Otherwise, return NULL in that case. */
910 ada_encode_1 (const char *decoded
, bool throw_errors
)
912 static char *encoding_buffer
= NULL
;
913 static size_t encoding_buffer_size
= 0;
920 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
921 2 * strlen (decoded
) + 10);
924 for (p
= decoded
; *p
!= '\0'; p
+= 1)
928 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
933 const struct ada_opname_map
*mapping
;
935 for (mapping
= ada_opname_table
;
936 mapping
->encoded
!= NULL
937 && !startswith (p
, mapping
->decoded
); mapping
+= 1)
939 if (mapping
->encoded
== NULL
)
942 error (_("invalid Ada operator name: %s"), p
);
946 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
947 k
+= strlen (mapping
->encoded
);
952 encoding_buffer
[k
] = *p
;
957 encoding_buffer
[k
] = '\0';
958 return encoding_buffer
;
961 /* The "encoded" form of DECODED, according to GNAT conventions.
962 The result is valid until the next call to ada_encode. */
965 ada_encode (const char *decoded
)
967 return ada_encode_1 (decoded
, true);
970 /* Return NAME folded to lower case, or, if surrounded by single
971 quotes, unfolded, but with the quotes stripped away. Result good
975 ada_fold_name (gdb::string_view name
)
977 static char *fold_buffer
= NULL
;
978 static size_t fold_buffer_size
= 0;
980 int len
= name
.size ();
981 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
985 strncpy (fold_buffer
, name
.data () + 1, len
- 2);
986 fold_buffer
[len
- 2] = '\000';
992 for (i
= 0; i
<= len
; i
+= 1)
993 fold_buffer
[i
] = tolower (name
[i
]);
999 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1002 is_lower_alphanum (const char c
)
1004 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1007 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1008 This function saves in LEN the length of that same symbol name but
1009 without either of these suffixes:
1015 These are suffixes introduced by the compiler for entities such as
1016 nested subprogram for instance, in order to avoid name clashes.
1017 They do not serve any purpose for the debugger. */
1020 ada_remove_trailing_digits (const char *encoded
, int *len
)
1022 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1026 while (i
> 0 && isdigit (encoded
[i
]))
1028 if (i
>= 0 && encoded
[i
] == '.')
1030 else if (i
>= 0 && encoded
[i
] == '$')
1032 else if (i
>= 2 && startswith (encoded
+ i
- 2, "___"))
1034 else if (i
>= 1 && startswith (encoded
+ i
- 1, "__"))
1039 /* Remove the suffix introduced by the compiler for protected object
1043 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1045 /* Remove trailing N. */
1047 /* Protected entry subprograms are broken into two
1048 separate subprograms: The first one is unprotected, and has
1049 a 'N' suffix; the second is the protected version, and has
1050 the 'P' suffix. The second calls the first one after handling
1051 the protection. Since the P subprograms are internally generated,
1052 we leave these names undecoded, giving the user a clue that this
1053 entity is internal. */
1056 && encoded
[*len
- 1] == 'N'
1057 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1061 /* If ENCODED follows the GNAT entity encoding conventions, then return
1062 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1063 replaced by ENCODED. */
1066 ada_decode (const char *encoded
)
1072 std::string decoded
;
1074 /* With function descriptors on PPC64, the value of a symbol named
1075 ".FN", if it exists, is the entry point of the function "FN". */
1076 if (encoded
[0] == '.')
1079 /* The name of the Ada main procedure starts with "_ada_".
1080 This prefix is not part of the decoded name, so skip this part
1081 if we see this prefix. */
1082 if (startswith (encoded
, "_ada_"))
1085 /* If the name starts with '_', then it is not a properly encoded
1086 name, so do not attempt to decode it. Similarly, if the name
1087 starts with '<', the name should not be decoded. */
1088 if (encoded
[0] == '_' || encoded
[0] == '<')
1091 len0
= strlen (encoded
);
1093 ada_remove_trailing_digits (encoded
, &len0
);
1094 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1096 /* Remove the ___X.* suffix if present. Do not forget to verify that
1097 the suffix is located before the current "end" of ENCODED. We want
1098 to avoid re-matching parts of ENCODED that have previously been
1099 marked as discarded (by decrementing LEN0). */
1100 p
= strstr (encoded
, "___");
1101 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1109 /* Remove any trailing TKB suffix. It tells us that this symbol
1110 is for the body of a task, but that information does not actually
1111 appear in the decoded name. */
1113 if (len0
> 3 && startswith (encoded
+ len0
- 3, "TKB"))
1116 /* Remove any trailing TB suffix. The TB suffix is slightly different
1117 from the TKB suffix because it is used for non-anonymous task
1120 if (len0
> 2 && startswith (encoded
+ len0
- 2, "TB"))
1123 /* Remove trailing "B" suffixes. */
1124 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1126 if (len0
> 1 && startswith (encoded
+ len0
- 1, "B"))
1129 /* Make decoded big enough for possible expansion by operator name. */
1131 decoded
.resize (2 * len0
+ 1, 'X');
1133 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1135 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1138 while ((i
>= 0 && isdigit (encoded
[i
]))
1139 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1141 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1143 else if (encoded
[i
] == '$')
1147 /* The first few characters that are not alphabetic are not part
1148 of any encoding we use, so we can copy them over verbatim. */
1150 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1151 decoded
[j
] = encoded
[i
];
1156 /* Is this a symbol function? */
1157 if (at_start_name
&& encoded
[i
] == 'O')
1161 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1163 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1164 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1166 && !isalnum (encoded
[i
+ op_len
]))
1168 strcpy (&decoded
.front() + j
, ada_opname_table
[k
].decoded
);
1171 j
+= strlen (ada_opname_table
[k
].decoded
);
1175 if (ada_opname_table
[k
].encoded
!= NULL
)
1180 /* Replace "TK__" with "__", which will eventually be translated
1181 into "." (just below). */
1183 if (i
< len0
- 4 && startswith (encoded
+ i
, "TK__"))
1186 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1187 be translated into "." (just below). These are internal names
1188 generated for anonymous blocks inside which our symbol is nested. */
1190 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1191 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1192 && isdigit (encoded
[i
+4]))
1196 while (k
< len0
&& isdigit (encoded
[k
]))
1197 k
++; /* Skip any extra digit. */
1199 /* Double-check that the "__B_{DIGITS}+" sequence we found
1200 is indeed followed by "__". */
1201 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1205 /* Remove _E{DIGITS}+[sb] */
1207 /* Just as for protected object subprograms, there are 2 categories
1208 of subprograms created by the compiler for each entry. The first
1209 one implements the actual entry code, and has a suffix following
1210 the convention above; the second one implements the barrier and
1211 uses the same convention as above, except that the 'E' is replaced
1214 Just as above, we do not decode the name of barrier functions
1215 to give the user a clue that the code he is debugging has been
1216 internally generated. */
1218 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1219 && isdigit (encoded
[i
+2]))
1223 while (k
< len0
&& isdigit (encoded
[k
]))
1227 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1230 /* Just as an extra precaution, make sure that if this
1231 suffix is followed by anything else, it is a '_'.
1232 Otherwise, we matched this sequence by accident. */
1234 || (k
< len0
&& encoded
[k
] == '_'))
1239 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1240 the GNAT front-end in protected object subprograms. */
1243 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1245 /* Backtrack a bit up until we reach either the begining of
1246 the encoded name, or "__". Make sure that we only find
1247 digits or lowercase characters. */
1248 const char *ptr
= encoded
+ i
- 1;
1250 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1253 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1257 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1259 /* This is a X[bn]* sequence not separated from the previous
1260 part of the name with a non-alpha-numeric character (in other
1261 words, immediately following an alpha-numeric character), then
1262 verify that it is placed at the end of the encoded name. If
1263 not, then the encoding is not valid and we should abort the
1264 decoding. Otherwise, just skip it, it is used in body-nested
1268 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1272 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1274 /* Replace '__' by '.'. */
1282 /* It's a character part of the decoded name, so just copy it
1284 decoded
[j
] = encoded
[i
];
1291 /* Decoded names should never contain any uppercase character.
1292 Double-check this, and abort the decoding if we find one. */
1294 for (i
= 0; i
< decoded
.length(); ++i
)
1295 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1301 if (encoded
[0] == '<')
1304 decoded
= '<' + std::string(encoded
) + '>';
1309 /* Table for keeping permanent unique copies of decoded names. Once
1310 allocated, names in this table are never released. While this is a
1311 storage leak, it should not be significant unless there are massive
1312 changes in the set of decoded names in successive versions of a
1313 symbol table loaded during a single session. */
1314 static struct htab
*decoded_names_store
;
1316 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1317 in the language-specific part of GSYMBOL, if it has not been
1318 previously computed. Tries to save the decoded name in the same
1319 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1320 in any case, the decoded symbol has a lifetime at least that of
1322 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1323 const, but nevertheless modified to a semantically equivalent form
1324 when a decoded name is cached in it. */
1327 ada_decode_symbol (const struct general_symbol_info
*arg
)
1329 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1330 const char **resultp
=
1331 &gsymbol
->language_specific
.demangled_name
;
1333 if (!gsymbol
->ada_mangled
)
1335 std::string decoded
= ada_decode (gsymbol
->linkage_name ());
1336 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1338 gsymbol
->ada_mangled
= 1;
1340 if (obstack
!= NULL
)
1341 *resultp
= obstack_strdup (obstack
, decoded
.c_str ());
1344 /* Sometimes, we can't find a corresponding objfile, in
1345 which case, we put the result on the heap. Since we only
1346 decode when needed, we hope this usually does not cause a
1347 significant memory leak (FIXME). */
1349 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1350 decoded
.c_str (), INSERT
);
1353 *slot
= xstrdup (decoded
.c_str ());
1362 ada_la_decode (const char *encoded
, int options
)
1364 return xstrdup (ada_decode (encoded
).c_str ());
1371 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1372 generated by the GNAT compiler to describe the index type used
1373 for each dimension of an array, check whether it follows the latest
1374 known encoding. If not, fix it up to conform to the latest encoding.
1375 Otherwise, do nothing. This function also does nothing if
1376 INDEX_DESC_TYPE is NULL.
1378 The GNAT encoding used to describe the array index type evolved a bit.
1379 Initially, the information would be provided through the name of each
1380 field of the structure type only, while the type of these fields was
1381 described as unspecified and irrelevant. The debugger was then expected
1382 to perform a global type lookup using the name of that field in order
1383 to get access to the full index type description. Because these global
1384 lookups can be very expensive, the encoding was later enhanced to make
1385 the global lookup unnecessary by defining the field type as being
1386 the full index type description.
1388 The purpose of this routine is to allow us to support older versions
1389 of the compiler by detecting the use of the older encoding, and by
1390 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1391 we essentially replace each field's meaningless type by the associated
1395 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1399 if (index_desc_type
== NULL
)
1401 gdb_assert (index_desc_type
->num_fields () > 0);
1403 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1404 to check one field only, no need to check them all). If not, return
1407 If our INDEX_DESC_TYPE was generated using the older encoding,
1408 the field type should be a meaningless integer type whose name
1409 is not equal to the field name. */
1410 if (index_desc_type
->field (0).type ()->name () != NULL
1411 && strcmp (index_desc_type
->field (0).type ()->name (),
1412 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1415 /* Fixup each field of INDEX_DESC_TYPE. */
1416 for (i
= 0; i
< index_desc_type
->num_fields (); i
++)
1418 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1419 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1422 index_desc_type
->field (i
).set_type (raw_type
);
1426 /* The desc_* routines return primitive portions of array descriptors
1429 /* The descriptor or array type, if any, indicated by TYPE; removes
1430 level of indirection, if needed. */
1432 static struct type
*
1433 desc_base_type (struct type
*type
)
1437 type
= ada_check_typedef (type
);
1438 if (type
->code () == TYPE_CODE_TYPEDEF
)
1439 type
= ada_typedef_target_type (type
);
1442 && (type
->code () == TYPE_CODE_PTR
1443 || type
->code () == TYPE_CODE_REF
))
1444 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1449 /* True iff TYPE indicates a "thin" array pointer type. */
1452 is_thin_pntr (struct type
*type
)
1455 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1456 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1459 /* The descriptor type for thin pointer type TYPE. */
1461 static struct type
*
1462 thin_descriptor_type (struct type
*type
)
1464 struct type
*base_type
= desc_base_type (type
);
1466 if (base_type
== NULL
)
1468 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1472 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1474 if (alt_type
== NULL
)
1481 /* A pointer to the array data for thin-pointer value VAL. */
1483 static struct value
*
1484 thin_data_pntr (struct value
*val
)
1486 struct type
*type
= ada_check_typedef (value_type (val
));
1487 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1489 data_type
= lookup_pointer_type (data_type
);
1491 if (type
->code () == TYPE_CODE_PTR
)
1492 return value_cast (data_type
, value_copy (val
));
1494 return value_from_longest (data_type
, value_address (val
));
1497 /* True iff TYPE indicates a "thick" array pointer type. */
1500 is_thick_pntr (struct type
*type
)
1502 type
= desc_base_type (type
);
1503 return (type
!= NULL
&& type
->code () == TYPE_CODE_STRUCT
1504 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1507 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1508 pointer to one, the type of its bounds data; otherwise, NULL. */
1510 static struct type
*
1511 desc_bounds_type (struct type
*type
)
1515 type
= desc_base_type (type
);
1519 else if (is_thin_pntr (type
))
1521 type
= thin_descriptor_type (type
);
1524 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1526 return ada_check_typedef (r
);
1528 else if (type
->code () == TYPE_CODE_STRUCT
)
1530 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1532 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1537 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1538 one, a pointer to its bounds data. Otherwise NULL. */
1540 static struct value
*
1541 desc_bounds (struct value
*arr
)
1543 struct type
*type
= ada_check_typedef (value_type (arr
));
1545 if (is_thin_pntr (type
))
1547 struct type
*bounds_type
=
1548 desc_bounds_type (thin_descriptor_type (type
));
1551 if (bounds_type
== NULL
)
1552 error (_("Bad GNAT array descriptor"));
1554 /* NOTE: The following calculation is not really kosher, but
1555 since desc_type is an XVE-encoded type (and shouldn't be),
1556 the correct calculation is a real pain. FIXME (and fix GCC). */
1557 if (type
->code () == TYPE_CODE_PTR
)
1558 addr
= value_as_long (arr
);
1560 addr
= value_address (arr
);
1563 value_from_longest (lookup_pointer_type (bounds_type
),
1564 addr
- TYPE_LENGTH (bounds_type
));
1567 else if (is_thick_pntr (type
))
1569 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1570 _("Bad GNAT array descriptor"));
1571 struct type
*p_bounds_type
= value_type (p_bounds
);
1574 && p_bounds_type
->code () == TYPE_CODE_PTR
)
1576 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1578 if (TYPE_STUB (target_type
))
1579 p_bounds
= value_cast (lookup_pointer_type
1580 (ada_check_typedef (target_type
)),
1584 error (_("Bad GNAT array descriptor"));
1592 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1593 position of the field containing the address of the bounds data. */
1596 fat_pntr_bounds_bitpos (struct type
*type
)
1598 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1601 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1602 size of the field containing the address of the bounds data. */
1605 fat_pntr_bounds_bitsize (struct type
*type
)
1607 type
= desc_base_type (type
);
1609 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1610 return TYPE_FIELD_BITSIZE (type
, 1);
1612 return 8 * TYPE_LENGTH (ada_check_typedef (type
->field (1).type ()));
1615 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1616 pointer to one, the type of its array data (a array-with-no-bounds type);
1617 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1620 static struct type
*
1621 desc_data_target_type (struct type
*type
)
1623 type
= desc_base_type (type
);
1625 /* NOTE: The following is bogus; see comment in desc_bounds. */
1626 if (is_thin_pntr (type
))
1627 return desc_base_type (thin_descriptor_type (type
)->field (1).type ());
1628 else if (is_thick_pntr (type
))
1630 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1633 && ada_check_typedef (data_type
)->code () == TYPE_CODE_PTR
)
1634 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1640 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1643 static struct value
*
1644 desc_data (struct value
*arr
)
1646 struct type
*type
= value_type (arr
);
1648 if (is_thin_pntr (type
))
1649 return thin_data_pntr (arr
);
1650 else if (is_thick_pntr (type
))
1651 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1652 _("Bad GNAT array descriptor"));
1658 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1659 position of the field containing the address of the data. */
1662 fat_pntr_data_bitpos (struct type
*type
)
1664 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1667 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1668 size of the field containing the address of the data. */
1671 fat_pntr_data_bitsize (struct type
*type
)
1673 type
= desc_base_type (type
);
1675 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1676 return TYPE_FIELD_BITSIZE (type
, 0);
1678 return TARGET_CHAR_BIT
* TYPE_LENGTH (type
->field (0).type ());
1681 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1682 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1683 bound, if WHICH is 1. The first bound is I=1. */
1685 static struct value
*
1686 desc_one_bound (struct value
*bounds
, int i
, int which
)
1688 char bound_name
[20];
1689 xsnprintf (bound_name
, sizeof (bound_name
), "%cB%d",
1690 which
? 'U' : 'L', i
- 1);
1691 return value_struct_elt (&bounds
, NULL
, bound_name
, NULL
,
1692 _("Bad GNAT array descriptor bounds"));
1695 /* If BOUNDS is an array-bounds structure type, return the bit position
1696 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1697 bound, if WHICH is 1. The first bound is I=1. */
1700 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1702 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1705 /* If BOUNDS is an array-bounds structure type, return the bit field size
1706 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1707 bound, if WHICH is 1. The first bound is I=1. */
1710 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1712 type
= desc_base_type (type
);
1714 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1715 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1717 return 8 * TYPE_LENGTH (type
->field (2 * i
+ which
- 2).type ());
1720 /* If TYPE is the type of an array-bounds structure, the type of its
1721 Ith bound (numbering from 1). Otherwise, NULL. */
1723 static struct type
*
1724 desc_index_type (struct type
*type
, int i
)
1726 type
= desc_base_type (type
);
1728 if (type
->code () == TYPE_CODE_STRUCT
)
1730 char bound_name
[20];
1731 xsnprintf (bound_name
, sizeof (bound_name
), "LB%d", i
- 1);
1732 return lookup_struct_elt_type (type
, bound_name
, 1);
1738 /* The number of index positions in the array-bounds type TYPE.
1739 Return 0 if TYPE is NULL. */
1742 desc_arity (struct type
*type
)
1744 type
= desc_base_type (type
);
1747 return type
->num_fields () / 2;
1751 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1752 an array descriptor type (representing an unconstrained array
1756 ada_is_direct_array_type (struct type
*type
)
1760 type
= ada_check_typedef (type
);
1761 return (type
->code () == TYPE_CODE_ARRAY
1762 || ada_is_array_descriptor_type (type
));
1765 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1769 ada_is_array_type (struct type
*type
)
1772 && (type
->code () == TYPE_CODE_PTR
1773 || type
->code () == TYPE_CODE_REF
))
1774 type
= TYPE_TARGET_TYPE (type
);
1775 return ada_is_direct_array_type (type
);
1778 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1781 ada_is_simple_array_type (struct type
*type
)
1785 type
= ada_check_typedef (type
);
1786 return (type
->code () == TYPE_CODE_ARRAY
1787 || (type
->code () == TYPE_CODE_PTR
1788 && (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ()
1789 == TYPE_CODE_ARRAY
)));
1792 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1795 ada_is_array_descriptor_type (struct type
*type
)
1797 struct type
*data_type
= desc_data_target_type (type
);
1801 type
= ada_check_typedef (type
);
1802 return (data_type
!= NULL
1803 && data_type
->code () == TYPE_CODE_ARRAY
1804 && desc_arity (desc_bounds_type (type
)) > 0);
1807 /* Non-zero iff type is a partially mal-formed GNAT array
1808 descriptor. FIXME: This is to compensate for some problems with
1809 debugging output from GNAT. Re-examine periodically to see if it
1813 ada_is_bogus_array_descriptor (struct type
*type
)
1817 && type
->code () == TYPE_CODE_STRUCT
1818 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1819 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1820 && !ada_is_array_descriptor_type (type
);
1824 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1825 (fat pointer) returns the type of the array data described---specifically,
1826 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1827 in from the descriptor; otherwise, they are left unspecified. If
1828 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1829 returns NULL. The result is simply the type of ARR if ARR is not
1832 static struct type
*
1833 ada_type_of_array (struct value
*arr
, int bounds
)
1835 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1836 return decode_constrained_packed_array_type (value_type (arr
));
1838 if (!ada_is_array_descriptor_type (value_type (arr
)))
1839 return value_type (arr
);
1843 struct type
*array_type
=
1844 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1846 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1847 TYPE_FIELD_BITSIZE (array_type
, 0) =
1848 decode_packed_array_bitsize (value_type (arr
));
1854 struct type
*elt_type
;
1856 struct value
*descriptor
;
1858 elt_type
= ada_array_element_type (value_type (arr
), -1);
1859 arity
= ada_array_arity (value_type (arr
));
1861 if (elt_type
== NULL
|| arity
== 0)
1862 return ada_check_typedef (value_type (arr
));
1864 descriptor
= desc_bounds (arr
);
1865 if (value_as_long (descriptor
) == 0)
1869 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1870 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1871 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1872 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1875 create_static_range_type (range_type
, value_type (low
),
1876 longest_to_int (value_as_long (low
)),
1877 longest_to_int (value_as_long (high
)));
1878 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1880 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1882 /* We need to store the element packed bitsize, as well as
1883 recompute the array size, because it was previously
1884 computed based on the unpacked element size. */
1885 LONGEST lo
= value_as_long (low
);
1886 LONGEST hi
= value_as_long (high
);
1888 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1889 decode_packed_array_bitsize (value_type (arr
));
1890 /* If the array has no element, then the size is already
1891 zero, and does not need to be recomputed. */
1895 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
1897 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
1902 return lookup_pointer_type (elt_type
);
1906 /* If ARR does not represent an array, returns ARR unchanged.
1907 Otherwise, returns either a standard GDB array with bounds set
1908 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1909 GDB array. Returns NULL if ARR is a null fat pointer. */
1912 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1914 if (ada_is_array_descriptor_type (value_type (arr
)))
1916 struct type
*arrType
= ada_type_of_array (arr
, 1);
1918 if (arrType
== NULL
)
1920 return value_cast (arrType
, value_copy (desc_data (arr
)));
1922 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1923 return decode_constrained_packed_array (arr
);
1928 /* If ARR does not represent an array, returns ARR unchanged.
1929 Otherwise, returns a standard GDB array describing ARR (which may
1930 be ARR itself if it already is in the proper form). */
1933 ada_coerce_to_simple_array (struct value
*arr
)
1935 if (ada_is_array_descriptor_type (value_type (arr
)))
1937 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1940 error (_("Bounds unavailable for null array pointer."));
1941 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal
)));
1942 return value_ind (arrVal
);
1944 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1945 return decode_constrained_packed_array (arr
);
1950 /* If TYPE represents a GNAT array type, return it translated to an
1951 ordinary GDB array type (possibly with BITSIZE fields indicating
1952 packing). For other types, is the identity. */
1955 ada_coerce_to_simple_array_type (struct type
*type
)
1957 if (ada_is_constrained_packed_array_type (type
))
1958 return decode_constrained_packed_array_type (type
);
1960 if (ada_is_array_descriptor_type (type
))
1961 return ada_check_typedef (desc_data_target_type (type
));
1966 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1969 ada_is_packed_array_type (struct type
*type
)
1973 type
= desc_base_type (type
);
1974 type
= ada_check_typedef (type
);
1976 ada_type_name (type
) != NULL
1977 && strstr (ada_type_name (type
), "___XP") != NULL
;
1980 /* Non-zero iff TYPE represents a standard GNAT constrained
1981 packed-array type. */
1984 ada_is_constrained_packed_array_type (struct type
*type
)
1986 return ada_is_packed_array_type (type
)
1987 && !ada_is_array_descriptor_type (type
);
1990 /* Non-zero iff TYPE represents an array descriptor for a
1991 unconstrained packed-array type. */
1994 ada_is_unconstrained_packed_array_type (struct type
*type
)
1996 return ada_is_packed_array_type (type
)
1997 && ada_is_array_descriptor_type (type
);
2000 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2001 return the size of its elements in bits. */
2004 decode_packed_array_bitsize (struct type
*type
)
2006 const char *raw_name
;
2010 /* Access to arrays implemented as fat pointers are encoded as a typedef
2011 of the fat pointer type. We need the name of the fat pointer type
2012 to do the decoding, so strip the typedef layer. */
2013 if (type
->code () == TYPE_CODE_TYPEDEF
)
2014 type
= ada_typedef_target_type (type
);
2016 raw_name
= ada_type_name (ada_check_typedef (type
));
2018 raw_name
= ada_type_name (desc_base_type (type
));
2023 tail
= strstr (raw_name
, "___XP");
2024 gdb_assert (tail
!= NULL
);
2026 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2029 (_("could not understand bit size information on packed array"));
2036 /* Given that TYPE is a standard GDB array type with all bounds filled
2037 in, and that the element size of its ultimate scalar constituents
2038 (that is, either its elements, or, if it is an array of arrays, its
2039 elements' elements, etc.) is *ELT_BITS, return an identical type,
2040 but with the bit sizes of its elements (and those of any
2041 constituent arrays) recorded in the BITSIZE components of its
2042 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2045 Note that, for arrays whose index type has an XA encoding where
2046 a bound references a record discriminant, getting that discriminant,
2047 and therefore the actual value of that bound, is not possible
2048 because none of the given parameters gives us access to the record.
2049 This function assumes that it is OK in the context where it is being
2050 used to return an array whose bounds are still dynamic and where
2051 the length is arbitrary. */
2053 static struct type
*
2054 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2056 struct type
*new_elt_type
;
2057 struct type
*new_type
;
2058 struct type
*index_type_desc
;
2059 struct type
*index_type
;
2060 LONGEST low_bound
, high_bound
;
2062 type
= ada_check_typedef (type
);
2063 if (type
->code () != TYPE_CODE_ARRAY
)
2066 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2067 if (index_type_desc
)
2068 index_type
= to_fixed_range_type (index_type_desc
->field (0).type (),
2071 index_type
= type
->index_type ();
2073 new_type
= alloc_type_copy (type
);
2075 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2077 create_array_type (new_type
, new_elt_type
, index_type
);
2078 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2079 new_type
->set_name (ada_type_name (type
));
2081 if ((check_typedef (index_type
)->code () == TYPE_CODE_RANGE
2082 && is_dynamic_type (check_typedef (index_type
)))
2083 || get_discrete_bounds (index_type
, &low_bound
, &high_bound
) < 0)
2084 low_bound
= high_bound
= 0;
2085 if (high_bound
< low_bound
)
2086 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2089 *elt_bits
*= (high_bound
- low_bound
+ 1);
2090 TYPE_LENGTH (new_type
) =
2091 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2094 TYPE_FIXED_INSTANCE (new_type
) = 1;
2098 /* The array type encoded by TYPE, where
2099 ada_is_constrained_packed_array_type (TYPE). */
2101 static struct type
*
2102 decode_constrained_packed_array_type (struct type
*type
)
2104 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2107 struct type
*shadow_type
;
2111 raw_name
= ada_type_name (desc_base_type (type
));
2116 name
= (char *) alloca (strlen (raw_name
) + 1);
2117 tail
= strstr (raw_name
, "___XP");
2118 type
= desc_base_type (type
);
2120 memcpy (name
, raw_name
, tail
- raw_name
);
2121 name
[tail
- raw_name
] = '\000';
2123 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2125 if (shadow_type
== NULL
)
2127 lim_warning (_("could not find bounds information on packed array"));
2130 shadow_type
= check_typedef (shadow_type
);
2132 if (shadow_type
->code () != TYPE_CODE_ARRAY
)
2134 lim_warning (_("could not understand bounds "
2135 "information on packed array"));
2139 bits
= decode_packed_array_bitsize (type
);
2140 return constrained_packed_array_type (shadow_type
, &bits
);
2143 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2144 array, returns a simple array that denotes that array. Its type is a
2145 standard GDB array type except that the BITSIZEs of the array
2146 target types are set to the number of bits in each element, and the
2147 type length is set appropriately. */
2149 static struct value
*
2150 decode_constrained_packed_array (struct value
*arr
)
2154 /* If our value is a pointer, then dereference it. Likewise if
2155 the value is a reference. Make sure that this operation does not
2156 cause the target type to be fixed, as this would indirectly cause
2157 this array to be decoded. The rest of the routine assumes that
2158 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2159 and "value_ind" routines to perform the dereferencing, as opposed
2160 to using "ada_coerce_ref" or "ada_value_ind". */
2161 arr
= coerce_ref (arr
);
2162 if (ada_check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2163 arr
= value_ind (arr
);
2165 type
= decode_constrained_packed_array_type (value_type (arr
));
2168 error (_("can't unpack array"));
2172 if (type_byte_order (value_type (arr
)) == BFD_ENDIAN_BIG
2173 && ada_is_modular_type (value_type (arr
)))
2175 /* This is a (right-justified) modular type representing a packed
2176 array with no wrapper. In order to interpret the value through
2177 the (left-justified) packed array type we just built, we must
2178 first left-justify it. */
2179 int bit_size
, bit_pos
;
2182 mod
= ada_modulus (value_type (arr
)) - 1;
2189 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2190 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2191 bit_pos
/ HOST_CHAR_BIT
,
2192 bit_pos
% HOST_CHAR_BIT
,
2197 return coerce_unspec_val_to_type (arr
, type
);
2201 /* The value of the element of packed array ARR at the ARITY indices
2202 given in IND. ARR must be a simple array. */
2204 static struct value
*
2205 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2208 int bits
, elt_off
, bit_off
;
2209 long elt_total_bit_offset
;
2210 struct type
*elt_type
;
2214 elt_total_bit_offset
= 0;
2215 elt_type
= ada_check_typedef (value_type (arr
));
2216 for (i
= 0; i
< arity
; i
+= 1)
2218 if (elt_type
->code () != TYPE_CODE_ARRAY
2219 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2221 (_("attempt to do packed indexing of "
2222 "something other than a packed array"));
2225 struct type
*range_type
= elt_type
->index_type ();
2226 LONGEST lowerbound
, upperbound
;
2229 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2231 lim_warning (_("don't know bounds of array"));
2232 lowerbound
= upperbound
= 0;
2235 idx
= pos_atr (ind
[i
]);
2236 if (idx
< lowerbound
|| idx
> upperbound
)
2237 lim_warning (_("packed array index %ld out of bounds"),
2239 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2240 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2241 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2244 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2245 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2247 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2252 /* Non-zero iff TYPE includes negative integer values. */
2255 has_negatives (struct type
*type
)
2257 switch (type
->code ())
2262 return !TYPE_UNSIGNED (type
);
2263 case TYPE_CODE_RANGE
:
2264 return TYPE_LOW_BOUND (type
) - TYPE_RANGE_DATA (type
)->bias
< 0;
2268 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2269 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2270 the unpacked buffer.
2272 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2273 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2275 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2278 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2280 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2283 ada_unpack_from_contents (const gdb_byte
*src
, int bit_offset
, int bit_size
,
2284 gdb_byte
*unpacked
, int unpacked_len
,
2285 int is_big_endian
, int is_signed_type
,
2288 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2289 int src_idx
; /* Index into the source area */
2290 int src_bytes_left
; /* Number of source bytes left to process. */
2291 int srcBitsLeft
; /* Number of source bits left to move */
2292 int unusedLS
; /* Number of bits in next significant
2293 byte of source that are unused */
2295 int unpacked_idx
; /* Index into the unpacked buffer */
2296 int unpacked_bytes_left
; /* Number of bytes left to set in unpacked. */
2298 unsigned long accum
; /* Staging area for bits being transferred */
2299 int accumSize
; /* Number of meaningful bits in accum */
2302 /* Transmit bytes from least to most significant; delta is the direction
2303 the indices move. */
2304 int delta
= is_big_endian
? -1 : 1;
2306 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2308 if ((bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
> unpacked_len
)
2309 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2310 bit_size
, unpacked_len
);
2312 srcBitsLeft
= bit_size
;
2313 src_bytes_left
= src_len
;
2314 unpacked_bytes_left
= unpacked_len
;
2319 src_idx
= src_len
- 1;
2321 && ((src
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2325 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2331 unpacked_idx
= unpacked_len
- 1;
2335 /* Non-scalar values must be aligned at a byte boundary... */
2337 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2338 /* ... And are placed at the beginning (most-significant) bytes
2340 unpacked_idx
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2341 unpacked_bytes_left
= unpacked_idx
+ 1;
2346 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2348 src_idx
= unpacked_idx
= 0;
2349 unusedLS
= bit_offset
;
2352 if (is_signed_type
&& (src
[src_len
- 1] & (1 << sign_bit_offset
)))
2357 while (src_bytes_left
> 0)
2359 /* Mask for removing bits of the next source byte that are not
2360 part of the value. */
2361 unsigned int unusedMSMask
=
2362 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2364 /* Sign-extend bits for this byte. */
2365 unsigned int signMask
= sign
& ~unusedMSMask
;
2368 (((src
[src_idx
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2369 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2370 if (accumSize
>= HOST_CHAR_BIT
)
2372 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2373 accumSize
-= HOST_CHAR_BIT
;
2374 accum
>>= HOST_CHAR_BIT
;
2375 unpacked_bytes_left
-= 1;
2376 unpacked_idx
+= delta
;
2378 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2380 src_bytes_left
-= 1;
2383 while (unpacked_bytes_left
> 0)
2385 accum
|= sign
<< accumSize
;
2386 unpacked
[unpacked_idx
] = accum
& ~(~0UL << HOST_CHAR_BIT
);
2387 accumSize
-= HOST_CHAR_BIT
;
2390 accum
>>= HOST_CHAR_BIT
;
2391 unpacked_bytes_left
-= 1;
2392 unpacked_idx
+= delta
;
2396 /* Create a new value of type TYPE from the contents of OBJ starting
2397 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2398 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2399 assigning through the result will set the field fetched from.
2400 VALADDR is ignored unless OBJ is NULL, in which case,
2401 VALADDR+OFFSET must address the start of storage containing the
2402 packed value. The value returned in this case is never an lval.
2403 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2406 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2407 long offset
, int bit_offset
, int bit_size
,
2411 const gdb_byte
*src
; /* First byte containing data to unpack */
2413 const int is_scalar
= is_scalar_type (type
);
2414 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2415 gdb::byte_vector staging
;
2417 type
= ada_check_typedef (type
);
2420 src
= valaddr
+ offset
;
2422 src
= value_contents (obj
) + offset
;
2424 if (is_dynamic_type (type
))
2426 /* The length of TYPE might by dynamic, so we need to resolve
2427 TYPE in order to know its actual size, which we then use
2428 to create the contents buffer of the value we return.
2429 The difficulty is that the data containing our object is
2430 packed, and therefore maybe not at a byte boundary. So, what
2431 we do, is unpack the data into a byte-aligned buffer, and then
2432 use that buffer as our object's value for resolving the type. */
2433 int staging_len
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2434 staging
.resize (staging_len
);
2436 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2437 staging
.data (), staging
.size (),
2438 is_big_endian
, has_negatives (type
),
2440 type
= resolve_dynamic_type (type
, staging
, 0);
2441 if (TYPE_LENGTH (type
) < (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
)
2443 /* This happens when the length of the object is dynamic,
2444 and is actually smaller than the space reserved for it.
2445 For instance, in an array of variant records, the bit_size
2446 we're given is the array stride, which is constant and
2447 normally equal to the maximum size of its element.
2448 But, in reality, each element only actually spans a portion
2450 bit_size
= TYPE_LENGTH (type
) * HOST_CHAR_BIT
;
2456 v
= allocate_value (type
);
2457 src
= valaddr
+ offset
;
2459 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2461 int src_len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2464 v
= value_at (type
, value_address (obj
) + offset
);
2465 buf
= (gdb_byte
*) alloca (src_len
);
2466 read_memory (value_address (v
), buf
, src_len
);
2471 v
= allocate_value (type
);
2472 src
= value_contents (obj
) + offset
;
2477 long new_offset
= offset
;
2479 set_value_component_location (v
, obj
);
2480 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2481 set_value_bitsize (v
, bit_size
);
2482 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2485 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2487 set_value_offset (v
, new_offset
);
2489 /* Also set the parent value. This is needed when trying to
2490 assign a new value (in inferior memory). */
2491 set_value_parent (v
, obj
);
2494 set_value_bitsize (v
, bit_size
);
2495 unpacked
= value_contents_writeable (v
);
2499 memset (unpacked
, 0, TYPE_LENGTH (type
));
2503 if (staging
.size () == TYPE_LENGTH (type
))
2505 /* Small short-cut: If we've unpacked the data into a buffer
2506 of the same size as TYPE's length, then we can reuse that,
2507 instead of doing the unpacking again. */
2508 memcpy (unpacked
, staging
.data (), staging
.size ());
2511 ada_unpack_from_contents (src
, bit_offset
, bit_size
,
2512 unpacked
, TYPE_LENGTH (type
),
2513 is_big_endian
, has_negatives (type
), is_scalar
);
2518 /* Store the contents of FROMVAL into the location of TOVAL.
2519 Return a new value with the location of TOVAL and contents of
2520 FROMVAL. Handles assignment into packed fields that have
2521 floating-point or non-scalar types. */
2523 static struct value
*
2524 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2526 struct type
*type
= value_type (toval
);
2527 int bits
= value_bitsize (toval
);
2529 toval
= ada_coerce_ref (toval
);
2530 fromval
= ada_coerce_ref (fromval
);
2532 if (ada_is_direct_array_type (value_type (toval
)))
2533 toval
= ada_coerce_to_simple_array (toval
);
2534 if (ada_is_direct_array_type (value_type (fromval
)))
2535 fromval
= ada_coerce_to_simple_array (fromval
);
2537 if (!deprecated_value_modifiable (toval
))
2538 error (_("Left operand of assignment is not a modifiable lvalue."));
2540 if (VALUE_LVAL (toval
) == lval_memory
2542 && (type
->code () == TYPE_CODE_FLT
2543 || type
->code () == TYPE_CODE_STRUCT
))
2545 int len
= (value_bitpos (toval
)
2546 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2548 gdb_byte
*buffer
= (gdb_byte
*) alloca (len
);
2550 CORE_ADDR to_addr
= value_address (toval
);
2552 if (type
->code () == TYPE_CODE_FLT
)
2553 fromval
= value_cast (type
, fromval
);
2555 read_memory (to_addr
, buffer
, len
);
2556 from_size
= value_bitsize (fromval
);
2558 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2560 const int is_big_endian
= type_byte_order (type
) == BFD_ENDIAN_BIG
;
2561 ULONGEST from_offset
= 0;
2562 if (is_big_endian
&& is_scalar_type (value_type (fromval
)))
2563 from_offset
= from_size
- bits
;
2564 copy_bitwise (buffer
, value_bitpos (toval
),
2565 value_contents (fromval
), from_offset
,
2566 bits
, is_big_endian
);
2567 write_memory_with_notification (to_addr
, buffer
, len
);
2569 val
= value_copy (toval
);
2570 memcpy (value_contents_raw (val
), value_contents (fromval
),
2571 TYPE_LENGTH (type
));
2572 deprecated_set_value_type (val
, type
);
2577 return value_assign (toval
, fromval
);
2581 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2582 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2583 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2584 COMPONENT, and not the inferior's memory. The current contents
2585 of COMPONENT are ignored.
2587 Although not part of the initial design, this function also works
2588 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2589 had a null address, and COMPONENT had an address which is equal to
2590 its offset inside CONTAINER. */
2593 value_assign_to_component (struct value
*container
, struct value
*component
,
2596 LONGEST offset_in_container
=
2597 (LONGEST
) (value_address (component
) - value_address (container
));
2598 int bit_offset_in_container
=
2599 value_bitpos (component
) - value_bitpos (container
);
2602 val
= value_cast (value_type (component
), val
);
2604 if (value_bitsize (component
) == 0)
2605 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2607 bits
= value_bitsize (component
);
2609 if (type_byte_order (value_type (container
)) == BFD_ENDIAN_BIG
)
2613 if (is_scalar_type (check_typedef (value_type (component
))))
2615 = TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
;
2618 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2619 value_bitpos (container
) + bit_offset_in_container
,
2620 value_contents (val
), src_offset
, bits
, 1);
2623 copy_bitwise (value_contents_writeable (container
) + offset_in_container
,
2624 value_bitpos (container
) + bit_offset_in_container
,
2625 value_contents (val
), 0, bits
, 0);
2628 /* Determine if TYPE is an access to an unconstrained array. */
2631 ada_is_access_to_unconstrained_array (struct type
*type
)
2633 return (type
->code () == TYPE_CODE_TYPEDEF
2634 && is_thick_pntr (ada_typedef_target_type (type
)));
2637 /* The value of the element of array ARR at the ARITY indices given in IND.
2638 ARR may be either a simple array, GNAT array descriptor, or pointer
2642 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2646 struct type
*elt_type
;
2648 elt
= ada_coerce_to_simple_array (arr
);
2650 elt_type
= ada_check_typedef (value_type (elt
));
2651 if (elt_type
->code () == TYPE_CODE_ARRAY
2652 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2653 return value_subscript_packed (elt
, arity
, ind
);
2655 for (k
= 0; k
< arity
; k
+= 1)
2657 struct type
*saved_elt_type
= TYPE_TARGET_TYPE (elt_type
);
2659 if (elt_type
->code () != TYPE_CODE_ARRAY
)
2660 error (_("too many subscripts (%d expected)"), k
);
2662 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2664 if (ada_is_access_to_unconstrained_array (saved_elt_type
)
2665 && value_type (elt
)->code () != TYPE_CODE_TYPEDEF
)
2667 /* The element is a typedef to an unconstrained array,
2668 except that the value_subscript call stripped the
2669 typedef layer. The typedef layer is GNAT's way to
2670 specify that the element is, at the source level, an
2671 access to the unconstrained array, rather than the
2672 unconstrained array. So, we need to restore that
2673 typedef layer, which we can do by forcing the element's
2674 type back to its original type. Otherwise, the returned
2675 value is going to be printed as the array, rather
2676 than as an access. Another symptom of the same issue
2677 would be that an expression trying to dereference the
2678 element would also be improperly rejected. */
2679 deprecated_set_value_type (elt
, saved_elt_type
);
2682 elt_type
= ada_check_typedef (value_type (elt
));
2688 /* Assuming ARR is a pointer to a GDB array, the value of the element
2689 of *ARR at the ARITY indices given in IND.
2690 Does not read the entire array into memory.
2692 Note: Unlike what one would expect, this function is used instead of
2693 ada_value_subscript for basically all non-packed array types. The reason
2694 for this is that a side effect of doing our own pointer arithmetics instead
2695 of relying on value_subscript is that there is no implicit typedef peeling.
2696 This is important for arrays of array accesses, where it allows us to
2697 preserve the fact that the array's element is an array access, where the
2698 access part os encoded in a typedef layer. */
2700 static struct value
*
2701 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2704 struct value
*array_ind
= ada_value_ind (arr
);
2706 = check_typedef (value_enclosing_type (array_ind
));
2708 if (type
->code () == TYPE_CODE_ARRAY
2709 && TYPE_FIELD_BITSIZE (type
, 0) > 0)
2710 return value_subscript_packed (array_ind
, arity
, ind
);
2712 for (k
= 0; k
< arity
; k
+= 1)
2716 if (type
->code () != TYPE_CODE_ARRAY
)
2717 error (_("too many subscripts (%d expected)"), k
);
2718 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2720 get_discrete_bounds (type
->index_type (), &lwb
, &upb
);
2721 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2722 type
= TYPE_TARGET_TYPE (type
);
2725 return value_ind (arr
);
2728 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2729 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2730 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2731 this array is LOW, as per Ada rules. */
2732 static struct value
*
2733 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2736 struct type
*type0
= ada_check_typedef (type
);
2737 struct type
*base_index_type
= TYPE_TARGET_TYPE (type0
->index_type ());
2738 struct type
*index_type
2739 = create_static_range_type (NULL
, base_index_type
, low
, high
);
2740 struct type
*slice_type
= create_array_type_with_stride
2741 (NULL
, TYPE_TARGET_TYPE (type0
), index_type
,
2742 type0
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2743 TYPE_FIELD_BITSIZE (type0
, 0));
2744 int base_low
= ada_discrete_type_low_bound (type0
->index_type ());
2745 LONGEST base_low_pos
, low_pos
;
2748 if (!discrete_position (base_index_type
, low
, &low_pos
)
2749 || !discrete_position (base_index_type
, base_low
, &base_low_pos
))
2751 warning (_("unable to get positions in slice, use bounds instead"));
2753 base_low_pos
= base_low
;
2756 base
= value_as_address (array_ptr
)
2757 + ((low_pos
- base_low_pos
)
2758 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0
)));
2759 return value_at_lazy (slice_type
, base
);
2763 static struct value
*
2764 ada_value_slice (struct value
*array
, int low
, int high
)
2766 struct type
*type
= ada_check_typedef (value_type (array
));
2767 struct type
*base_index_type
= TYPE_TARGET_TYPE (type
->index_type ());
2768 struct type
*index_type
2769 = create_static_range_type (NULL
, type
->index_type (), low
, high
);
2770 struct type
*slice_type
= create_array_type_with_stride
2771 (NULL
, TYPE_TARGET_TYPE (type
), index_type
,
2772 type
->dyn_prop (DYN_PROP_BYTE_STRIDE
),
2773 TYPE_FIELD_BITSIZE (type
, 0));
2774 LONGEST low_pos
, high_pos
;
2776 if (!discrete_position (base_index_type
, low
, &low_pos
)
2777 || !discrete_position (base_index_type
, high
, &high_pos
))
2779 warning (_("unable to get positions in slice, use bounds instead"));
2784 return value_cast (slice_type
,
2785 value_slice (array
, low
, high_pos
- low_pos
+ 1));
2788 /* If type is a record type in the form of a standard GNAT array
2789 descriptor, returns the number of dimensions for type. If arr is a
2790 simple array, returns the number of "array of"s that prefix its
2791 type designation. Otherwise, returns 0. */
2794 ada_array_arity (struct type
*type
)
2801 type
= desc_base_type (type
);
2804 if (type
->code () == TYPE_CODE_STRUCT
)
2805 return desc_arity (desc_bounds_type (type
));
2807 while (type
->code () == TYPE_CODE_ARRAY
)
2810 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2816 /* If TYPE is a record type in the form of a standard GNAT array
2817 descriptor or a simple array type, returns the element type for
2818 TYPE after indexing by NINDICES indices, or by all indices if
2819 NINDICES is -1. Otherwise, returns NULL. */
2822 ada_array_element_type (struct type
*type
, int nindices
)
2824 type
= desc_base_type (type
);
2826 if (type
->code () == TYPE_CODE_STRUCT
)
2829 struct type
*p_array_type
;
2831 p_array_type
= desc_data_target_type (type
);
2833 k
= ada_array_arity (type
);
2837 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2838 if (nindices
>= 0 && k
> nindices
)
2840 while (k
> 0 && p_array_type
!= NULL
)
2842 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2845 return p_array_type
;
2847 else if (type
->code () == TYPE_CODE_ARRAY
)
2849 while (nindices
!= 0 && type
->code () == TYPE_CODE_ARRAY
)
2851 type
= TYPE_TARGET_TYPE (type
);
2860 /* The type of nth index in arrays of given type (n numbering from 1).
2861 Does not examine memory. Throws an error if N is invalid or TYPE
2862 is not an array type. NAME is the name of the Ada attribute being
2863 evaluated ('range, 'first, 'last, or 'length); it is used in building
2864 the error message. */
2866 static struct type
*
2867 ada_index_type (struct type
*type
, int n
, const char *name
)
2869 struct type
*result_type
;
2871 type
= desc_base_type (type
);
2873 if (n
< 0 || n
> ada_array_arity (type
))
2874 error (_("invalid dimension number to '%s"), name
);
2876 if (ada_is_simple_array_type (type
))
2880 for (i
= 1; i
< n
; i
+= 1)
2881 type
= TYPE_TARGET_TYPE (type
);
2882 result_type
= TYPE_TARGET_TYPE (type
->index_type ());
2883 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2884 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2885 perhaps stabsread.c would make more sense. */
2886 if (result_type
&& result_type
->code () == TYPE_CODE_UNDEF
)
2891 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2892 if (result_type
== NULL
)
2893 error (_("attempt to take bound of something that is not an array"));
2899 /* Given that arr is an array type, returns the lower bound of the
2900 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2901 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2902 array-descriptor type. It works for other arrays with bounds supplied
2903 by run-time quantities other than discriminants. */
2906 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
2908 struct type
*type
, *index_type_desc
, *index_type
;
2911 gdb_assert (which
== 0 || which
== 1);
2913 if (ada_is_constrained_packed_array_type (arr_type
))
2914 arr_type
= decode_constrained_packed_array_type (arr_type
);
2916 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2917 return (LONGEST
) - which
;
2919 if (arr_type
->code () == TYPE_CODE_PTR
)
2920 type
= TYPE_TARGET_TYPE (arr_type
);
2924 if (TYPE_FIXED_INSTANCE (type
))
2926 /* The array has already been fixed, so we do not need to
2927 check the parallel ___XA type again. That encoding has
2928 already been applied, so ignore it now. */
2929 index_type_desc
= NULL
;
2933 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2934 ada_fixup_array_indexes_type (index_type_desc
);
2937 if (index_type_desc
!= NULL
)
2938 index_type
= to_fixed_range_type (index_type_desc
->field (n
- 1).type (),
2942 struct type
*elt_type
= check_typedef (type
);
2944 for (i
= 1; i
< n
; i
++)
2945 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
2947 index_type
= elt_type
->index_type ();
2951 (LONGEST
) (which
== 0
2952 ? ada_discrete_type_low_bound (index_type
)
2953 : ada_discrete_type_high_bound (index_type
));
2956 /* Given that arr is an array value, returns the lower bound of the
2957 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2958 WHICH is 1. This routine will also work for arrays with bounds
2959 supplied by run-time quantities other than discriminants. */
2962 ada_array_bound (struct value
*arr
, int n
, int which
)
2964 struct type
*arr_type
;
2966 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2967 arr
= value_ind (arr
);
2968 arr_type
= value_enclosing_type (arr
);
2970 if (ada_is_constrained_packed_array_type (arr_type
))
2971 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
2972 else if (ada_is_simple_array_type (arr_type
))
2973 return ada_array_bound_from_type (arr_type
, n
, which
);
2975 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
2978 /* Given that arr is an array value, returns the length of the
2979 nth index. This routine will also work for arrays with bounds
2980 supplied by run-time quantities other than discriminants.
2981 Does not work for arrays indexed by enumeration types with representation
2982 clauses at the moment. */
2985 ada_array_length (struct value
*arr
, int n
)
2987 struct type
*arr_type
, *index_type
;
2990 if (check_typedef (value_type (arr
))->code () == TYPE_CODE_PTR
)
2991 arr
= value_ind (arr
);
2992 arr_type
= value_enclosing_type (arr
);
2994 if (ada_is_constrained_packed_array_type (arr_type
))
2995 return ada_array_length (decode_constrained_packed_array (arr
), n
);
2997 if (ada_is_simple_array_type (arr_type
))
2999 low
= ada_array_bound_from_type (arr_type
, n
, 0);
3000 high
= ada_array_bound_from_type (arr_type
, n
, 1);
3004 low
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0));
3005 high
= value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1));
3008 arr_type
= check_typedef (arr_type
);
3009 index_type
= ada_index_type (arr_type
, n
, "length");
3010 if (index_type
!= NULL
)
3012 struct type
*base_type
;
3013 if (index_type
->code () == TYPE_CODE_RANGE
)
3014 base_type
= TYPE_TARGET_TYPE (index_type
);
3016 base_type
= index_type
;
3018 low
= pos_atr (value_from_longest (base_type
, low
));
3019 high
= pos_atr (value_from_longest (base_type
, high
));
3021 return high
- low
+ 1;
3024 /* An array whose type is that of ARR_TYPE (an array type), with
3025 bounds LOW to HIGH, but whose contents are unimportant. If HIGH is
3026 less than LOW, then LOW-1 is used. */
3028 static struct value
*
3029 empty_array (struct type
*arr_type
, int low
, int high
)
3031 struct type
*arr_type0
= ada_check_typedef (arr_type
);
3032 struct type
*index_type
3033 = create_static_range_type
3034 (NULL
, TYPE_TARGET_TYPE (arr_type0
->index_type ()), low
,
3035 high
< low
? low
- 1 : high
);
3036 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
3038 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3042 /* Name resolution */
3044 /* The "decoded" name for the user-definable Ada operator corresponding
3048 ada_decoded_op_name (enum exp_opcode op
)
3052 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3054 if (ada_opname_table
[i
].op
== op
)
3055 return ada_opname_table
[i
].decoded
;
3057 error (_("Could not find operator name for opcode"));
3060 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3061 in a listing of choices during disambiguation (see sort_choices, below).
3062 The idea is that overloadings of a subprogram name from the
3063 same package should sort in their source order. We settle for ordering
3064 such symbols by their trailing number (__N or $N). */
3067 encoded_ordered_before (const char *N0
, const char *N1
)
3071 else if (N0
== NULL
)
3077 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3079 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3081 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3082 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3087 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3090 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3092 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3093 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3095 return (strcmp (N0
, N1
) < 0);
3099 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3103 sort_choices (struct block_symbol syms
[], int nsyms
)
3107 for (i
= 1; i
< nsyms
; i
+= 1)
3109 struct block_symbol sym
= syms
[i
];
3112 for (j
= i
- 1; j
>= 0; j
-= 1)
3114 if (encoded_ordered_before (syms
[j
].symbol
->linkage_name (),
3115 sym
.symbol
->linkage_name ()))
3117 syms
[j
+ 1] = syms
[j
];
3123 /* Whether GDB should display formals and return types for functions in the
3124 overloads selection menu. */
3125 static bool print_signatures
= true;
3127 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3128 all but functions, the signature is just the name of the symbol. For
3129 functions, this is the name of the function, the list of types for formals
3130 and the return type (if any). */
3133 ada_print_symbol_signature (struct ui_file
*stream
, struct symbol
*sym
,
3134 const struct type_print_options
*flags
)
3136 struct type
*type
= SYMBOL_TYPE (sym
);
3138 fprintf_filtered (stream
, "%s", sym
->print_name ());
3139 if (!print_signatures
3141 || type
->code () != TYPE_CODE_FUNC
)
3144 if (type
->num_fields () > 0)
3148 fprintf_filtered (stream
, " (");
3149 for (i
= 0; i
< type
->num_fields (); ++i
)
3152 fprintf_filtered (stream
, "; ");
3153 ada_print_type (type
->field (i
).type (), NULL
, stream
, -1, 0,
3156 fprintf_filtered (stream
, ")");
3158 if (TYPE_TARGET_TYPE (type
) != NULL
3159 && TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_VOID
)
3161 fprintf_filtered (stream
, " return ");
3162 ada_print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, -1, 0, flags
);
3166 /* Read and validate a set of numeric choices from the user in the
3167 range 0 .. N_CHOICES-1. Place the results in increasing
3168 order in CHOICES[0 .. N-1], and return N.
3170 The user types choices as a sequence of numbers on one line
3171 separated by blanks, encoding them as follows:
3173 + A choice of 0 means to cancel the selection, throwing an error.
3174 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3175 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3177 The user is not allowed to choose more than MAX_RESULTS values.
3179 ANNOTATION_SUFFIX, if present, is used to annotate the input
3180 prompts (for use with the -f switch). */
3183 get_selections (int *choices
, int n_choices
, int max_results
,
3184 int is_all_choice
, const char *annotation_suffix
)
3189 int first_choice
= is_all_choice
? 2 : 1;
3191 prompt
= getenv ("PS2");
3195 args
= command_line_input (prompt
, annotation_suffix
);
3198 error_no_arg (_("one or more choice numbers"));
3202 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3203 order, as given in args. Choices are validated. */
3209 args
= skip_spaces (args
);
3210 if (*args
== '\0' && n_chosen
== 0)
3211 error_no_arg (_("one or more choice numbers"));
3212 else if (*args
== '\0')
3215 choice
= strtol (args
, &args2
, 10);
3216 if (args
== args2
|| choice
< 0
3217 || choice
> n_choices
+ first_choice
- 1)
3218 error (_("Argument must be choice number"));
3222 error (_("cancelled"));
3224 if (choice
< first_choice
)
3226 n_chosen
= n_choices
;
3227 for (j
= 0; j
< n_choices
; j
+= 1)
3231 choice
-= first_choice
;
3233 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3237 if (j
< 0 || choice
!= choices
[j
])
3241 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3242 choices
[k
+ 1] = choices
[k
];
3243 choices
[j
+ 1] = choice
;
3248 if (n_chosen
> max_results
)
3249 error (_("Select no more than %d of the above"), max_results
);
3254 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3255 by asking the user (if necessary), returning the number selected,
3256 and setting the first elements of SYMS items. Error if no symbols
3259 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3260 to be re-integrated one of these days. */
3263 user_select_syms (struct block_symbol
*syms
, int nsyms
, int max_results
)
3266 int *chosen
= XALLOCAVEC (int , nsyms
);
3268 int first_choice
= (max_results
== 1) ? 1 : 2;
3269 const char *select_mode
= multiple_symbols_select_mode ();
3271 if (max_results
< 1)
3272 error (_("Request to select 0 symbols!"));
3276 if (select_mode
== multiple_symbols_cancel
)
3278 canceled because the command is ambiguous\n\
3279 See set/show multiple-symbol."));
3281 /* If select_mode is "all", then return all possible symbols.
3282 Only do that if more than one symbol can be selected, of course.
3283 Otherwise, display the menu as usual. */
3284 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3287 printf_filtered (_("[0] cancel\n"));
3288 if (max_results
> 1)
3289 printf_filtered (_("[1] all\n"));
3291 sort_choices (syms
, nsyms
);
3293 for (i
= 0; i
< nsyms
; i
+= 1)
3295 if (syms
[i
].symbol
== NULL
)
3298 if (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_BLOCK
)
3300 struct symtab_and_line sal
=
3301 find_function_start_sal (syms
[i
].symbol
, 1);
3303 printf_filtered ("[%d] ", i
+ first_choice
);
3304 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3305 &type_print_raw_options
);
3306 if (sal
.symtab
== NULL
)
3307 printf_filtered (_(" at %p[<no source file available>%p]:%d\n"),
3308 metadata_style
.style ().ptr (), nullptr, sal
.line
);
3312 styled_string (file_name_style
.style (),
3313 symtab_to_filename_for_display (sal
.symtab
)),
3320 (SYMBOL_CLASS (syms
[i
].symbol
) == LOC_CONST
3321 && SYMBOL_TYPE (syms
[i
].symbol
) != NULL
3322 && SYMBOL_TYPE (syms
[i
].symbol
)->code () == TYPE_CODE_ENUM
);
3323 struct symtab
*symtab
= NULL
;
3325 if (SYMBOL_OBJFILE_OWNED (syms
[i
].symbol
))
3326 symtab
= symbol_symtab (syms
[i
].symbol
);
3328 if (SYMBOL_LINE (syms
[i
].symbol
) != 0 && symtab
!= NULL
)
3330 printf_filtered ("[%d] ", i
+ first_choice
);
3331 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3332 &type_print_raw_options
);
3333 printf_filtered (_(" at %s:%d\n"),
3334 symtab_to_filename_for_display (symtab
),
3335 SYMBOL_LINE (syms
[i
].symbol
));
3337 else if (is_enumeral
3338 && SYMBOL_TYPE (syms
[i
].symbol
)->name () != NULL
)
3340 printf_filtered (("[%d] "), i
+ first_choice
);
3341 ada_print_type (SYMBOL_TYPE (syms
[i
].symbol
), NULL
,
3342 gdb_stdout
, -1, 0, &type_print_raw_options
);
3343 printf_filtered (_("'(%s) (enumeral)\n"),
3344 syms
[i
].symbol
->print_name ());
3348 printf_filtered ("[%d] ", i
+ first_choice
);
3349 ada_print_symbol_signature (gdb_stdout
, syms
[i
].symbol
,
3350 &type_print_raw_options
);
3353 printf_filtered (is_enumeral
3354 ? _(" in %s (enumeral)\n")
3356 symtab_to_filename_for_display (symtab
));
3358 printf_filtered (is_enumeral
3359 ? _(" (enumeral)\n")
3365 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3368 for (i
= 0; i
< n_chosen
; i
+= 1)
3369 syms
[i
] = syms
[chosen
[i
]];
3374 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3375 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3376 undefined namespace) and converts operators that are
3377 user-defined into appropriate function calls. If CONTEXT_TYPE is
3378 non-null, it provides a preferred result type [at the moment, only
3379 type void has any effect---causing procedures to be preferred over
3380 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3381 return type is preferred. May change (expand) *EXP. */
3384 resolve (expression_up
*expp
, int void_context_p
, int parse_completion
,
3385 innermost_block_tracker
*tracker
)
3387 struct type
*context_type
= NULL
;
3391 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
3393 resolve_subexp (expp
, &pc
, 1, context_type
, parse_completion
, tracker
);
3396 /* Resolve the operator of the subexpression beginning at
3397 position *POS of *EXPP. "Resolving" consists of replacing
3398 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3399 with their resolutions, replacing built-in operators with
3400 function calls to user-defined operators, where appropriate, and,
3401 when DEPROCEDURE_P is non-zero, converting function-valued variables
3402 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3403 are as in ada_resolve, above. */
3405 static struct value
*
3406 resolve_subexp (expression_up
*expp
, int *pos
, int deprocedure_p
,
3407 struct type
*context_type
, int parse_completion
,
3408 innermost_block_tracker
*tracker
)
3412 struct expression
*exp
; /* Convenience: == *expp. */
3413 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3414 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3415 int nargs
; /* Number of operands. */
3422 /* Pass one: resolve operands, saving their types and updating *pos,
3427 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3428 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3433 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3435 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3440 resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3445 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
),
3446 parse_completion
, tracker
);
3449 case OP_ATR_MODULUS
:
3459 case TERNOP_IN_RANGE
:
3460 case BINOP_IN_BOUNDS
:
3466 case OP_DISCRETE_RANGE
:
3468 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3477 arg1
= resolve_subexp (expp
, pos
, 0, NULL
, parse_completion
, tracker
);
3479 resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
, tracker
);
3481 resolve_subexp (expp
, pos
, 1, value_type (arg1
), parse_completion
,
3499 case BINOP_LOGICAL_AND
:
3500 case BINOP_LOGICAL_OR
:
3501 case BINOP_BITWISE_AND
:
3502 case BINOP_BITWISE_IOR
:
3503 case BINOP_BITWISE_XOR
:
3506 case BINOP_NOTEQUAL
:
3513 case BINOP_SUBSCRIPT
:
3521 case UNOP_LOGICAL_NOT
:
3531 case OP_VAR_MSYM_VALUE
:
3538 case OP_INTERNALVAR
:
3548 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3551 case STRUCTOP_STRUCT
:
3552 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3565 error (_("Unexpected operator during name resolution"));
3568 argvec
= XALLOCAVEC (struct value
*, nargs
+ 1);
3569 for (i
= 0; i
< nargs
; i
+= 1)
3570 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
, parse_completion
,
3575 /* Pass two: perform any resolution on principal operator. */
3582 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3584 std::vector
<struct block_symbol
> candidates
;
3588 ada_lookup_symbol_list (exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3589 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3592 if (n_candidates
> 1)
3594 /* Types tend to get re-introduced locally, so if there
3595 are any local symbols that are not types, first filter
3598 for (j
= 0; j
< n_candidates
; j
+= 1)
3599 switch (SYMBOL_CLASS (candidates
[j
].symbol
))
3604 case LOC_REGPARM_ADDR
:
3612 if (j
< n_candidates
)
3615 while (j
< n_candidates
)
3617 if (SYMBOL_CLASS (candidates
[j
].symbol
) == LOC_TYPEDEF
)
3619 candidates
[j
] = candidates
[n_candidates
- 1];
3628 if (n_candidates
== 0)
3629 error (_("No definition found for %s"),
3630 exp
->elts
[pc
+ 2].symbol
->print_name ());
3631 else if (n_candidates
== 1)
3633 else if (deprocedure_p
3634 && !is_nonfunction (candidates
.data (), n_candidates
))
3636 i
= ada_resolve_function
3637 (candidates
.data (), n_candidates
, NULL
, 0,
3638 exp
->elts
[pc
+ 2].symbol
->linkage_name (),
3639 context_type
, parse_completion
);
3641 error (_("Could not find a match for %s"),
3642 exp
->elts
[pc
+ 2].symbol
->print_name ());
3646 printf_filtered (_("Multiple matches for %s\n"),
3647 exp
->elts
[pc
+ 2].symbol
->print_name ());
3648 user_select_syms (candidates
.data (), n_candidates
, 1);
3652 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3653 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].symbol
;
3654 tracker
->update (candidates
[i
]);
3658 && (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)->code ()
3661 replace_operator_with_call (expp
, pc
, 0, 4,
3662 exp
->elts
[pc
+ 2].symbol
,
3663 exp
->elts
[pc
+ 1].block
);
3670 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3671 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3673 std::vector
<struct block_symbol
> candidates
;
3677 ada_lookup_symbol_list (exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3678 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3681 if (n_candidates
== 1)
3685 i
= ada_resolve_function
3686 (candidates
.data (), n_candidates
,
3688 exp
->elts
[pc
+ 5].symbol
->linkage_name (),
3689 context_type
, parse_completion
);
3691 error (_("Could not find a match for %s"),
3692 exp
->elts
[pc
+ 5].symbol
->print_name ());
3695 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3696 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].symbol
;
3697 tracker
->update (candidates
[i
]);
3708 case BINOP_BITWISE_AND
:
3709 case BINOP_BITWISE_IOR
:
3710 case BINOP_BITWISE_XOR
:
3712 case BINOP_NOTEQUAL
:
3720 case UNOP_LOGICAL_NOT
:
3722 if (possible_user_operator_p (op
, argvec
))
3724 std::vector
<struct block_symbol
> candidates
;
3728 ada_lookup_symbol_list (ada_decoded_op_name (op
),
3732 i
= ada_resolve_function (candidates
.data (), n_candidates
, argvec
,
3733 nargs
, ada_decoded_op_name (op
), NULL
,
3738 replace_operator_with_call (expp
, pc
, nargs
, 1,
3739 candidates
[i
].symbol
,
3740 candidates
[i
].block
);
3751 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
3752 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS
,
3753 exp
->elts
[pc
+ 1].objfile
,
3754 exp
->elts
[pc
+ 2].msymbol
);
3756 return evaluate_subexp_type (exp
, pos
);
3759 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3760 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3762 /* The term "match" here is rather loose. The match is heuristic and
3766 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3768 ftype
= ada_check_typedef (ftype
);
3769 atype
= ada_check_typedef (atype
);
3771 if (ftype
->code () == TYPE_CODE_REF
)
3772 ftype
= TYPE_TARGET_TYPE (ftype
);
3773 if (atype
->code () == TYPE_CODE_REF
)
3774 atype
= TYPE_TARGET_TYPE (atype
);
3776 switch (ftype
->code ())
3779 return ftype
->code () == atype
->code ();
3781 if (atype
->code () == TYPE_CODE_PTR
)
3782 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3783 TYPE_TARGET_TYPE (atype
), 0);
3786 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3788 case TYPE_CODE_ENUM
:
3789 case TYPE_CODE_RANGE
:
3790 switch (atype
->code ())
3793 case TYPE_CODE_ENUM
:
3794 case TYPE_CODE_RANGE
:
3800 case TYPE_CODE_ARRAY
:
3801 return (atype
->code () == TYPE_CODE_ARRAY
3802 || ada_is_array_descriptor_type (atype
));
3804 case TYPE_CODE_STRUCT
:
3805 if (ada_is_array_descriptor_type (ftype
))
3806 return (atype
->code () == TYPE_CODE_ARRAY
3807 || ada_is_array_descriptor_type (atype
));
3809 return (atype
->code () == TYPE_CODE_STRUCT
3810 && !ada_is_array_descriptor_type (atype
));
3812 case TYPE_CODE_UNION
:
3814 return (atype
->code () == ftype
->code ());
3818 /* Return non-zero if the formals of FUNC "sufficiently match" the
3819 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3820 may also be an enumeral, in which case it is treated as a 0-
3821 argument function. */
3824 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3827 struct type
*func_type
= SYMBOL_TYPE (func
);
3829 if (SYMBOL_CLASS (func
) == LOC_CONST
3830 && func_type
->code () == TYPE_CODE_ENUM
)
3831 return (n_actuals
== 0);
3832 else if (func_type
== NULL
|| func_type
->code () != TYPE_CODE_FUNC
)
3835 if (func_type
->num_fields () != n_actuals
)
3838 for (i
= 0; i
< n_actuals
; i
+= 1)
3840 if (actuals
[i
] == NULL
)
3844 struct type
*ftype
= ada_check_typedef (func_type
->field (i
).type ());
3845 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3847 if (!ada_type_match (ftype
, atype
, 1))
3854 /* False iff function type FUNC_TYPE definitely does not produce a value
3855 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3856 FUNC_TYPE is not a valid function type with a non-null return type
3857 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3860 return_match (struct type
*func_type
, struct type
*context_type
)
3862 struct type
*return_type
;
3864 if (func_type
== NULL
)
3867 if (func_type
->code () == TYPE_CODE_FUNC
)
3868 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3870 return_type
= get_base_type (func_type
);
3871 if (return_type
== NULL
)
3874 context_type
= get_base_type (context_type
);
3876 if (return_type
->code () == TYPE_CODE_ENUM
)
3877 return context_type
== NULL
|| return_type
== context_type
;
3878 else if (context_type
== NULL
)
3879 return return_type
->code () != TYPE_CODE_VOID
;
3881 return return_type
->code () == context_type
->code ();
3885 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3886 function (if any) that matches the types of the NARGS arguments in
3887 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3888 that returns that type, then eliminate matches that don't. If
3889 CONTEXT_TYPE is void and there is at least one match that does not
3890 return void, eliminate all matches that do.
3892 Asks the user if there is more than one match remaining. Returns -1
3893 if there is no such symbol or none is selected. NAME is used
3894 solely for messages. May re-arrange and modify SYMS in
3895 the process; the index returned is for the modified vector. */
3898 ada_resolve_function (struct block_symbol syms
[],
3899 int nsyms
, struct value
**args
, int nargs
,
3900 const char *name
, struct type
*context_type
,
3901 int parse_completion
)
3905 int m
; /* Number of hits */
3908 /* In the first pass of the loop, we only accept functions matching
3909 context_type. If none are found, we add a second pass of the loop
3910 where every function is accepted. */
3911 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3913 for (k
= 0; k
< nsyms
; k
+= 1)
3915 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].symbol
));
3917 if (ada_args_match (syms
[k
].symbol
, args
, nargs
)
3918 && (fallback
|| return_match (type
, context_type
)))
3926 /* If we got multiple matches, ask the user which one to use. Don't do this
3927 interactive thing during completion, though, as the purpose of the
3928 completion is providing a list of all possible matches. Prompting the
3929 user to filter it down would be completely unexpected in this case. */
3932 else if (m
> 1 && !parse_completion
)
3934 printf_filtered (_("Multiple matches for %s\n"), name
);
3935 user_select_syms (syms
, m
, 1);
3941 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3942 on the function identified by SYM and BLOCK, and taking NARGS
3943 arguments. Update *EXPP as needed to hold more space. */
3946 replace_operator_with_call (expression_up
*expp
, int pc
, int nargs
,
3947 int oplen
, struct symbol
*sym
,
3948 const struct block
*block
)
3950 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3951 symbol, -oplen for operator being replaced). */
3952 struct expression
*newexp
= (struct expression
*)
3953 xzalloc (sizeof (struct expression
)
3954 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3955 struct expression
*exp
= expp
->get ();
3957 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3958 newexp
->language_defn
= exp
->language_defn
;
3959 newexp
->gdbarch
= exp
->gdbarch
;
3960 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3961 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3962 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3964 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3965 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3967 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3968 newexp
->elts
[pc
+ 4].block
= block
;
3969 newexp
->elts
[pc
+ 5].symbol
= sym
;
3971 expp
->reset (newexp
);
3974 /* Type-class predicates */
3976 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3980 numeric_type_p (struct type
*type
)
3986 switch (type
->code ())
3991 case TYPE_CODE_RANGE
:
3992 return (type
== TYPE_TARGET_TYPE (type
)
3993 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
4000 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4003 integer_type_p (struct type
*type
)
4009 switch (type
->code ())
4013 case TYPE_CODE_RANGE
:
4014 return (type
== TYPE_TARGET_TYPE (type
)
4015 || integer_type_p (TYPE_TARGET_TYPE (type
)));
4022 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4025 scalar_type_p (struct type
*type
)
4031 switch (type
->code ())
4034 case TYPE_CODE_RANGE
:
4035 case TYPE_CODE_ENUM
:
4044 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4047 discrete_type_p (struct type
*type
)
4053 switch (type
->code ())
4056 case TYPE_CODE_RANGE
:
4057 case TYPE_CODE_ENUM
:
4058 case TYPE_CODE_BOOL
:
4066 /* Returns non-zero if OP with operands in the vector ARGS could be
4067 a user-defined function. Errs on the side of pre-defined operators
4068 (i.e., result 0). */
4071 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
4073 struct type
*type0
=
4074 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
4075 struct type
*type1
=
4076 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
4090 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
4094 case BINOP_BITWISE_AND
:
4095 case BINOP_BITWISE_IOR
:
4096 case BINOP_BITWISE_XOR
:
4097 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
4100 case BINOP_NOTEQUAL
:
4105 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4108 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4111 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4115 case UNOP_LOGICAL_NOT
:
4117 return (!numeric_type_p (type0
));
4126 1. In the following, we assume that a renaming type's name may
4127 have an ___XD suffix. It would be nice if this went away at some
4129 2. We handle both the (old) purely type-based representation of
4130 renamings and the (new) variable-based encoding. At some point,
4131 it is devoutly to be hoped that the former goes away
4132 (FIXME: hilfinger-2007-07-09).
4133 3. Subprogram renamings are not implemented, although the XRS
4134 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4136 /* If SYM encodes a renaming,
4138 <renaming> renames <renamed entity>,
4140 sets *LEN to the length of the renamed entity's name,
4141 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4142 the string describing the subcomponent selected from the renamed
4143 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4144 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4145 are undefined). Otherwise, returns a value indicating the category
4146 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4147 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4148 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4149 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4150 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4151 may be NULL, in which case they are not assigned.
4153 [Currently, however, GCC does not generate subprogram renamings.] */
4155 enum ada_renaming_category
4156 ada_parse_renaming (struct symbol
*sym
,
4157 const char **renamed_entity
, int *len
,
4158 const char **renaming_expr
)
4160 enum ada_renaming_category kind
;
4165 return ADA_NOT_RENAMING
;
4166 switch (SYMBOL_CLASS (sym
))
4169 return ADA_NOT_RENAMING
;
4173 case LOC_OPTIMIZED_OUT
:
4174 info
= strstr (sym
->linkage_name (), "___XR");
4176 return ADA_NOT_RENAMING
;
4180 kind
= ADA_OBJECT_RENAMING
;
4184 kind
= ADA_EXCEPTION_RENAMING
;
4188 kind
= ADA_PACKAGE_RENAMING
;
4192 kind
= ADA_SUBPROGRAM_RENAMING
;
4196 return ADA_NOT_RENAMING
;
4200 if (renamed_entity
!= NULL
)
4201 *renamed_entity
= info
;
4202 suffix
= strstr (info
, "___XE");
4203 if (suffix
== NULL
|| suffix
== info
)
4204 return ADA_NOT_RENAMING
;
4206 *len
= strlen (info
) - strlen (suffix
);
4208 if (renaming_expr
!= NULL
)
4209 *renaming_expr
= suffix
;
4213 /* Compute the value of the given RENAMING_SYM, which is expected to
4214 be a symbol encoding a renaming expression. BLOCK is the block
4215 used to evaluate the renaming. */
4217 static struct value
*
4218 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4219 const struct block
*block
)
4221 const char *sym_name
;
4223 sym_name
= renaming_sym
->linkage_name ();
4224 expression_up expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4225 return evaluate_expression (expr
.get ());
4229 /* Evaluation: Function Calls */
4231 /* Return an lvalue containing the value VAL. This is the identity on
4232 lvalues, and otherwise has the side-effect of allocating memory
4233 in the inferior where a copy of the value contents is copied. */
4235 static struct value
*
4236 ensure_lval (struct value
*val
)
4238 if (VALUE_LVAL (val
) == not_lval
4239 || VALUE_LVAL (val
) == lval_internalvar
)
4241 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4242 const CORE_ADDR addr
=
4243 value_as_long (value_allocate_space_in_inferior (len
));
4245 VALUE_LVAL (val
) = lval_memory
;
4246 set_value_address (val
, addr
);
4247 write_memory (addr
, value_contents (val
), len
);
4253 /* Given ARG, a value of type (pointer or reference to a)*
4254 structure/union, extract the component named NAME from the ultimate
4255 target structure/union and return it as a value with its
4258 The routine searches for NAME among all members of the structure itself
4259 and (recursively) among all members of any wrapper members
4262 If NO_ERR, then simply return NULL in case of error, rather than
4265 static struct value
*
4266 ada_value_struct_elt (struct value
*arg
, const char *name
, int no_err
)
4268 struct type
*t
, *t1
;
4273 t1
= t
= ada_check_typedef (value_type (arg
));
4274 if (t
->code () == TYPE_CODE_REF
)
4276 t1
= TYPE_TARGET_TYPE (t
);
4279 t1
= ada_check_typedef (t1
);
4280 if (t1
->code () == TYPE_CODE_PTR
)
4282 arg
= coerce_ref (arg
);
4287 while (t
->code () == TYPE_CODE_PTR
)
4289 t1
= TYPE_TARGET_TYPE (t
);
4292 t1
= ada_check_typedef (t1
);
4293 if (t1
->code () == TYPE_CODE_PTR
)
4295 arg
= value_ind (arg
);
4302 if (t1
->code () != TYPE_CODE_STRUCT
&& t1
->code () != TYPE_CODE_UNION
)
4306 v
= ada_search_struct_field (name
, arg
, 0, t
);
4309 int bit_offset
, bit_size
, byte_offset
;
4310 struct type
*field_type
;
4313 if (t
->code () == TYPE_CODE_PTR
)
4314 address
= value_address (ada_value_ind (arg
));
4316 address
= value_address (ada_coerce_ref (arg
));
4318 /* Check to see if this is a tagged type. We also need to handle
4319 the case where the type is a reference to a tagged type, but
4320 we have to be careful to exclude pointers to tagged types.
4321 The latter should be shown as usual (as a pointer), whereas
4322 a reference should mostly be transparent to the user. */
4324 if (ada_is_tagged_type (t1
, 0)
4325 || (t1
->code () == TYPE_CODE_REF
4326 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1
), 0)))
4328 /* We first try to find the searched field in the current type.
4329 If not found then let's look in the fixed type. */
4331 if (!find_struct_field (name
, t1
, 0,
4332 &field_type
, &byte_offset
, &bit_offset
,
4341 /* Convert to fixed type in all cases, so that we have proper
4342 offsets to each field in unconstrained record types. */
4343 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
,
4344 address
, NULL
, check_tag
);
4346 if (find_struct_field (name
, t1
, 0,
4347 &field_type
, &byte_offset
, &bit_offset
,
4352 if (t
->code () == TYPE_CODE_REF
)
4353 arg
= ada_coerce_ref (arg
);
4355 arg
= ada_value_ind (arg
);
4356 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
4357 bit_offset
, bit_size
,
4361 v
= value_at_lazy (field_type
, address
+ byte_offset
);
4365 if (v
!= NULL
|| no_err
)
4368 error (_("There is no member named %s."), name
);
4374 error (_("Attempt to extract a component of "
4375 "a value that is not a record."));
4378 /* Return the value ACTUAL, converted to be an appropriate value for a
4379 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4380 allocating any necessary descriptors (fat pointers), or copies of
4381 values not residing in memory, updating it as needed. */
4384 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4386 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4387 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4388 struct type
*formal_target
=
4389 formal_type
->code () == TYPE_CODE_PTR
4390 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4391 struct type
*actual_target
=
4392 actual_type
->code () == TYPE_CODE_PTR
4393 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4395 if (ada_is_array_descriptor_type (formal_target
)
4396 && actual_target
->code () == TYPE_CODE_ARRAY
)
4397 return make_array_descriptor (formal_type
, actual
);
4398 else if (formal_type
->code () == TYPE_CODE_PTR
4399 || formal_type
->code () == TYPE_CODE_REF
)
4401 struct value
*result
;
4403 if (formal_target
->code () == TYPE_CODE_ARRAY
4404 && ada_is_array_descriptor_type (actual_target
))
4405 result
= desc_data (actual
);
4406 else if (formal_type
->code () != TYPE_CODE_PTR
)
4408 if (VALUE_LVAL (actual
) != lval_memory
)
4412 actual_type
= ada_check_typedef (value_type (actual
));
4413 val
= allocate_value (actual_type
);
4414 memcpy ((char *) value_contents_raw (val
),
4415 (char *) value_contents (actual
),
4416 TYPE_LENGTH (actual_type
));
4417 actual
= ensure_lval (val
);
4419 result
= value_addr (actual
);
4423 return value_cast_pointers (formal_type
, result
, 0);
4425 else if (actual_type
->code () == TYPE_CODE_PTR
)
4426 return ada_value_ind (actual
);
4427 else if (ada_is_aligner_type (formal_type
))
4429 /* We need to turn this parameter into an aligner type
4431 struct value
*aligner
= allocate_value (formal_type
);
4432 struct value
*component
= ada_value_struct_elt (aligner
, "F", 0);
4434 value_assign_to_component (aligner
, component
, actual
);
4441 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4442 type TYPE. This is usually an inefficient no-op except on some targets
4443 (such as AVR) where the representation of a pointer and an address
4447 value_pointer (struct value
*value
, struct type
*type
)
4449 struct gdbarch
*gdbarch
= get_type_arch (type
);
4450 unsigned len
= TYPE_LENGTH (type
);
4451 gdb_byte
*buf
= (gdb_byte
*) alloca (len
);
4454 addr
= value_address (value
);
4455 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4456 addr
= extract_unsigned_integer (buf
, len
, type_byte_order (type
));
4461 /* Push a descriptor of type TYPE for array value ARR on the stack at
4462 *SP, updating *SP to reflect the new descriptor. Return either
4463 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4464 to-descriptor type rather than a descriptor type), a struct value *
4465 representing a pointer to this descriptor. */
4467 static struct value
*
4468 make_array_descriptor (struct type
*type
, struct value
*arr
)
4470 struct type
*bounds_type
= desc_bounds_type (type
);
4471 struct type
*desc_type
= desc_base_type (type
);
4472 struct value
*descriptor
= allocate_value (desc_type
);
4473 struct value
*bounds
= allocate_value (bounds_type
);
4476 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4479 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4480 ada_array_bound (arr
, i
, 0),
4481 desc_bound_bitpos (bounds_type
, i
, 0),
4482 desc_bound_bitsize (bounds_type
, i
, 0));
4483 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4484 ada_array_bound (arr
, i
, 1),
4485 desc_bound_bitpos (bounds_type
, i
, 1),
4486 desc_bound_bitsize (bounds_type
, i
, 1));
4489 bounds
= ensure_lval (bounds
);
4491 modify_field (value_type (descriptor
),
4492 value_contents_writeable (descriptor
),
4493 value_pointer (ensure_lval (arr
),
4494 desc_type
->field (0).type ()),
4495 fat_pntr_data_bitpos (desc_type
),
4496 fat_pntr_data_bitsize (desc_type
));
4498 modify_field (value_type (descriptor
),
4499 value_contents_writeable (descriptor
),
4500 value_pointer (bounds
,
4501 desc_type
->field (1).type ()),
4502 fat_pntr_bounds_bitpos (desc_type
),
4503 fat_pntr_bounds_bitsize (desc_type
));
4505 descriptor
= ensure_lval (descriptor
);
4507 if (type
->code () == TYPE_CODE_PTR
)
4508 return value_addr (descriptor
);
4513 /* Symbol Cache Module */
4515 /* Performance measurements made as of 2010-01-15 indicate that
4516 this cache does bring some noticeable improvements. Depending
4517 on the type of entity being printed, the cache can make it as much
4518 as an order of magnitude faster than without it.
4520 The descriptive type DWARF extension has significantly reduced
4521 the need for this cache, at least when DWARF is being used. However,
4522 even in this case, some expensive name-based symbol searches are still
4523 sometimes necessary - to find an XVZ variable, mostly. */
4525 /* Initialize the contents of SYM_CACHE. */
4528 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4530 obstack_init (&sym_cache
->cache_space
);
4531 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4534 /* Free the memory used by SYM_CACHE. */
4537 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4539 obstack_free (&sym_cache
->cache_space
, NULL
);
4543 /* Return the symbol cache associated to the given program space PSPACE.
4544 If not allocated for this PSPACE yet, allocate and initialize one. */
4546 static struct ada_symbol_cache
*
4547 ada_get_symbol_cache (struct program_space
*pspace
)
4549 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4551 if (pspace_data
->sym_cache
== NULL
)
4553 pspace_data
->sym_cache
= XCNEW (struct ada_symbol_cache
);
4554 ada_init_symbol_cache (pspace_data
->sym_cache
);
4557 return pspace_data
->sym_cache
;
4560 /* Clear all entries from the symbol cache. */
4563 ada_clear_symbol_cache (void)
4565 struct ada_symbol_cache
*sym_cache
4566 = ada_get_symbol_cache (current_program_space
);
4568 obstack_free (&sym_cache
->cache_space
, NULL
);
4569 ada_init_symbol_cache (sym_cache
);
4572 /* Search our cache for an entry matching NAME and DOMAIN.
4573 Return it if found, or NULL otherwise. */
4575 static struct cache_entry
**
4576 find_entry (const char *name
, domain_enum domain
)
4578 struct ada_symbol_cache
*sym_cache
4579 = ada_get_symbol_cache (current_program_space
);
4580 int h
= msymbol_hash (name
) % HASH_SIZE
;
4581 struct cache_entry
**e
;
4583 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4585 if (domain
== (*e
)->domain
&& strcmp (name
, (*e
)->name
) == 0)
4591 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4592 Return 1 if found, 0 otherwise.
4594 If an entry was found and SYM is not NULL, set *SYM to the entry's
4595 SYM. Same principle for BLOCK if not NULL. */
4598 lookup_cached_symbol (const char *name
, domain_enum domain
,
4599 struct symbol
**sym
, const struct block
**block
)
4601 struct cache_entry
**e
= find_entry (name
, domain
);
4608 *block
= (*e
)->block
;
4612 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4613 in domain DOMAIN, save this result in our symbol cache. */
4616 cache_symbol (const char *name
, domain_enum domain
, struct symbol
*sym
,
4617 const struct block
*block
)
4619 struct ada_symbol_cache
*sym_cache
4620 = ada_get_symbol_cache (current_program_space
);
4622 struct cache_entry
*e
;
4624 /* Symbols for builtin types don't have a block.
4625 For now don't cache such symbols. */
4626 if (sym
!= NULL
&& !SYMBOL_OBJFILE_OWNED (sym
))
4629 /* If the symbol is a local symbol, then do not cache it, as a search
4630 for that symbol depends on the context. To determine whether
4631 the symbol is local or not, we check the block where we found it
4632 against the global and static blocks of its associated symtab. */
4634 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4635 GLOBAL_BLOCK
) != block
4636 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym
)),
4637 STATIC_BLOCK
) != block
)
4640 h
= msymbol_hash (name
) % HASH_SIZE
;
4641 e
= XOBNEW (&sym_cache
->cache_space
, cache_entry
);
4642 e
->next
= sym_cache
->root
[h
];
4643 sym_cache
->root
[h
] = e
;
4644 e
->name
= obstack_strdup (&sym_cache
->cache_space
, name
);
4652 /* Return the symbol name match type that should be used used when
4653 searching for all symbols matching LOOKUP_NAME.
4655 LOOKUP_NAME is expected to be a symbol name after transformation
4658 static symbol_name_match_type
4659 name_match_type_from_name (const char *lookup_name
)
4661 return (strstr (lookup_name
, "__") == NULL
4662 ? symbol_name_match_type::WILD
4663 : symbol_name_match_type::FULL
);
4666 /* Return the result of a standard (literal, C-like) lookup of NAME in
4667 given DOMAIN, visible from lexical block BLOCK. */
4669 static struct symbol
*
4670 standard_lookup (const char *name
, const struct block
*block
,
4673 /* Initialize it just to avoid a GCC false warning. */
4674 struct block_symbol sym
= {};
4676 if (lookup_cached_symbol (name
, domain
, &sym
.symbol
, NULL
))
4678 ada_lookup_encoded_symbol (name
, block
, domain
, &sym
);
4679 cache_symbol (name
, domain
, sym
.symbol
, sym
.block
);
4684 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4685 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4686 since they contend in overloading in the same way. */
4688 is_nonfunction (struct block_symbol syms
[], int n
)
4692 for (i
= 0; i
< n
; i
+= 1)
4693 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_FUNC
4694 && (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
4695 || SYMBOL_CLASS (syms
[i
].symbol
) != LOC_CONST
))
4701 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4702 struct types. Otherwise, they may not. */
4705 equiv_types (struct type
*type0
, struct type
*type1
)
4709 if (type0
== NULL
|| type1
== NULL
4710 || type0
->code () != type1
->code ())
4712 if ((type0
->code () == TYPE_CODE_STRUCT
4713 || type0
->code () == TYPE_CODE_ENUM
)
4714 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4715 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4721 /* True iff SYM0 represents the same entity as SYM1, or one that is
4722 no more defined than that of SYM1. */
4725 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4729 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4730 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4733 switch (SYMBOL_CLASS (sym0
))
4739 struct type
*type0
= SYMBOL_TYPE (sym0
);
4740 struct type
*type1
= SYMBOL_TYPE (sym1
);
4741 const char *name0
= sym0
->linkage_name ();
4742 const char *name1
= sym1
->linkage_name ();
4743 int len0
= strlen (name0
);
4746 type0
->code () == type1
->code ()
4747 && (equiv_types (type0
, type1
)
4748 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4749 && startswith (name1
+ len0
, "___XV")));
4752 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4753 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4757 const char *name0
= sym0
->linkage_name ();
4758 const char *name1
= sym1
->linkage_name ();
4759 return (strcmp (name0
, name1
) == 0
4760 && SYMBOL_VALUE_ADDRESS (sym0
) == SYMBOL_VALUE_ADDRESS (sym1
));
4768 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4769 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4772 add_defn_to_vec (struct obstack
*obstackp
,
4774 const struct block
*block
)
4777 struct block_symbol
*prevDefns
= defns_collected (obstackp
, 0);
4779 /* Do not try to complete stub types, as the debugger is probably
4780 already scanning all symbols matching a certain name at the
4781 time when this function is called. Trying to replace the stub
4782 type by its associated full type will cause us to restart a scan
4783 which may lead to an infinite recursion. Instead, the client
4784 collecting the matching symbols will end up collecting several
4785 matches, with at least one of them complete. It can then filter
4786 out the stub ones if needed. */
4788 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4790 if (lesseq_defined_than (sym
, prevDefns
[i
].symbol
))
4792 else if (lesseq_defined_than (prevDefns
[i
].symbol
, sym
))
4794 prevDefns
[i
].symbol
= sym
;
4795 prevDefns
[i
].block
= block
;
4801 struct block_symbol info
;
4805 obstack_grow (obstackp
, &info
, sizeof (struct block_symbol
));
4809 /* Number of block_symbol structures currently collected in current vector in
4813 num_defns_collected (struct obstack
*obstackp
)
4815 return obstack_object_size (obstackp
) / sizeof (struct block_symbol
);
4818 /* Vector of block_symbol structures currently collected in current vector in
4819 OBSTACKP. If FINISH, close off the vector and return its final address. */
4821 static struct block_symbol
*
4822 defns_collected (struct obstack
*obstackp
, int finish
)
4825 return (struct block_symbol
*) obstack_finish (obstackp
);
4827 return (struct block_symbol
*) obstack_base (obstackp
);
4830 /* Return a bound minimal symbol matching NAME according to Ada
4831 decoding rules. Returns an invalid symbol if there is no such
4832 minimal symbol. Names prefixed with "standard__" are handled
4833 specially: "standard__" is first stripped off, and only static and
4834 global symbols are searched. */
4836 struct bound_minimal_symbol
4837 ada_lookup_simple_minsym (const char *name
)
4839 struct bound_minimal_symbol result
;
4841 memset (&result
, 0, sizeof (result
));
4843 symbol_name_match_type match_type
= name_match_type_from_name (name
);
4844 lookup_name_info
lookup_name (name
, match_type
);
4846 symbol_name_matcher_ftype
*match_name
4847 = ada_get_symbol_name_matcher (lookup_name
);
4849 for (objfile
*objfile
: current_program_space
->objfiles ())
4851 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
4853 if (match_name (msymbol
->linkage_name (), lookup_name
, NULL
)
4854 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4856 result
.minsym
= msymbol
;
4857 result
.objfile
= objfile
;
4866 /* For all subprograms that statically enclose the subprogram of the
4867 selected frame, add symbols matching identifier NAME in DOMAIN
4868 and their blocks to the list of data in OBSTACKP, as for
4869 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4870 with a wildcard prefix. */
4873 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4874 const lookup_name_info
&lookup_name
,
4879 /* True if TYPE is definitely an artificial type supplied to a symbol
4880 for which no debugging information was given in the symbol file. */
4883 is_nondebugging_type (struct type
*type
)
4885 const char *name
= ada_type_name (type
);
4887 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4890 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4891 that are deemed "identical" for practical purposes.
4893 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4894 types and that their number of enumerals is identical (in other
4895 words, type1->num_fields () == type2->num_fields ()). */
4898 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4902 /* The heuristic we use here is fairly conservative. We consider
4903 that 2 enumerate types are identical if they have the same
4904 number of enumerals and that all enumerals have the same
4905 underlying value and name. */
4907 /* All enums in the type should have an identical underlying value. */
4908 for (i
= 0; i
< type1
->num_fields (); i
++)
4909 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4912 /* All enumerals should also have the same name (modulo any numerical
4914 for (i
= 0; i
< type1
->num_fields (); i
++)
4916 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4917 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4918 int len_1
= strlen (name_1
);
4919 int len_2
= strlen (name_2
);
4921 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4922 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4924 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4925 TYPE_FIELD_NAME (type2
, i
),
4933 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4934 that are deemed "identical" for practical purposes. Sometimes,
4935 enumerals are not strictly identical, but their types are so similar
4936 that they can be considered identical.
4938 For instance, consider the following code:
4940 type Color is (Black, Red, Green, Blue, White);
4941 type RGB_Color is new Color range Red .. Blue;
4943 Type RGB_Color is a subrange of an implicit type which is a copy
4944 of type Color. If we call that implicit type RGB_ColorB ("B" is
4945 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4946 As a result, when an expression references any of the enumeral
4947 by name (Eg. "print green"), the expression is technically
4948 ambiguous and the user should be asked to disambiguate. But
4949 doing so would only hinder the user, since it wouldn't matter
4950 what choice he makes, the outcome would always be the same.
4951 So, for practical purposes, we consider them as the same. */
4954 symbols_are_identical_enums (const std::vector
<struct block_symbol
> &syms
)
4958 /* Before performing a thorough comparison check of each type,
4959 we perform a series of inexpensive checks. We expect that these
4960 checks will quickly fail in the vast majority of cases, and thus
4961 help prevent the unnecessary use of a more expensive comparison.
4962 Said comparison also expects us to make some of these checks
4963 (see ada_identical_enum_types_p). */
4965 /* Quick check: All symbols should have an enum type. */
4966 for (i
= 0; i
< syms
.size (); i
++)
4967 if (SYMBOL_TYPE (syms
[i
].symbol
)->code () != TYPE_CODE_ENUM
)
4970 /* Quick check: They should all have the same value. */
4971 for (i
= 1; i
< syms
.size (); i
++)
4972 if (SYMBOL_VALUE (syms
[i
].symbol
) != SYMBOL_VALUE (syms
[0].symbol
))
4975 /* Quick check: They should all have the same number of enumerals. */
4976 for (i
= 1; i
< syms
.size (); i
++)
4977 if (SYMBOL_TYPE (syms
[i
].symbol
)->num_fields ()
4978 != SYMBOL_TYPE (syms
[0].symbol
)->num_fields ())
4981 /* All the sanity checks passed, so we might have a set of
4982 identical enumeration types. Perform a more complete
4983 comparison of the type of each symbol. */
4984 for (i
= 1; i
< syms
.size (); i
++)
4985 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].symbol
),
4986 SYMBOL_TYPE (syms
[0].symbol
)))
4992 /* Remove any non-debugging symbols in SYMS that definitely
4993 duplicate other symbols in the list (The only case I know of where
4994 this happens is when object files containing stabs-in-ecoff are
4995 linked with files containing ordinary ecoff debugging symbols (or no
4996 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4997 Returns the number of items in the modified list. */
5000 remove_extra_symbols (std::vector
<struct block_symbol
> *syms
)
5004 /* We should never be called with less than 2 symbols, as there
5005 cannot be any extra symbol in that case. But it's easy to
5006 handle, since we have nothing to do in that case. */
5007 if (syms
->size () < 2)
5008 return syms
->size ();
5011 while (i
< syms
->size ())
5015 /* If two symbols have the same name and one of them is a stub type,
5016 the get rid of the stub. */
5018 if (TYPE_STUB (SYMBOL_TYPE ((*syms
)[i
].symbol
))
5019 && (*syms
)[i
].symbol
->linkage_name () != NULL
)
5021 for (j
= 0; j
< syms
->size (); j
++)
5024 && !TYPE_STUB (SYMBOL_TYPE ((*syms
)[j
].symbol
))
5025 && (*syms
)[j
].symbol
->linkage_name () != NULL
5026 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5027 (*syms
)[j
].symbol
->linkage_name ()) == 0)
5032 /* Two symbols with the same name, same class and same address
5033 should be identical. */
5035 else if ((*syms
)[i
].symbol
->linkage_name () != NULL
5036 && SYMBOL_CLASS ((*syms
)[i
].symbol
) == LOC_STATIC
5037 && is_nondebugging_type (SYMBOL_TYPE ((*syms
)[i
].symbol
)))
5039 for (j
= 0; j
< syms
->size (); j
+= 1)
5042 && (*syms
)[j
].symbol
->linkage_name () != NULL
5043 && strcmp ((*syms
)[i
].symbol
->linkage_name (),
5044 (*syms
)[j
].symbol
->linkage_name ()) == 0
5045 && SYMBOL_CLASS ((*syms
)[i
].symbol
)
5046 == SYMBOL_CLASS ((*syms
)[j
].symbol
)
5047 && SYMBOL_VALUE_ADDRESS ((*syms
)[i
].symbol
)
5048 == SYMBOL_VALUE_ADDRESS ((*syms
)[j
].symbol
))
5054 syms
->erase (syms
->begin () + i
);
5059 /* If all the remaining symbols are identical enumerals, then
5060 just keep the first one and discard the rest.
5062 Unlike what we did previously, we do not discard any entry
5063 unless they are ALL identical. This is because the symbol
5064 comparison is not a strict comparison, but rather a practical
5065 comparison. If all symbols are considered identical, then
5066 we can just go ahead and use the first one and discard the rest.
5067 But if we cannot reduce the list to a single element, we have
5068 to ask the user to disambiguate anyways. And if we have to
5069 present a multiple-choice menu, it's less confusing if the list
5070 isn't missing some choices that were identical and yet distinct. */
5071 if (symbols_are_identical_enums (*syms
))
5074 return syms
->size ();
5077 /* Given a type that corresponds to a renaming entity, use the type name
5078 to extract the scope (package name or function name, fully qualified,
5079 and following the GNAT encoding convention) where this renaming has been
5083 xget_renaming_scope (struct type
*renaming_type
)
5085 /* The renaming types adhere to the following convention:
5086 <scope>__<rename>___<XR extension>.
5087 So, to extract the scope, we search for the "___XR" extension,
5088 and then backtrack until we find the first "__". */
5090 const char *name
= renaming_type
->name ();
5091 const char *suffix
= strstr (name
, "___XR");
5094 /* Now, backtrack a bit until we find the first "__". Start looking
5095 at suffix - 3, as the <rename> part is at least one character long. */
5097 for (last
= suffix
- 3; last
> name
; last
--)
5098 if (last
[0] == '_' && last
[1] == '_')
5101 /* Make a copy of scope and return it. */
5102 return std::string (name
, last
);
5105 /* Return nonzero if NAME corresponds to a package name. */
5108 is_package_name (const char *name
)
5110 /* Here, We take advantage of the fact that no symbols are generated
5111 for packages, while symbols are generated for each function.
5112 So the condition for NAME represent a package becomes equivalent
5113 to NAME not existing in our list of symbols. There is only one
5114 small complication with library-level functions (see below). */
5116 /* If it is a function that has not been defined at library level,
5117 then we should be able to look it up in the symbols. */
5118 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
5121 /* Library-level function names start with "_ada_". See if function
5122 "_ada_" followed by NAME can be found. */
5124 /* Do a quick check that NAME does not contain "__", since library-level
5125 functions names cannot contain "__" in them. */
5126 if (strstr (name
, "__") != NULL
)
5129 std::string fun_name
= string_printf ("_ada_%s", name
);
5131 return (standard_lookup (fun_name
.c_str (), NULL
, VAR_DOMAIN
) == NULL
);
5134 /* Return nonzero if SYM corresponds to a renaming entity that is
5135 not visible from FUNCTION_NAME. */
5138 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
5140 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
5143 std::string scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
5145 /* If the rename has been defined in a package, then it is visible. */
5146 if (is_package_name (scope
.c_str ()))
5149 /* Check that the rename is in the current function scope by checking
5150 that its name starts with SCOPE. */
5152 /* If the function name starts with "_ada_", it means that it is
5153 a library-level function. Strip this prefix before doing the
5154 comparison, as the encoding for the renaming does not contain
5156 if (startswith (function_name
, "_ada_"))
5159 return !startswith (function_name
, scope
.c_str ());
5162 /* Remove entries from SYMS that corresponds to a renaming entity that
5163 is not visible from the function associated with CURRENT_BLOCK or
5164 that is superfluous due to the presence of more specific renaming
5165 information. Places surviving symbols in the initial entries of
5166 SYMS and returns the number of surviving symbols.
5169 First, in cases where an object renaming is implemented as a
5170 reference variable, GNAT may produce both the actual reference
5171 variable and the renaming encoding. In this case, we discard the
5174 Second, GNAT emits a type following a specified encoding for each renaming
5175 entity. Unfortunately, STABS currently does not support the definition
5176 of types that are local to a given lexical block, so all renamings types
5177 are emitted at library level. As a consequence, if an application
5178 contains two renaming entities using the same name, and a user tries to
5179 print the value of one of these entities, the result of the ada symbol
5180 lookup will also contain the wrong renaming type.
5182 This function partially covers for this limitation by attempting to
5183 remove from the SYMS list renaming symbols that should be visible
5184 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5185 method with the current information available. The implementation
5186 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5188 - When the user tries to print a rename in a function while there
5189 is another rename entity defined in a package: Normally, the
5190 rename in the function has precedence over the rename in the
5191 package, so the latter should be removed from the list. This is
5192 currently not the case.
5194 - This function will incorrectly remove valid renames if
5195 the CURRENT_BLOCK corresponds to a function which symbol name
5196 has been changed by an "Export" pragma. As a consequence,
5197 the user will be unable to print such rename entities. */
5200 remove_irrelevant_renamings (std::vector
<struct block_symbol
> *syms
,
5201 const struct block
*current_block
)
5203 struct symbol
*current_function
;
5204 const char *current_function_name
;
5206 int is_new_style_renaming
;
5208 /* If there is both a renaming foo___XR... encoded as a variable and
5209 a simple variable foo in the same block, discard the latter.
5210 First, zero out such symbols, then compress. */
5211 is_new_style_renaming
= 0;
5212 for (i
= 0; i
< syms
->size (); i
+= 1)
5214 struct symbol
*sym
= (*syms
)[i
].symbol
;
5215 const struct block
*block
= (*syms
)[i
].block
;
5219 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5221 name
= sym
->linkage_name ();
5222 suffix
= strstr (name
, "___XR");
5226 int name_len
= suffix
- name
;
5229 is_new_style_renaming
= 1;
5230 for (j
= 0; j
< syms
->size (); j
+= 1)
5231 if (i
!= j
&& (*syms
)[j
].symbol
!= NULL
5232 && strncmp (name
, (*syms
)[j
].symbol
->linkage_name (),
5234 && block
== (*syms
)[j
].block
)
5235 (*syms
)[j
].symbol
= NULL
;
5238 if (is_new_style_renaming
)
5242 for (j
= k
= 0; j
< syms
->size (); j
+= 1)
5243 if ((*syms
)[j
].symbol
!= NULL
)
5245 (*syms
)[k
] = (*syms
)[j
];
5251 /* Extract the function name associated to CURRENT_BLOCK.
5252 Abort if unable to do so. */
5254 if (current_block
== NULL
)
5255 return syms
->size ();
5257 current_function
= block_linkage_function (current_block
);
5258 if (current_function
== NULL
)
5259 return syms
->size ();
5261 current_function_name
= current_function
->linkage_name ();
5262 if (current_function_name
== NULL
)
5263 return syms
->size ();
5265 /* Check each of the symbols, and remove it from the list if it is
5266 a type corresponding to a renaming that is out of the scope of
5267 the current block. */
5270 while (i
< syms
->size ())
5272 if (ada_parse_renaming ((*syms
)[i
].symbol
, NULL
, NULL
, NULL
)
5273 == ADA_OBJECT_RENAMING
5274 && old_renaming_is_invisible ((*syms
)[i
].symbol
,
5275 current_function_name
))
5276 syms
->erase (syms
->begin () + i
);
5281 return syms
->size ();
5284 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5285 whose name and domain match NAME and DOMAIN respectively.
5286 If no match was found, then extend the search to "enclosing"
5287 routines (in other words, if we're inside a nested function,
5288 search the symbols defined inside the enclosing functions).
5289 If WILD_MATCH_P is nonzero, perform the naming matching in
5290 "wild" mode (see function "wild_match" for more info).
5292 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5295 ada_add_local_symbols (struct obstack
*obstackp
,
5296 const lookup_name_info
&lookup_name
,
5297 const struct block
*block
, domain_enum domain
)
5299 int block_depth
= 0;
5301 while (block
!= NULL
)
5304 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5306 /* If we found a non-function match, assume that's the one. */
5307 if (is_nonfunction (defns_collected (obstackp
, 0),
5308 num_defns_collected (obstackp
)))
5311 block
= BLOCK_SUPERBLOCK (block
);
5314 /* If no luck so far, try to find NAME as a local symbol in some lexically
5315 enclosing subprogram. */
5316 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5317 add_symbols_from_enclosing_procs (obstackp
, lookup_name
, domain
);
5320 /* An object of this type is used as the user_data argument when
5321 calling the map_matching_symbols method. */
5325 struct objfile
*objfile
;
5326 struct obstack
*obstackp
;
5327 struct symbol
*arg_sym
;
5331 /* A callback for add_nonlocal_symbols that adds symbol, found in BSYM,
5332 to a list of symbols. DATA is a pointer to a struct match_data *
5333 containing the obstack that collects the symbol list, the file that SYM
5334 must come from, a flag indicating whether a non-argument symbol has
5335 been found in the current block, and the last argument symbol
5336 passed in SYM within the current block (if any). When SYM is null,
5337 marking the end of a block, the argument symbol is added if no
5338 other has been found. */
5341 aux_add_nonlocal_symbols (struct block_symbol
*bsym
,
5342 struct match_data
*data
)
5344 const struct block
*block
= bsym
->block
;
5345 struct symbol
*sym
= bsym
->symbol
;
5349 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5350 add_defn_to_vec (data
->obstackp
,
5351 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5353 data
->found_sym
= 0;
5354 data
->arg_sym
= NULL
;
5358 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5360 else if (SYMBOL_IS_ARGUMENT (sym
))
5361 data
->arg_sym
= sym
;
5364 data
->found_sym
= 1;
5365 add_defn_to_vec (data
->obstackp
,
5366 fixup_symbol_section (sym
, data
->objfile
),
5373 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5374 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5375 symbols to OBSTACKP. Return whether we found such symbols. */
5378 ada_add_block_renamings (struct obstack
*obstackp
,
5379 const struct block
*block
,
5380 const lookup_name_info
&lookup_name
,
5383 struct using_direct
*renaming
;
5384 int defns_mark
= num_defns_collected (obstackp
);
5386 symbol_name_matcher_ftype
*name_match
5387 = ada_get_symbol_name_matcher (lookup_name
);
5389 for (renaming
= block_using (block
);
5391 renaming
= renaming
->next
)
5395 /* Avoid infinite recursions: skip this renaming if we are actually
5396 already traversing it.
5398 Currently, symbol lookup in Ada don't use the namespace machinery from
5399 C++/Fortran support: skip namespace imports that use them. */
5400 if (renaming
->searched
5401 || (renaming
->import_src
!= NULL
5402 && renaming
->import_src
[0] != '\0')
5403 || (renaming
->import_dest
!= NULL
5404 && renaming
->import_dest
[0] != '\0'))
5406 renaming
->searched
= 1;
5408 /* TODO: here, we perform another name-based symbol lookup, which can
5409 pull its own multiple overloads. In theory, we should be able to do
5410 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5411 not a simple name. But in order to do this, we would need to enhance
5412 the DWARF reader to associate a symbol to this renaming, instead of a
5413 name. So, for now, we do something simpler: re-use the C++/Fortran
5414 namespace machinery. */
5415 r_name
= (renaming
->alias
!= NULL
5417 : renaming
->declaration
);
5418 if (name_match (r_name
, lookup_name
, NULL
))
5420 lookup_name_info
decl_lookup_name (renaming
->declaration
,
5421 lookup_name
.match_type ());
5422 ada_add_all_symbols (obstackp
, block
, decl_lookup_name
, domain
,
5425 renaming
->searched
= 0;
5427 return num_defns_collected (obstackp
) != defns_mark
;
5430 /* Implements compare_names, but only applying the comparision using
5431 the given CASING. */
5434 compare_names_with_case (const char *string1
, const char *string2
,
5435 enum case_sensitivity casing
)
5437 while (*string1
!= '\0' && *string2
!= '\0')
5441 if (isspace (*string1
) || isspace (*string2
))
5442 return strcmp_iw_ordered (string1
, string2
);
5444 if (casing
== case_sensitive_off
)
5446 c1
= tolower (*string1
);
5447 c2
= tolower (*string2
);
5464 return strcmp_iw_ordered (string1
, string2
);
5466 if (*string2
== '\0')
5468 if (is_name_suffix (string1
))
5475 if (*string2
== '(')
5476 return strcmp_iw_ordered (string1
, string2
);
5479 if (casing
== case_sensitive_off
)
5480 return tolower (*string1
) - tolower (*string2
);
5482 return *string1
- *string2
;
5487 /* Compare STRING1 to STRING2, with results as for strcmp.
5488 Compatible with strcmp_iw_ordered in that...
5490 strcmp_iw_ordered (STRING1, STRING2) <= 0
5494 compare_names (STRING1, STRING2) <= 0
5496 (they may differ as to what symbols compare equal). */
5499 compare_names (const char *string1
, const char *string2
)
5503 /* Similar to what strcmp_iw_ordered does, we need to perform
5504 a case-insensitive comparison first, and only resort to
5505 a second, case-sensitive, comparison if the first one was
5506 not sufficient to differentiate the two strings. */
5508 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5510 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5515 /* Convenience function to get at the Ada encoded lookup name for
5516 LOOKUP_NAME, as a C string. */
5519 ada_lookup_name (const lookup_name_info
&lookup_name
)
5521 return lookup_name
.ada ().lookup_name ().c_str ();
5524 /* Add to OBSTACKP all non-local symbols whose name and domain match
5525 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5526 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5527 symbols otherwise. */
5530 add_nonlocal_symbols (struct obstack
*obstackp
,
5531 const lookup_name_info
&lookup_name
,
5532 domain_enum domain
, int global
)
5534 struct match_data data
;
5536 memset (&data
, 0, sizeof data
);
5537 data
.obstackp
= obstackp
;
5539 bool is_wild_match
= lookup_name
.ada ().wild_match_p ();
5541 auto callback
= [&] (struct block_symbol
*bsym
)
5543 return aux_add_nonlocal_symbols (bsym
, &data
);
5546 for (objfile
*objfile
: current_program_space
->objfiles ())
5548 data
.objfile
= objfile
;
5550 objfile
->sf
->qf
->map_matching_symbols (objfile
, lookup_name
,
5551 domain
, global
, callback
,
5553 ? NULL
: compare_names
));
5555 for (compunit_symtab
*cu
: objfile
->compunits ())
5557 const struct block
*global_block
5558 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu
), GLOBAL_BLOCK
);
5560 if (ada_add_block_renamings (obstackp
, global_block
, lookup_name
,
5566 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
5568 const char *name
= ada_lookup_name (lookup_name
);
5569 std::string bracket_name
= std::string ("<_ada_") + name
+ '>';
5570 lookup_name_info
name1 (bracket_name
, symbol_name_match_type::FULL
);
5572 for (objfile
*objfile
: current_program_space
->objfiles ())
5574 data
.objfile
= objfile
;
5575 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
,
5576 domain
, global
, callback
,
5582 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5583 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5584 returning the number of matches. Add these to OBSTACKP.
5586 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5587 symbol match within the nest of blocks whose innermost member is BLOCK,
5588 is the one match returned (no other matches in that or
5589 enclosing blocks is returned). If there are any matches in or
5590 surrounding BLOCK, then these alone are returned.
5592 Names prefixed with "standard__" are handled specially:
5593 "standard__" is first stripped off (by the lookup_name
5594 constructor), and only static and global symbols are searched.
5596 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5597 to lookup global symbols. */
5600 ada_add_all_symbols (struct obstack
*obstackp
,
5601 const struct block
*block
,
5602 const lookup_name_info
&lookup_name
,
5605 int *made_global_lookup_p
)
5609 if (made_global_lookup_p
)
5610 *made_global_lookup_p
= 0;
5612 /* Special case: If the user specifies a symbol name inside package
5613 Standard, do a non-wild matching of the symbol name without
5614 the "standard__" prefix. This was primarily introduced in order
5615 to allow the user to specifically access the standard exceptions
5616 using, for instance, Standard.Constraint_Error when Constraint_Error
5617 is ambiguous (due to the user defining its own Constraint_Error
5618 entity inside its program). */
5619 if (lookup_name
.ada ().standard_p ())
5622 /* Check the non-global symbols. If we have ANY match, then we're done. */
5627 ada_add_local_symbols (obstackp
, lookup_name
, block
, domain
);
5630 /* In the !full_search case we're are being called by
5631 iterate_over_symbols, and we don't want to search
5633 ada_add_block_symbols (obstackp
, block
, lookup_name
, domain
, NULL
);
5635 if (num_defns_collected (obstackp
) > 0 || !full_search
)
5639 /* No non-global symbols found. Check our cache to see if we have
5640 already performed this search before. If we have, then return
5643 if (lookup_cached_symbol (ada_lookup_name (lookup_name
),
5644 domain
, &sym
, &block
))
5647 add_defn_to_vec (obstackp
, sym
, block
);
5651 if (made_global_lookup_p
)
5652 *made_global_lookup_p
= 1;
5654 /* Search symbols from all global blocks. */
5656 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 1);
5658 /* Now add symbols from all per-file blocks if we've gotten no hits
5659 (not strictly correct, but perhaps better than an error). */
5661 if (num_defns_collected (obstackp
) == 0)
5662 add_nonlocal_symbols (obstackp
, lookup_name
, domain
, 0);
5665 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5666 is non-zero, enclosing scope and in global scopes, returning the number of
5668 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols
5669 found and the blocks and symbol tables (if any) in which they were
5672 When full_search is non-zero, any non-function/non-enumeral
5673 symbol match within the nest of blocks whose innermost member is BLOCK,
5674 is the one match returned (no other matches in that or
5675 enclosing blocks is returned). If there are any matches in or
5676 surrounding BLOCK, then these alone are returned.
5678 Names prefixed with "standard__" are handled specially: "standard__"
5679 is first stripped off, and only static and global symbols are searched. */
5682 ada_lookup_symbol_list_worker (const lookup_name_info
&lookup_name
,
5683 const struct block
*block
,
5685 std::vector
<struct block_symbol
> *results
,
5688 int syms_from_global_search
;
5690 auto_obstack obstack
;
5692 ada_add_all_symbols (&obstack
, block
, lookup_name
,
5693 domain
, full_search
, &syms_from_global_search
);
5695 ndefns
= num_defns_collected (&obstack
);
5697 struct block_symbol
*base
= defns_collected (&obstack
, 1);
5698 for (int i
= 0; i
< ndefns
; ++i
)
5699 results
->push_back (base
[i
]);
5701 ndefns
= remove_extra_symbols (results
);
5703 if (ndefns
== 0 && full_search
&& syms_from_global_search
)
5704 cache_symbol (ada_lookup_name (lookup_name
), domain
, NULL
, NULL
);
5706 if (ndefns
== 1 && full_search
&& syms_from_global_search
)
5707 cache_symbol (ada_lookup_name (lookup_name
), domain
,
5708 (*results
)[0].symbol
, (*results
)[0].block
);
5710 ndefns
= remove_irrelevant_renamings (results
, block
);
5715 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5716 in global scopes, returning the number of matches, and filling *RESULTS
5717 with (SYM,BLOCK) tuples.
5719 See ada_lookup_symbol_list_worker for further details. */
5722 ada_lookup_symbol_list (const char *name
, const struct block
*block
,
5724 std::vector
<struct block_symbol
> *results
)
5726 symbol_name_match_type name_match_type
= name_match_type_from_name (name
);
5727 lookup_name_info
lookup_name (name
, name_match_type
);
5729 return ada_lookup_symbol_list_worker (lookup_name
, block
, domain
, results
, 1);
5732 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5733 to 1, but choosing the first symbol found if there are multiple
5736 The result is stored in *INFO, which must be non-NULL.
5737 If no match is found, INFO->SYM is set to NULL. */
5740 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5742 struct block_symbol
*info
)
5744 /* Since we already have an encoded name, wrap it in '<>' to force a
5745 verbatim match. Otherwise, if the name happens to not look like
5746 an encoded name (because it doesn't include a "__"),
5747 ada_lookup_name_info would re-encode/fold it again, and that
5748 would e.g., incorrectly lowercase object renaming names like
5749 "R28b" -> "r28b". */
5750 std::string verbatim
= std::string ("<") + name
+ '>';
5752 gdb_assert (info
!= NULL
);
5753 *info
= ada_lookup_symbol (verbatim
.c_str (), block
, domain
);
5756 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5757 scope and in global scopes, or NULL if none. NAME is folded and
5758 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5759 choosing the first symbol if there are multiple choices. */
5762 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5765 std::vector
<struct block_symbol
> candidates
;
5768 n_candidates
= ada_lookup_symbol_list (name
, block0
, domain
, &candidates
);
5770 if (n_candidates
== 0)
5773 block_symbol info
= candidates
[0];
5774 info
.symbol
= fixup_symbol_section (info
.symbol
, NULL
);
5778 static struct block_symbol
5779 ada_lookup_symbol_nonlocal (const struct language_defn
*langdef
,
5781 const struct block
*block
,
5782 const domain_enum domain
)
5784 struct block_symbol sym
;
5786 sym
= ada_lookup_symbol (name
, block_static_block (block
), domain
);
5787 if (sym
.symbol
!= NULL
)
5790 /* If we haven't found a match at this point, try the primitive
5791 types. In other languages, this search is performed before
5792 searching for global symbols in order to short-circuit that
5793 global-symbol search if it happens that the name corresponds
5794 to a primitive type. But we cannot do the same in Ada, because
5795 it is perfectly legitimate for a program to declare a type which
5796 has the same name as a standard type. If looking up a type in
5797 that situation, we have traditionally ignored the primitive type
5798 in favor of user-defined types. This is why, unlike most other
5799 languages, we search the primitive types this late and only after
5800 having searched the global symbols without success. */
5802 if (domain
== VAR_DOMAIN
)
5804 struct gdbarch
*gdbarch
;
5807 gdbarch
= target_gdbarch ();
5809 gdbarch
= block_gdbarch (block
);
5810 sym
.symbol
= language_lookup_primitive_type_as_symbol (langdef
, gdbarch
, name
);
5811 if (sym
.symbol
!= NULL
)
5819 /* True iff STR is a possible encoded suffix of a normal Ada name
5820 that is to be ignored for matching purposes. Suffixes of parallel
5821 names (e.g., XVE) are not included here. Currently, the possible suffixes
5822 are given by any of the regular expressions:
5824 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5825 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5826 TKB [subprogram suffix for task bodies]
5827 _E[0-9]+[bs]$ [protected object entry suffixes]
5828 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5830 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5831 match is performed. This sequence is used to differentiate homonyms,
5832 is an optional part of a valid name suffix. */
5835 is_name_suffix (const char *str
)
5838 const char *matching
;
5839 const int len
= strlen (str
);
5841 /* Skip optional leading __[0-9]+. */
5843 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5846 while (isdigit (str
[0]))
5852 if (str
[0] == '.' || str
[0] == '$')
5855 while (isdigit (matching
[0]))
5857 if (matching
[0] == '\0')
5863 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5866 while (isdigit (matching
[0]))
5868 if (matching
[0] == '\0')
5872 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5874 if (strcmp (str
, "TKB") == 0)
5878 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5879 with a N at the end. Unfortunately, the compiler uses the same
5880 convention for other internal types it creates. So treating
5881 all entity names that end with an "N" as a name suffix causes
5882 some regressions. For instance, consider the case of an enumerated
5883 type. To support the 'Image attribute, it creates an array whose
5885 Having a single character like this as a suffix carrying some
5886 information is a bit risky. Perhaps we should change the encoding
5887 to be something like "_N" instead. In the meantime, do not do
5888 the following check. */
5889 /* Protected Object Subprograms */
5890 if (len
== 1 && str
[0] == 'N')
5895 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5898 while (isdigit (matching
[0]))
5900 if ((matching
[0] == 'b' || matching
[0] == 's')
5901 && matching
[1] == '\0')
5905 /* ??? We should not modify STR directly, as we are doing below. This
5906 is fine in this case, but may become problematic later if we find
5907 that this alternative did not work, and want to try matching
5908 another one from the begining of STR. Since we modified it, we
5909 won't be able to find the begining of the string anymore! */
5913 while (str
[0] != '_' && str
[0] != '\0')
5915 if (str
[0] != 'n' && str
[0] != 'b')
5921 if (str
[0] == '\000')
5926 if (str
[1] != '_' || str
[2] == '\000')
5930 if (strcmp (str
+ 3, "JM") == 0)
5932 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5933 the LJM suffix in favor of the JM one. But we will
5934 still accept LJM as a valid suffix for a reasonable
5935 amount of time, just to allow ourselves to debug programs
5936 compiled using an older version of GNAT. */
5937 if (strcmp (str
+ 3, "LJM") == 0)
5941 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5942 || str
[4] == 'U' || str
[4] == 'P')
5944 if (str
[4] == 'R' && str
[5] != 'T')
5948 if (!isdigit (str
[2]))
5950 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5951 if (!isdigit (str
[k
]) && str
[k
] != '_')
5955 if (str
[0] == '$' && isdigit (str
[1]))
5957 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5958 if (!isdigit (str
[k
]) && str
[k
] != '_')
5965 /* Return non-zero if the string starting at NAME and ending before
5966 NAME_END contains no capital letters. */
5969 is_valid_name_for_wild_match (const char *name0
)
5971 std::string decoded_name
= ada_decode (name0
);
5974 /* If the decoded name starts with an angle bracket, it means that
5975 NAME0 does not follow the GNAT encoding format. It should then
5976 not be allowed as a possible wild match. */
5977 if (decoded_name
[0] == '<')
5980 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5981 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5987 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5988 that could start a simple name. Assumes that *NAMEP points into
5989 the string beginning at NAME0. */
5992 advance_wild_match (const char **namep
, const char *name0
, int target0
)
5994 const char *name
= *namep
;
6004 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
6007 if (name
== name0
+ 5 && startswith (name0
, "_ada"))
6012 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
6013 || name
[2] == target0
))
6021 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
6031 /* Return true iff NAME encodes a name of the form prefix.PATN.
6032 Ignores any informational suffixes of NAME (i.e., for which
6033 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6037 wild_match (const char *name
, const char *patn
)
6040 const char *name0
= name
;
6044 const char *match
= name
;
6048 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
6051 if (*p
== '\0' && is_name_suffix (name
))
6052 return match
== name0
|| is_valid_name_for_wild_match (name0
);
6054 if (name
[-1] == '_')
6057 if (!advance_wild_match (&name
, name0
, *patn
))
6062 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6063 any trailing suffixes that encode debugging information or leading
6064 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6065 information that is ignored). */
6068 full_match (const char *sym_name
, const char *search_name
)
6070 size_t search_name_len
= strlen (search_name
);
6072 if (strncmp (sym_name
, search_name
, search_name_len
) == 0
6073 && is_name_suffix (sym_name
+ search_name_len
))
6076 if (startswith (sym_name
, "_ada_")
6077 && strncmp (sym_name
+ 5, search_name
, search_name_len
) == 0
6078 && is_name_suffix (sym_name
+ search_name_len
+ 5))
6084 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6085 *defn_symbols, updating the list of symbols in OBSTACKP (if
6086 necessary). OBJFILE is the section containing BLOCK. */
6089 ada_add_block_symbols (struct obstack
*obstackp
,
6090 const struct block
*block
,
6091 const lookup_name_info
&lookup_name
,
6092 domain_enum domain
, struct objfile
*objfile
)
6094 struct block_iterator iter
;
6095 /* A matching argument symbol, if any. */
6096 struct symbol
*arg_sym
;
6097 /* Set true when we find a matching non-argument symbol. */
6103 for (sym
= block_iter_match_first (block
, lookup_name
, &iter
);
6105 sym
= block_iter_match_next (lookup_name
, &iter
))
6107 if (symbol_matches_domain (sym
->language (), SYMBOL_DOMAIN (sym
), domain
))
6109 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6111 if (SYMBOL_IS_ARGUMENT (sym
))
6116 add_defn_to_vec (obstackp
,
6117 fixup_symbol_section (sym
, objfile
),
6124 /* Handle renamings. */
6126 if (ada_add_block_renamings (obstackp
, block
, lookup_name
, domain
))
6129 if (!found_sym
&& arg_sym
!= NULL
)
6131 add_defn_to_vec (obstackp
,
6132 fixup_symbol_section (arg_sym
, objfile
),
6136 if (!lookup_name
.ada ().wild_match_p ())
6140 const std::string
&ada_lookup_name
= lookup_name
.ada ().lookup_name ();
6141 const char *name
= ada_lookup_name
.c_str ();
6142 size_t name_len
= ada_lookup_name
.size ();
6144 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
6146 if (symbol_matches_domain (sym
->language (),
6147 SYMBOL_DOMAIN (sym
), domain
))
6151 cmp
= (int) '_' - (int) sym
->linkage_name ()[0];
6154 cmp
= !startswith (sym
->linkage_name (), "_ada_");
6156 cmp
= strncmp (name
, sym
->linkage_name () + 5,
6161 && is_name_suffix (sym
->linkage_name () + name_len
+ 5))
6163 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
6165 if (SYMBOL_IS_ARGUMENT (sym
))
6170 add_defn_to_vec (obstackp
,
6171 fixup_symbol_section (sym
, objfile
),
6179 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6180 They aren't parameters, right? */
6181 if (!found_sym
&& arg_sym
!= NULL
)
6183 add_defn_to_vec (obstackp
,
6184 fixup_symbol_section (arg_sym
, objfile
),
6191 /* Symbol Completion */
6196 ada_lookup_name_info::matches
6197 (const char *sym_name
,
6198 symbol_name_match_type match_type
,
6199 completion_match_result
*comp_match_res
) const
6202 const char *text
= m_encoded_name
.c_str ();
6203 size_t text_len
= m_encoded_name
.size ();
6205 /* First, test against the fully qualified name of the symbol. */
6207 if (strncmp (sym_name
, text
, text_len
) == 0)
6210 std::string decoded_name
= ada_decode (sym_name
);
6211 if (match
&& !m_encoded_p
)
6213 /* One needed check before declaring a positive match is to verify
6214 that iff we are doing a verbatim match, the decoded version
6215 of the symbol name starts with '<'. Otherwise, this symbol name
6216 is not a suitable completion. */
6218 bool has_angle_bracket
= (decoded_name
[0] == '<');
6219 match
= (has_angle_bracket
== m_verbatim_p
);
6222 if (match
&& !m_verbatim_p
)
6224 /* When doing non-verbatim match, another check that needs to
6225 be done is to verify that the potentially matching symbol name
6226 does not include capital letters, because the ada-mode would
6227 not be able to understand these symbol names without the
6228 angle bracket notation. */
6231 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6236 /* Second: Try wild matching... */
6238 if (!match
&& m_wild_match_p
)
6240 /* Since we are doing wild matching, this means that TEXT
6241 may represent an unqualified symbol name. We therefore must
6242 also compare TEXT against the unqualified name of the symbol. */
6243 sym_name
= ada_unqualified_name (decoded_name
.c_str ());
6245 if (strncmp (sym_name
, text
, text_len
) == 0)
6249 /* Finally: If we found a match, prepare the result to return. */
6254 if (comp_match_res
!= NULL
)
6256 std::string
&match_str
= comp_match_res
->match
.storage ();
6259 match_str
= ada_decode (sym_name
);
6263 match_str
= add_angle_brackets (sym_name
);
6265 match_str
= sym_name
;
6269 comp_match_res
->set_match (match_str
.c_str ());
6277 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6278 for tagged types. */
6281 ada_is_dispatch_table_ptr_type (struct type
*type
)
6285 if (type
->code () != TYPE_CODE_PTR
)
6288 name
= TYPE_TARGET_TYPE (type
)->name ();
6292 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6295 /* Return non-zero if TYPE is an interface tag. */
6298 ada_is_interface_tag (struct type
*type
)
6300 const char *name
= type
->name ();
6305 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6308 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6309 to be invisible to users. */
6312 ada_is_ignored_field (struct type
*type
, int field_num
)
6314 if (field_num
< 0 || field_num
> type
->num_fields ())
6317 /* Check the name of that field. */
6319 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6321 /* Anonymous field names should not be printed.
6322 brobecker/2007-02-20: I don't think this can actually happen
6323 but we don't want to print the value of anonymous fields anyway. */
6327 /* Normally, fields whose name start with an underscore ("_")
6328 are fields that have been internally generated by the compiler,
6329 and thus should not be printed. The "_parent" field is special,
6330 however: This is a field internally generated by the compiler
6331 for tagged types, and it contains the components inherited from
6332 the parent type. This field should not be printed as is, but
6333 should not be ignored either. */
6334 if (name
[0] == '_' && !startswith (name
, "_parent"))
6338 /* If this is the dispatch table of a tagged type or an interface tag,
6340 if (ada_is_tagged_type (type
, 1)
6341 && (ada_is_dispatch_table_ptr_type (type
->field (field_num
).type ())
6342 || ada_is_interface_tag (type
->field (field_num
).type ())))
6345 /* Not a special field, so it should not be ignored. */
6349 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6350 pointer or reference type whose ultimate target has a tag field. */
6353 ada_is_tagged_type (struct type
*type
, int refok
)
6355 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6358 /* True iff TYPE represents the type of X'Tag */
6361 ada_is_tag_type (struct type
*type
)
6363 type
= ada_check_typedef (type
);
6365 if (type
== NULL
|| type
->code () != TYPE_CODE_PTR
)
6369 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6371 return (name
!= NULL
6372 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6376 /* The type of the tag on VAL. */
6378 static struct type
*
6379 ada_tag_type (struct value
*val
)
6381 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6384 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6385 retired at Ada 05). */
6388 is_ada95_tag (struct value
*tag
)
6390 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6393 /* The value of the tag on VAL. */
6395 static struct value
*
6396 ada_value_tag (struct value
*val
)
6398 return ada_value_struct_elt (val
, "_tag", 0);
6401 /* The value of the tag on the object of type TYPE whose contents are
6402 saved at VALADDR, if it is non-null, or is at memory address
6405 static struct value
*
6406 value_tag_from_contents_and_address (struct type
*type
,
6407 const gdb_byte
*valaddr
,
6410 int tag_byte_offset
;
6411 struct type
*tag_type
;
6413 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6416 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6418 : valaddr
+ tag_byte_offset
);
6419 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6421 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6426 static struct type
*
6427 type_from_tag (struct value
*tag
)
6429 gdb::unique_xmalloc_ptr
<char> type_name
= ada_tag_name (tag
);
6431 if (type_name
!= NULL
)
6432 return ada_find_any_type (ada_encode (type_name
.get ()));
6436 /* Given a value OBJ of a tagged type, return a value of this
6437 type at the base address of the object. The base address, as
6438 defined in Ada.Tags, it is the address of the primary tag of
6439 the object, and therefore where the field values of its full
6440 view can be fetched. */
6443 ada_tag_value_at_base_address (struct value
*obj
)
6446 LONGEST offset_to_top
= 0;
6447 struct type
*ptr_type
, *obj_type
;
6449 CORE_ADDR base_address
;
6451 obj_type
= value_type (obj
);
6453 /* It is the responsability of the caller to deref pointers. */
6455 if (obj_type
->code () == TYPE_CODE_PTR
|| obj_type
->code () == TYPE_CODE_REF
)
6458 tag
= ada_value_tag (obj
);
6462 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6464 if (is_ada95_tag (tag
))
6467 ptr_type
= language_lookup_primitive_type
6468 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6469 ptr_type
= lookup_pointer_type (ptr_type
);
6470 val
= value_cast (ptr_type
, tag
);
6474 /* It is perfectly possible that an exception be raised while
6475 trying to determine the base address, just like for the tag;
6476 see ada_tag_name for more details. We do not print the error
6477 message for the same reason. */
6481 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6484 catch (const gdb_exception_error
&e
)
6489 /* If offset is null, nothing to do. */
6491 if (offset_to_top
== 0)
6494 /* -1 is a special case in Ada.Tags; however, what should be done
6495 is not quite clear from the documentation. So do nothing for
6498 if (offset_to_top
== -1)
6501 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6502 from the base address. This was however incompatible with
6503 C++ dispatch table: C++ uses a *negative* value to *add*
6504 to the base address. Ada's convention has therefore been
6505 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6506 use the same convention. Here, we support both cases by
6507 checking the sign of OFFSET_TO_TOP. */
6509 if (offset_to_top
> 0)
6510 offset_to_top
= -offset_to_top
;
6512 base_address
= value_address (obj
) + offset_to_top
;
6513 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6515 /* Make sure that we have a proper tag at the new address.
6516 Otherwise, offset_to_top is bogus (which can happen when
6517 the object is not initialized yet). */
6522 obj_type
= type_from_tag (tag
);
6527 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6530 /* Return the "ada__tags__type_specific_data" type. */
6532 static struct type
*
6533 ada_get_tsd_type (struct inferior
*inf
)
6535 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6537 if (data
->tsd_type
== 0)
6538 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6539 return data
->tsd_type
;
6542 /* Return the TSD (type-specific data) associated to the given TAG.
6543 TAG is assumed to be the tag of a tagged-type entity.
6545 May return NULL if we are unable to get the TSD. */
6547 static struct value
*
6548 ada_get_tsd_from_tag (struct value
*tag
)
6553 /* First option: The TSD is simply stored as a field of our TAG.
6554 Only older versions of GNAT would use this format, but we have
6555 to test it first, because there are no visible markers for
6556 the current approach except the absence of that field. */
6558 val
= ada_value_struct_elt (tag
, "tsd", 1);
6562 /* Try the second representation for the dispatch table (in which
6563 there is no explicit 'tsd' field in the referent of the tag pointer,
6564 and instead the tsd pointer is stored just before the dispatch
6567 type
= ada_get_tsd_type (current_inferior());
6570 type
= lookup_pointer_type (lookup_pointer_type (type
));
6571 val
= value_cast (type
, tag
);
6574 return value_ind (value_ptradd (val
, -1));
6577 /* Given the TSD of a tag (type-specific data), return a string
6578 containing the name of the associated type.
6580 May return NULL if we are unable to determine the tag name. */
6582 static gdb::unique_xmalloc_ptr
<char>
6583 ada_tag_name_from_tsd (struct value
*tsd
)
6588 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6591 gdb::unique_xmalloc_ptr
<char> buffer
6592 = target_read_string (value_as_address (val
), INT_MAX
);
6593 if (buffer
== nullptr)
6596 for (p
= buffer
.get (); *p
!= '\0'; ++p
)
6605 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6608 Return NULL if the TAG is not an Ada tag, or if we were unable to
6609 determine the name of that tag. */
6611 gdb::unique_xmalloc_ptr
<char>
6612 ada_tag_name (struct value
*tag
)
6614 gdb::unique_xmalloc_ptr
<char> name
;
6616 if (!ada_is_tag_type (value_type (tag
)))
6619 /* It is perfectly possible that an exception be raised while trying
6620 to determine the TAG's name, even under normal circumstances:
6621 The associated variable may be uninitialized or corrupted, for
6622 instance. We do not let any exception propagate past this point.
6623 instead we return NULL.
6625 We also do not print the error message either (which often is very
6626 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6627 the caller print a more meaningful message if necessary. */
6630 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6633 name
= ada_tag_name_from_tsd (tsd
);
6635 catch (const gdb_exception_error
&e
)
6642 /* The parent type of TYPE, or NULL if none. */
6645 ada_parent_type (struct type
*type
)
6649 type
= ada_check_typedef (type
);
6651 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
6654 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6655 if (ada_is_parent_field (type
, i
))
6657 struct type
*parent_type
= type
->field (i
).type ();
6659 /* If the _parent field is a pointer, then dereference it. */
6660 if (parent_type
->code () == TYPE_CODE_PTR
)
6661 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6662 /* If there is a parallel XVS type, get the actual base type. */
6663 parent_type
= ada_get_base_type (parent_type
);
6665 return ada_check_typedef (parent_type
);
6671 /* True iff field number FIELD_NUM of structure type TYPE contains the
6672 parent-type (inherited) fields of a derived type. Assumes TYPE is
6673 a structure type with at least FIELD_NUM+1 fields. */
6676 ada_is_parent_field (struct type
*type
, int field_num
)
6678 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6680 return (name
!= NULL
6681 && (startswith (name
, "PARENT")
6682 || startswith (name
, "_parent")));
6685 /* True iff field number FIELD_NUM of structure type TYPE is a
6686 transparent wrapper field (which should be silently traversed when doing
6687 field selection and flattened when printing). Assumes TYPE is a
6688 structure type with at least FIELD_NUM+1 fields. Such fields are always
6692 ada_is_wrapper_field (struct type
*type
, int field_num
)
6694 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6696 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6698 /* This happens in functions with "out" or "in out" parameters
6699 which are passed by copy. For such functions, GNAT describes
6700 the function's return type as being a struct where the return
6701 value is in a field called RETVAL, and where the other "out"
6702 or "in out" parameters are fields of that struct. This is not
6707 return (name
!= NULL
6708 && (startswith (name
, "PARENT")
6709 || strcmp (name
, "REP") == 0
6710 || startswith (name
, "_parent")
6711 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6714 /* True iff field number FIELD_NUM of structure or union type TYPE
6715 is a variant wrapper. Assumes TYPE is a structure type with at least
6716 FIELD_NUM+1 fields. */
6719 ada_is_variant_part (struct type
*type
, int field_num
)
6721 /* Only Ada types are eligible. */
6722 if (!ADA_TYPE_P (type
))
6725 struct type
*field_type
= type
->field (field_num
).type ();
6727 return (field_type
->code () == TYPE_CODE_UNION
6728 || (is_dynamic_field (type
, field_num
)
6729 && (TYPE_TARGET_TYPE (field_type
)->code ()
6730 == TYPE_CODE_UNION
)));
6733 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6734 whose discriminants are contained in the record type OUTER_TYPE,
6735 returns the type of the controlling discriminant for the variant.
6736 May return NULL if the type could not be found. */
6739 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6741 const char *name
= ada_variant_discrim_name (var_type
);
6743 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6746 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6747 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6748 represents a 'when others' clause; otherwise 0. */
6751 ada_is_others_clause (struct type
*type
, int field_num
)
6753 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6755 return (name
!= NULL
&& name
[0] == 'O');
6758 /* Assuming that TYPE0 is the type of the variant part of a record,
6759 returns the name of the discriminant controlling the variant.
6760 The value is valid until the next call to ada_variant_discrim_name. */
6763 ada_variant_discrim_name (struct type
*type0
)
6765 static char *result
= NULL
;
6766 static size_t result_len
= 0;
6769 const char *discrim_end
;
6770 const char *discrim_start
;
6772 if (type0
->code () == TYPE_CODE_PTR
)
6773 type
= TYPE_TARGET_TYPE (type0
);
6777 name
= ada_type_name (type
);
6779 if (name
== NULL
|| name
[0] == '\000')
6782 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6785 if (startswith (discrim_end
, "___XVN"))
6788 if (discrim_end
== name
)
6791 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6794 if (discrim_start
== name
+ 1)
6796 if ((discrim_start
> name
+ 3
6797 && startswith (discrim_start
- 3, "___"))
6798 || discrim_start
[-1] == '.')
6802 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6803 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6804 result
[discrim_end
- discrim_start
] = '\0';
6808 /* Scan STR for a subtype-encoded number, beginning at position K.
6809 Put the position of the character just past the number scanned in
6810 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6811 Return 1 if there was a valid number at the given position, and 0
6812 otherwise. A "subtype-encoded" number consists of the absolute value
6813 in decimal, followed by the letter 'm' to indicate a negative number.
6814 Assumes 0m does not occur. */
6817 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6821 if (!isdigit (str
[k
]))
6824 /* Do it the hard way so as not to make any assumption about
6825 the relationship of unsigned long (%lu scan format code) and
6828 while (isdigit (str
[k
]))
6830 RU
= RU
* 10 + (str
[k
] - '0');
6837 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6843 /* NOTE on the above: Technically, C does not say what the results of
6844 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6845 number representable as a LONGEST (although either would probably work
6846 in most implementations). When RU>0, the locution in the then branch
6847 above is always equivalent to the negative of RU. */
6854 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6855 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6856 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6859 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6861 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6875 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6885 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6886 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6888 if (val
>= L
&& val
<= U
)
6900 /* FIXME: Lots of redundancy below. Try to consolidate. */
6902 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6903 ARG_TYPE, extract and return the value of one of its (non-static)
6904 fields. FIELDNO says which field. Differs from value_primitive_field
6905 only in that it can handle packed values of arbitrary type. */
6908 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6909 struct type
*arg_type
)
6913 arg_type
= ada_check_typedef (arg_type
);
6914 type
= arg_type
->field (fieldno
).type ();
6916 /* Handle packed fields. It might be that the field is not packed
6917 relative to its containing structure, but the structure itself is
6918 packed; in this case we must take the bit-field path. */
6919 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
6921 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6922 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6924 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6925 offset
+ bit_pos
/ 8,
6926 bit_pos
% 8, bit_size
, type
);
6929 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6932 /* Find field with name NAME in object of type TYPE. If found,
6933 set the following for each argument that is non-null:
6934 - *FIELD_TYPE_P to the field's type;
6935 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6936 an object of that type;
6937 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6938 - *BIT_SIZE_P to its size in bits if the field is packed, and
6940 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6941 fields up to but not including the desired field, or by the total
6942 number of fields if not found. A NULL value of NAME never
6943 matches; the function just counts visible fields in this case.
6945 Notice that we need to handle when a tagged record hierarchy
6946 has some components with the same name, like in this scenario:
6948 type Top_T is tagged record
6954 type Middle_T is new Top.Top_T with record
6955 N : Character := 'a';
6959 type Bottom_T is new Middle.Middle_T with record
6961 C : Character := '5';
6963 A : Character := 'J';
6966 Let's say we now have a variable declared and initialized as follow:
6968 TC : Top_A := new Bottom_T;
6970 And then we use this variable to call this function
6972 procedure Assign (Obj: in out Top_T; TV : Integer);
6976 Assign (Top_T (B), 12);
6978 Now, we're in the debugger, and we're inside that procedure
6979 then and we want to print the value of obj.c:
6981 Usually, the tagged record or one of the parent type owns the
6982 component to print and there's no issue but in this particular
6983 case, what does it mean to ask for Obj.C? Since the actual
6984 type for object is type Bottom_T, it could mean two things: type
6985 component C from the Middle_T view, but also component C from
6986 Bottom_T. So in that "undefined" case, when the component is
6987 not found in the non-resolved type (which includes all the
6988 components of the parent type), then resolve it and see if we
6989 get better luck once expanded.
6991 In the case of homonyms in the derived tagged type, we don't
6992 guaranty anything, and pick the one that's easiest for us
6995 Returns 1 if found, 0 otherwise. */
6998 find_struct_field (const char *name
, struct type
*type
, int offset
,
6999 struct type
**field_type_p
,
7000 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
7004 int parent_offset
= -1;
7006 type
= ada_check_typedef (type
);
7008 if (field_type_p
!= NULL
)
7009 *field_type_p
= NULL
;
7010 if (byte_offset_p
!= NULL
)
7012 if (bit_offset_p
!= NULL
)
7014 if (bit_size_p
!= NULL
)
7017 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7019 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
7020 int fld_offset
= offset
+ bit_pos
/ 8;
7021 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7023 if (t_field_name
== NULL
)
7026 else if (ada_is_parent_field (type
, i
))
7028 /* This is a field pointing us to the parent type of a tagged
7029 type. As hinted in this function's documentation, we give
7030 preference to fields in the current record first, so what
7031 we do here is just record the index of this field before
7032 we skip it. If it turns out we couldn't find our field
7033 in the current record, then we'll get back to it and search
7034 inside it whether the field might exist in the parent. */
7040 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7042 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7044 if (field_type_p
!= NULL
)
7045 *field_type_p
= type
->field (i
).type ();
7046 if (byte_offset_p
!= NULL
)
7047 *byte_offset_p
= fld_offset
;
7048 if (bit_offset_p
!= NULL
)
7049 *bit_offset_p
= bit_pos
% 8;
7050 if (bit_size_p
!= NULL
)
7051 *bit_size_p
= bit_size
;
7054 else if (ada_is_wrapper_field (type
, i
))
7056 if (find_struct_field (name
, type
->field (i
).type (), fld_offset
,
7057 field_type_p
, byte_offset_p
, bit_offset_p
,
7058 bit_size_p
, index_p
))
7061 else if (ada_is_variant_part (type
, i
))
7063 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7066 struct type
*field_type
7067 = ada_check_typedef (type
->field (i
).type ());
7069 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7071 if (find_struct_field (name
, field_type
->field (j
).type (),
7073 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7074 field_type_p
, byte_offset_p
,
7075 bit_offset_p
, bit_size_p
, index_p
))
7079 else if (index_p
!= NULL
)
7083 /* Field not found so far. If this is a tagged type which
7084 has a parent, try finding that field in the parent now. */
7086 if (parent_offset
!= -1)
7088 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
7089 int fld_offset
= offset
+ bit_pos
/ 8;
7091 if (find_struct_field (name
, type
->field (parent_offset
).type (),
7092 fld_offset
, field_type_p
, byte_offset_p
,
7093 bit_offset_p
, bit_size_p
, index_p
))
7100 /* Number of user-visible fields in record type TYPE. */
7103 num_visible_fields (struct type
*type
)
7108 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7112 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7113 and search in it assuming it has (class) type TYPE.
7114 If found, return value, else return NULL.
7116 Searches recursively through wrapper fields (e.g., '_parent').
7118 In the case of homonyms in the tagged types, please refer to the
7119 long explanation in find_struct_field's function documentation. */
7121 static struct value
*
7122 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7126 int parent_offset
= -1;
7128 type
= ada_check_typedef (type
);
7129 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7131 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7133 if (t_field_name
== NULL
)
7136 else if (ada_is_parent_field (type
, i
))
7138 /* This is a field pointing us to the parent type of a tagged
7139 type. As hinted in this function's documentation, we give
7140 preference to fields in the current record first, so what
7141 we do here is just record the index of this field before
7142 we skip it. If it turns out we couldn't find our field
7143 in the current record, then we'll get back to it and search
7144 inside it whether the field might exist in the parent. */
7150 else if (field_name_match (t_field_name
, name
))
7151 return ada_value_primitive_field (arg
, offset
, i
, type
);
7153 else if (ada_is_wrapper_field (type
, i
))
7155 struct value
*v
= /* Do not let indent join lines here. */
7156 ada_search_struct_field (name
, arg
,
7157 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7158 type
->field (i
).type ());
7164 else if (ada_is_variant_part (type
, i
))
7166 /* PNH: Do we ever get here? See find_struct_field. */
7168 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7169 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7171 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7173 struct value
*v
= ada_search_struct_field
/* Force line
7176 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7177 field_type
->field (j
).type ());
7185 /* Field not found so far. If this is a tagged type which
7186 has a parent, try finding that field in the parent now. */
7188 if (parent_offset
!= -1)
7190 struct value
*v
= ada_search_struct_field (
7191 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7192 type
->field (parent_offset
).type ());
7201 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7202 int, struct type
*);
7205 /* Return field #INDEX in ARG, where the index is that returned by
7206 * find_struct_field through its INDEX_P argument. Adjust the address
7207 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7208 * If found, return value, else return NULL. */
7210 static struct value
*
7211 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7214 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7218 /* Auxiliary function for ada_index_struct_field. Like
7219 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7222 static struct value
*
7223 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7227 type
= ada_check_typedef (type
);
7229 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7231 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7233 else if (ada_is_wrapper_field (type
, i
))
7235 struct value
*v
= /* Do not let indent join lines here. */
7236 ada_index_struct_field_1 (index_p
, arg
,
7237 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7238 type
->field (i
).type ());
7244 else if (ada_is_variant_part (type
, i
))
7246 /* PNH: Do we ever get here? See ada_search_struct_field,
7247 find_struct_field. */
7248 error (_("Cannot assign this kind of variant record"));
7250 else if (*index_p
== 0)
7251 return ada_value_primitive_field (arg
, offset
, i
, type
);
7258 /* Return a string representation of type TYPE. */
7261 type_as_string (struct type
*type
)
7263 string_file tmp_stream
;
7265 type_print (type
, "", &tmp_stream
, -1);
7267 return std::move (tmp_stream
.string ());
7270 /* Given a type TYPE, look up the type of the component of type named NAME.
7271 If DISPP is non-null, add its byte displacement from the beginning of a
7272 structure (pointed to by a value) of type TYPE to *DISPP (does not
7273 work for packed fields).
7275 Matches any field whose name has NAME as a prefix, possibly
7278 TYPE can be either a struct or union. If REFOK, TYPE may also
7279 be a (pointer or reference)+ to a struct or union, and the
7280 ultimate target type will be searched.
7282 Looks recursively into variant clauses and parent types.
7284 In the case of homonyms in the tagged types, please refer to the
7285 long explanation in find_struct_field's function documentation.
7287 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7288 TYPE is not a type of the right kind. */
7290 static struct type
*
7291 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7295 int parent_offset
= -1;
7300 if (refok
&& type
!= NULL
)
7303 type
= ada_check_typedef (type
);
7304 if (type
->code () != TYPE_CODE_PTR
&& type
->code () != TYPE_CODE_REF
)
7306 type
= TYPE_TARGET_TYPE (type
);
7310 || (type
->code () != TYPE_CODE_STRUCT
7311 && type
->code () != TYPE_CODE_UNION
))
7316 error (_("Type %s is not a structure or union type"),
7317 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7320 type
= to_static_fixed_type (type
);
7322 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7324 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7327 if (t_field_name
== NULL
)
7330 else if (ada_is_parent_field (type
, i
))
7332 /* This is a field pointing us to the parent type of a tagged
7333 type. As hinted in this function's documentation, we give
7334 preference to fields in the current record first, so what
7335 we do here is just record the index of this field before
7336 we skip it. If it turns out we couldn't find our field
7337 in the current record, then we'll get back to it and search
7338 inside it whether the field might exist in the parent. */
7344 else if (field_name_match (t_field_name
, name
))
7345 return type
->field (i
).type ();
7347 else if (ada_is_wrapper_field (type
, i
))
7349 t
= ada_lookup_struct_elt_type (type
->field (i
).type (), name
,
7355 else if (ada_is_variant_part (type
, i
))
7358 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7360 for (j
= field_type
->num_fields () - 1; j
>= 0; j
-= 1)
7362 /* FIXME pnh 2008/01/26: We check for a field that is
7363 NOT wrapped in a struct, since the compiler sometimes
7364 generates these for unchecked variant types. Revisit
7365 if the compiler changes this practice. */
7366 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7368 if (v_field_name
!= NULL
7369 && field_name_match (v_field_name
, name
))
7370 t
= field_type
->field (j
).type ();
7372 t
= ada_lookup_struct_elt_type (field_type
->field (j
).type (),
7382 /* Field not found so far. If this is a tagged type which
7383 has a parent, try finding that field in the parent now. */
7385 if (parent_offset
!= -1)
7389 t
= ada_lookup_struct_elt_type (type
->field (parent_offset
).type (),
7398 const char *name_str
= name
!= NULL
? name
: _("<null>");
7400 error (_("Type %s has no component named %s"),
7401 type_as_string (type
).c_str (), name_str
);
7407 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7408 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7409 represents an unchecked union (that is, the variant part of a
7410 record that is named in an Unchecked_Union pragma). */
7413 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7415 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7417 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7421 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7422 within OUTER, determine which variant clause (field number in VAR_TYPE,
7423 numbering from 0) is applicable. Returns -1 if none are. */
7426 ada_which_variant_applies (struct type
*var_type
, struct value
*outer
)
7430 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7431 struct value
*discrim
;
7432 LONGEST discrim_val
;
7434 /* Using plain value_from_contents_and_address here causes problems
7435 because we will end up trying to resolve a type that is currently
7436 being constructed. */
7437 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7438 if (discrim
== NULL
)
7440 discrim_val
= value_as_long (discrim
);
7443 for (i
= 0; i
< var_type
->num_fields (); i
+= 1)
7445 if (ada_is_others_clause (var_type
, i
))
7447 else if (ada_in_variant (discrim_val
, var_type
, i
))
7451 return others_clause
;
7456 /* Dynamic-Sized Records */
7458 /* Strategy: The type ostensibly attached to a value with dynamic size
7459 (i.e., a size that is not statically recorded in the debugging
7460 data) does not accurately reflect the size or layout of the value.
7461 Our strategy is to convert these values to values with accurate,
7462 conventional types that are constructed on the fly. */
7464 /* There is a subtle and tricky problem here. In general, we cannot
7465 determine the size of dynamic records without its data. However,
7466 the 'struct value' data structure, which GDB uses to represent
7467 quantities in the inferior process (the target), requires the size
7468 of the type at the time of its allocation in order to reserve space
7469 for GDB's internal copy of the data. That's why the
7470 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7471 rather than struct value*s.
7473 However, GDB's internal history variables ($1, $2, etc.) are
7474 struct value*s containing internal copies of the data that are not, in
7475 general, the same as the data at their corresponding addresses in
7476 the target. Fortunately, the types we give to these values are all
7477 conventional, fixed-size types (as per the strategy described
7478 above), so that we don't usually have to perform the
7479 'to_fixed_xxx_type' conversions to look at their values.
7480 Unfortunately, there is one exception: if one of the internal
7481 history variables is an array whose elements are unconstrained
7482 records, then we will need to create distinct fixed types for each
7483 element selected. */
7485 /* The upshot of all of this is that many routines take a (type, host
7486 address, target address) triple as arguments to represent a value.
7487 The host address, if non-null, is supposed to contain an internal
7488 copy of the relevant data; otherwise, the program is to consult the
7489 target at the target address. */
7491 /* Assuming that VAL0 represents a pointer value, the result of
7492 dereferencing it. Differs from value_ind in its treatment of
7493 dynamic-sized types. */
7496 ada_value_ind (struct value
*val0
)
7498 struct value
*val
= value_ind (val0
);
7500 if (ada_is_tagged_type (value_type (val
), 0))
7501 val
= ada_tag_value_at_base_address (val
);
7503 return ada_to_fixed_value (val
);
7506 /* The value resulting from dereferencing any "reference to"
7507 qualifiers on VAL0. */
7509 static struct value
*
7510 ada_coerce_ref (struct value
*val0
)
7512 if (value_type (val0
)->code () == TYPE_CODE_REF
)
7514 struct value
*val
= val0
;
7516 val
= coerce_ref (val
);
7518 if (ada_is_tagged_type (value_type (val
), 0))
7519 val
= ada_tag_value_at_base_address (val
);
7521 return ada_to_fixed_value (val
);
7527 /* Return the bit alignment required for field #F of template type TYPE. */
7530 field_alignment (struct type
*type
, int f
)
7532 const char *name
= TYPE_FIELD_NAME (type
, f
);
7536 /* The field name should never be null, unless the debugging information
7537 is somehow malformed. In this case, we assume the field does not
7538 require any alignment. */
7542 len
= strlen (name
);
7544 if (!isdigit (name
[len
- 1]))
7547 if (isdigit (name
[len
- 2]))
7548 align_offset
= len
- 2;
7550 align_offset
= len
- 1;
7552 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7553 return TARGET_CHAR_BIT
;
7555 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7558 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7560 static struct symbol
*
7561 ada_find_any_type_symbol (const char *name
)
7565 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7566 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7569 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7573 /* Find a type named NAME. Ignores ambiguity. This routine will look
7574 solely for types defined by debug info, it will not search the GDB
7577 static struct type
*
7578 ada_find_any_type (const char *name
)
7580 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7583 return SYMBOL_TYPE (sym
);
7588 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7589 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7590 symbol, in which case it is returned. Otherwise, this looks for
7591 symbols whose name is that of NAME_SYM suffixed with "___XR".
7592 Return symbol if found, and NULL otherwise. */
7595 ada_is_renaming_symbol (struct symbol
*name_sym
)
7597 const char *name
= name_sym
->linkage_name ();
7598 return strstr (name
, "___XR") != NULL
;
7601 /* Because of GNAT encoding conventions, several GDB symbols may match a
7602 given type name. If the type denoted by TYPE0 is to be preferred to
7603 that of TYPE1 for purposes of type printing, return non-zero;
7604 otherwise return 0. */
7607 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7611 else if (type0
== NULL
)
7613 else if (type1
->code () == TYPE_CODE_VOID
)
7615 else if (type0
->code () == TYPE_CODE_VOID
)
7617 else if (type1
->name () == NULL
&& type0
->name () != NULL
)
7619 else if (ada_is_constrained_packed_array_type (type0
))
7621 else if (ada_is_array_descriptor_type (type0
)
7622 && !ada_is_array_descriptor_type (type1
))
7626 const char *type0_name
= type0
->name ();
7627 const char *type1_name
= type1
->name ();
7629 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7630 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7636 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7640 ada_type_name (struct type
*type
)
7644 return type
->name ();
7647 /* Search the list of "descriptive" types associated to TYPE for a type
7648 whose name is NAME. */
7650 static struct type
*
7651 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7653 struct type
*result
, *tmp
;
7655 if (ada_ignore_descriptive_types_p
)
7658 /* If there no descriptive-type info, then there is no parallel type
7660 if (!HAVE_GNAT_AUX_INFO (type
))
7663 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7664 while (result
!= NULL
)
7666 const char *result_name
= ada_type_name (result
);
7668 if (result_name
== NULL
)
7670 warning (_("unexpected null name on descriptive type"));
7674 /* If the names match, stop. */
7675 if (strcmp (result_name
, name
) == 0)
7678 /* Otherwise, look at the next item on the list, if any. */
7679 if (HAVE_GNAT_AUX_INFO (result
))
7680 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7684 /* If not found either, try after having resolved the typedef. */
7689 result
= check_typedef (result
);
7690 if (HAVE_GNAT_AUX_INFO (result
))
7691 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7697 /* If we didn't find a match, see whether this is a packed array. With
7698 older compilers, the descriptive type information is either absent or
7699 irrelevant when it comes to packed arrays so the above lookup fails.
7700 Fall back to using a parallel lookup by name in this case. */
7701 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7702 return ada_find_any_type (name
);
7707 /* Find a parallel type to TYPE with the specified NAME, using the
7708 descriptive type taken from the debugging information, if available,
7709 and otherwise using the (slower) name-based method. */
7711 static struct type
*
7712 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7714 struct type
*result
= NULL
;
7716 if (HAVE_GNAT_AUX_INFO (type
))
7717 result
= find_parallel_type_by_descriptive_type (type
, name
);
7719 result
= ada_find_any_type (name
);
7724 /* Same as above, but specify the name of the parallel type by appending
7725 SUFFIX to the name of TYPE. */
7728 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7731 const char *type_name
= ada_type_name (type
);
7734 if (type_name
== NULL
)
7737 len
= strlen (type_name
);
7739 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7741 strcpy (name
, type_name
);
7742 strcpy (name
+ len
, suffix
);
7744 return ada_find_parallel_type_with_name (type
, name
);
7747 /* If TYPE is a variable-size record type, return the corresponding template
7748 type describing its fields. Otherwise, return NULL. */
7750 static struct type
*
7751 dynamic_template_type (struct type
*type
)
7753 type
= ada_check_typedef (type
);
7755 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
7756 || ada_type_name (type
) == NULL
)
7760 int len
= strlen (ada_type_name (type
));
7762 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7765 return ada_find_parallel_type (type
, "___XVE");
7769 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7770 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7773 is_dynamic_field (struct type
*templ_type
, int field_num
)
7775 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7778 && templ_type
->field (field_num
).type ()->code () == TYPE_CODE_PTR
7779 && strstr (name
, "___XVL") != NULL
;
7782 /* The index of the variant field of TYPE, or -1 if TYPE does not
7783 represent a variant record type. */
7786 variant_field_index (struct type
*type
)
7790 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
7793 for (f
= 0; f
< type
->num_fields (); f
+= 1)
7795 if (ada_is_variant_part (type
, f
))
7801 /* A record type with no fields. */
7803 static struct type
*
7804 empty_record (struct type
*templ
)
7806 struct type
*type
= alloc_type_copy (templ
);
7808 type
->set_code (TYPE_CODE_STRUCT
);
7809 INIT_NONE_SPECIFIC (type
);
7810 type
->set_name ("<empty>");
7811 TYPE_LENGTH (type
) = 0;
7815 /* An ordinary record type (with fixed-length fields) that describes
7816 the value of type TYPE at VALADDR or ADDRESS (see comments at
7817 the beginning of this section) VAL according to GNAT conventions.
7818 DVAL0 should describe the (portion of a) record that contains any
7819 necessary discriminants. It should be NULL if value_type (VAL) is
7820 an outer-level type (i.e., as opposed to a branch of a variant.) A
7821 variant field (unless unchecked) is replaced by a particular branch
7824 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7825 length are not statically known are discarded. As a consequence,
7826 VALADDR, ADDRESS and DVAL0 are ignored.
7828 NOTE: Limitations: For now, we assume that dynamic fields and
7829 variants occupy whole numbers of bytes. However, they need not be
7833 ada_template_to_fixed_record_type_1 (struct type
*type
,
7834 const gdb_byte
*valaddr
,
7835 CORE_ADDR address
, struct value
*dval0
,
7836 int keep_dynamic_fields
)
7838 struct value
*mark
= value_mark ();
7841 int nfields
, bit_len
;
7847 /* Compute the number of fields in this record type that are going
7848 to be processed: unless keep_dynamic_fields, this includes only
7849 fields whose position and length are static will be processed. */
7850 if (keep_dynamic_fields
)
7851 nfields
= type
->num_fields ();
7855 while (nfields
< type
->num_fields ()
7856 && !ada_is_variant_part (type
, nfields
)
7857 && !is_dynamic_field (type
, nfields
))
7861 rtype
= alloc_type_copy (type
);
7862 rtype
->set_code (TYPE_CODE_STRUCT
);
7863 INIT_NONE_SPECIFIC (rtype
);
7864 rtype
->set_num_fields (nfields
);
7866 ((struct field
*) TYPE_ZALLOC (rtype
, nfields
* sizeof (struct field
)));
7867 rtype
->set_name (ada_type_name (type
));
7868 TYPE_FIXED_INSTANCE (rtype
) = 1;
7874 for (f
= 0; f
< nfields
; f
+= 1)
7876 off
= align_up (off
, field_alignment (type
, f
))
7877 + TYPE_FIELD_BITPOS (type
, f
);
7878 SET_FIELD_BITPOS (rtype
->field (f
), off
);
7879 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7881 if (ada_is_variant_part (type
, f
))
7886 else if (is_dynamic_field (type
, f
))
7888 const gdb_byte
*field_valaddr
= valaddr
;
7889 CORE_ADDR field_address
= address
;
7890 struct type
*field_type
=
7891 TYPE_TARGET_TYPE (type
->field (f
).type ());
7895 /* rtype's length is computed based on the run-time
7896 value of discriminants. If the discriminants are not
7897 initialized, the type size may be completely bogus and
7898 GDB may fail to allocate a value for it. So check the
7899 size first before creating the value. */
7900 ada_ensure_varsize_limit (rtype
);
7901 /* Using plain value_from_contents_and_address here
7902 causes problems because we will end up trying to
7903 resolve a type that is currently being
7905 dval
= value_from_contents_and_address_unresolved (rtype
,
7908 rtype
= value_type (dval
);
7913 /* If the type referenced by this field is an aligner type, we need
7914 to unwrap that aligner type, because its size might not be set.
7915 Keeping the aligner type would cause us to compute the wrong
7916 size for this field, impacting the offset of the all the fields
7917 that follow this one. */
7918 if (ada_is_aligner_type (field_type
))
7920 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7922 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7923 field_address
= cond_offset_target (field_address
, field_offset
);
7924 field_type
= ada_aligned_type (field_type
);
7927 field_valaddr
= cond_offset_host (field_valaddr
,
7928 off
/ TARGET_CHAR_BIT
);
7929 field_address
= cond_offset_target (field_address
,
7930 off
/ TARGET_CHAR_BIT
);
7932 /* Get the fixed type of the field. Note that, in this case,
7933 we do not want to get the real type out of the tag: if
7934 the current field is the parent part of a tagged record,
7935 we will get the tag of the object. Clearly wrong: the real
7936 type of the parent is not the real type of the child. We
7937 would end up in an infinite loop. */
7938 field_type
= ada_get_base_type (field_type
);
7939 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7940 field_address
, dval
, 0);
7941 /* If the field size is already larger than the maximum
7942 object size, then the record itself will necessarily
7943 be larger than the maximum object size. We need to make
7944 this check now, because the size might be so ridiculously
7945 large (due to an uninitialized variable in the inferior)
7946 that it would cause an overflow when adding it to the
7948 ada_ensure_varsize_limit (field_type
);
7950 rtype
->field (f
).set_type (field_type
);
7951 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7952 /* The multiplication can potentially overflow. But because
7953 the field length has been size-checked just above, and
7954 assuming that the maximum size is a reasonable value,
7955 an overflow should not happen in practice. So rather than
7956 adding overflow recovery code to this already complex code,
7957 we just assume that it's not going to happen. */
7959 TYPE_LENGTH (rtype
->field (f
).type ()) * TARGET_CHAR_BIT
;
7963 /* Note: If this field's type is a typedef, it is important
7964 to preserve the typedef layer.
7966 Otherwise, we might be transforming a typedef to a fat
7967 pointer (encoding a pointer to an unconstrained array),
7968 into a basic fat pointer (encoding an unconstrained
7969 array). As both types are implemented using the same
7970 structure, the typedef is the only clue which allows us
7971 to distinguish between the two options. Stripping it
7972 would prevent us from printing this field appropriately. */
7973 rtype
->field (f
).set_type (type
->field (f
).type ());
7974 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7975 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7977 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7980 struct type
*field_type
= type
->field (f
).type ();
7982 /* We need to be careful of typedefs when computing
7983 the length of our field. If this is a typedef,
7984 get the length of the target type, not the length
7986 if (field_type
->code () == TYPE_CODE_TYPEDEF
)
7987 field_type
= ada_typedef_target_type (field_type
);
7990 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
7993 if (off
+ fld_bit_len
> bit_len
)
7994 bit_len
= off
+ fld_bit_len
;
7996 TYPE_LENGTH (rtype
) =
7997 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8000 /* We handle the variant part, if any, at the end because of certain
8001 odd cases in which it is re-ordered so as NOT to be the last field of
8002 the record. This can happen in the presence of representation
8004 if (variant_field
>= 0)
8006 struct type
*branch_type
;
8008 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8012 /* Using plain value_from_contents_and_address here causes
8013 problems because we will end up trying to resolve a type
8014 that is currently being constructed. */
8015 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8017 rtype
= value_type (dval
);
8023 to_fixed_variant_branch_type
8024 (type
->field (variant_field
).type (),
8025 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8026 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8027 if (branch_type
== NULL
)
8029 for (f
= variant_field
+ 1; f
< rtype
->num_fields (); f
+= 1)
8030 rtype
->field (f
- 1) = rtype
->field (f
);
8031 rtype
->set_num_fields (rtype
->num_fields () - 1);
8035 rtype
->field (variant_field
).set_type (branch_type
);
8036 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8038 TYPE_LENGTH (rtype
->field (variant_field
).type ()) *
8040 if (off
+ fld_bit_len
> bit_len
)
8041 bit_len
= off
+ fld_bit_len
;
8042 TYPE_LENGTH (rtype
) =
8043 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8047 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8048 should contain the alignment of that record, which should be a strictly
8049 positive value. If null or negative, then something is wrong, most
8050 probably in the debug info. In that case, we don't round up the size
8051 of the resulting type. If this record is not part of another structure,
8052 the current RTYPE length might be good enough for our purposes. */
8053 if (TYPE_LENGTH (type
) <= 0)
8056 warning (_("Invalid type size for `%s' detected: %s."),
8057 rtype
->name (), pulongest (TYPE_LENGTH (type
)));
8059 warning (_("Invalid type size for <unnamed> detected: %s."),
8060 pulongest (TYPE_LENGTH (type
)));
8064 TYPE_LENGTH (rtype
) = align_up (TYPE_LENGTH (rtype
),
8065 TYPE_LENGTH (type
));
8068 value_free_to_mark (mark
);
8069 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8070 error (_("record type with dynamic size is larger than varsize-limit"));
8074 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8077 static struct type
*
8078 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8079 CORE_ADDR address
, struct value
*dval0
)
8081 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8085 /* An ordinary record type in which ___XVL-convention fields and
8086 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8087 static approximations, containing all possible fields. Uses
8088 no runtime values. Useless for use in values, but that's OK,
8089 since the results are used only for type determinations. Works on both
8090 structs and unions. Representation note: to save space, we memorize
8091 the result of this function in the TYPE_TARGET_TYPE of the
8094 static struct type
*
8095 template_to_static_fixed_type (struct type
*type0
)
8101 /* No need no do anything if the input type is already fixed. */
8102 if (TYPE_FIXED_INSTANCE (type0
))
8105 /* Likewise if we already have computed the static approximation. */
8106 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8107 return TYPE_TARGET_TYPE (type0
);
8109 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8111 nfields
= type0
->num_fields ();
8113 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8114 recompute all over next time. */
8115 TYPE_TARGET_TYPE (type0
) = type
;
8117 for (f
= 0; f
< nfields
; f
+= 1)
8119 struct type
*field_type
= type0
->field (f
).type ();
8120 struct type
*new_type
;
8122 if (is_dynamic_field (type0
, f
))
8124 field_type
= ada_check_typedef (field_type
);
8125 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8128 new_type
= static_unwrap_type (field_type
);
8130 if (new_type
!= field_type
)
8132 /* Clone TYPE0 only the first time we get a new field type. */
8135 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8136 type
->set_code (type0
->code ());
8137 INIT_NONE_SPECIFIC (type
);
8138 type
->set_num_fields (nfields
);
8142 TYPE_ALLOC (type
, nfields
* sizeof (struct field
)));
8143 memcpy (fields
, type0
->fields (),
8144 sizeof (struct field
) * nfields
);
8145 type
->set_fields (fields
);
8147 type
->set_name (ada_type_name (type0
));
8148 TYPE_FIXED_INSTANCE (type
) = 1;
8149 TYPE_LENGTH (type
) = 0;
8151 type
->field (f
).set_type (new_type
);
8152 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8159 /* Given an object of type TYPE whose contents are at VALADDR and
8160 whose address in memory is ADDRESS, returns a revision of TYPE,
8161 which should be a non-dynamic-sized record, in which the variant
8162 part, if any, is replaced with the appropriate branch. Looks
8163 for discriminant values in DVAL0, which can be NULL if the record
8164 contains the necessary discriminant values. */
8166 static struct type
*
8167 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8168 CORE_ADDR address
, struct value
*dval0
)
8170 struct value
*mark
= value_mark ();
8173 struct type
*branch_type
;
8174 int nfields
= type
->num_fields ();
8175 int variant_field
= variant_field_index (type
);
8177 if (variant_field
== -1)
8182 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8183 type
= value_type (dval
);
8188 rtype
= alloc_type_copy (type
);
8189 rtype
->set_code (TYPE_CODE_STRUCT
);
8190 INIT_NONE_SPECIFIC (rtype
);
8191 rtype
->set_num_fields (nfields
);
8194 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8195 memcpy (fields
, type
->fields (), sizeof (struct field
) * nfields
);
8196 rtype
->set_fields (fields
);
8198 rtype
->set_name (ada_type_name (type
));
8199 TYPE_FIXED_INSTANCE (rtype
) = 1;
8200 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8202 branch_type
= to_fixed_variant_branch_type
8203 (type
->field (variant_field
).type (),
8204 cond_offset_host (valaddr
,
8205 TYPE_FIELD_BITPOS (type
, variant_field
)
8207 cond_offset_target (address
,
8208 TYPE_FIELD_BITPOS (type
, variant_field
)
8209 / TARGET_CHAR_BIT
), dval
);
8210 if (branch_type
== NULL
)
8214 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8215 rtype
->field (f
- 1) = rtype
->field (f
);
8216 rtype
->set_num_fields (rtype
->num_fields () - 1);
8220 rtype
->field (variant_field
).set_type (branch_type
);
8221 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8222 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8223 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8225 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (type
->field (variant_field
).type ());
8227 value_free_to_mark (mark
);
8231 /* An ordinary record type (with fixed-length fields) that describes
8232 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8233 beginning of this section]. Any necessary discriminants' values
8234 should be in DVAL, a record value; it may be NULL if the object
8235 at ADDR itself contains any necessary discriminant values.
8236 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8237 values from the record are needed. Except in the case that DVAL,
8238 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8239 unchecked) is replaced by a particular branch of the variant.
8241 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8242 is questionable and may be removed. It can arise during the
8243 processing of an unconstrained-array-of-record type where all the
8244 variant branches have exactly the same size. This is because in
8245 such cases, the compiler does not bother to use the XVS convention
8246 when encoding the record. I am currently dubious of this
8247 shortcut and suspect the compiler should be altered. FIXME. */
8249 static struct type
*
8250 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8251 CORE_ADDR address
, struct value
*dval
)
8253 struct type
*templ_type
;
8255 if (TYPE_FIXED_INSTANCE (type0
))
8258 templ_type
= dynamic_template_type (type0
);
8260 if (templ_type
!= NULL
)
8261 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8262 else if (variant_field_index (type0
) >= 0)
8264 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8266 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8271 TYPE_FIXED_INSTANCE (type0
) = 1;
8277 /* An ordinary record type (with fixed-length fields) that describes
8278 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8279 union type. Any necessary discriminants' values should be in DVAL,
8280 a record value. That is, this routine selects the appropriate
8281 branch of the union at ADDR according to the discriminant value
8282 indicated in the union's type name. Returns VAR_TYPE0 itself if
8283 it represents a variant subject to a pragma Unchecked_Union. */
8285 static struct type
*
8286 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8287 CORE_ADDR address
, struct value
*dval
)
8290 struct type
*templ_type
;
8291 struct type
*var_type
;
8293 if (var_type0
->code () == TYPE_CODE_PTR
)
8294 var_type
= TYPE_TARGET_TYPE (var_type0
);
8296 var_type
= var_type0
;
8298 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8300 if (templ_type
!= NULL
)
8301 var_type
= templ_type
;
8303 if (is_unchecked_variant (var_type
, value_type (dval
)))
8305 which
= ada_which_variant_applies (var_type
, dval
);
8308 return empty_record (var_type
);
8309 else if (is_dynamic_field (var_type
, which
))
8310 return to_fixed_record_type
8311 (TYPE_TARGET_TYPE (var_type
->field (which
).type ()),
8312 valaddr
, address
, dval
);
8313 else if (variant_field_index (var_type
->field (which
).type ()) >= 0)
8315 to_fixed_record_type
8316 (var_type
->field (which
).type (), valaddr
, address
, dval
);
8318 return var_type
->field (which
).type ();
8321 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8322 ENCODING_TYPE, a type following the GNAT conventions for discrete
8323 type encodings, only carries redundant information. */
8326 ada_is_redundant_range_encoding (struct type
*range_type
,
8327 struct type
*encoding_type
)
8329 const char *bounds_str
;
8333 gdb_assert (range_type
->code () == TYPE_CODE_RANGE
);
8335 if (get_base_type (range_type
)->code ()
8336 != get_base_type (encoding_type
)->code ())
8338 /* The compiler probably used a simple base type to describe
8339 the range type instead of the range's actual base type,
8340 expecting us to get the real base type from the encoding
8341 anyway. In this situation, the encoding cannot be ignored
8346 if (is_dynamic_type (range_type
))
8349 if (encoding_type
->name () == NULL
)
8352 bounds_str
= strstr (encoding_type
->name (), "___XDLU_");
8353 if (bounds_str
== NULL
)
8356 n
= 8; /* Skip "___XDLU_". */
8357 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8359 if (TYPE_LOW_BOUND (range_type
) != lo
)
8362 n
+= 2; /* Skip the "__" separator between the two bounds. */
8363 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8365 if (TYPE_HIGH_BOUND (range_type
) != hi
)
8371 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8372 a type following the GNAT encoding for describing array type
8373 indices, only carries redundant information. */
8376 ada_is_redundant_index_type_desc (struct type
*array_type
,
8377 struct type
*desc_type
)
8379 struct type
*this_layer
= check_typedef (array_type
);
8382 for (i
= 0; i
< desc_type
->num_fields (); i
++)
8384 if (!ada_is_redundant_range_encoding (this_layer
->index_type (),
8385 desc_type
->field (i
).type ()))
8387 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8393 /* Assuming that TYPE0 is an array type describing the type of a value
8394 at ADDR, and that DVAL describes a record containing any
8395 discriminants used in TYPE0, returns a type for the value that
8396 contains no dynamic components (that is, no components whose sizes
8397 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8398 true, gives an error message if the resulting type's size is over
8401 static struct type
*
8402 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8405 struct type
*index_type_desc
;
8406 struct type
*result
;
8407 int constrained_packed_array_p
;
8408 static const char *xa_suffix
= "___XA";
8410 type0
= ada_check_typedef (type0
);
8411 if (TYPE_FIXED_INSTANCE (type0
))
8414 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8415 if (constrained_packed_array_p
)
8416 type0
= decode_constrained_packed_array_type (type0
);
8418 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8420 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8421 encoding suffixed with 'P' may still be generated. If so,
8422 it should be used to find the XA type. */
8424 if (index_type_desc
== NULL
)
8426 const char *type_name
= ada_type_name (type0
);
8428 if (type_name
!= NULL
)
8430 const int len
= strlen (type_name
);
8431 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8433 if (type_name
[len
- 1] == 'P')
8435 strcpy (name
, type_name
);
8436 strcpy (name
+ len
- 1, xa_suffix
);
8437 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8442 ada_fixup_array_indexes_type (index_type_desc
);
8443 if (index_type_desc
!= NULL
8444 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8446 /* Ignore this ___XA parallel type, as it does not bring any
8447 useful information. This allows us to avoid creating fixed
8448 versions of the array's index types, which would be identical
8449 to the original ones. This, in turn, can also help avoid
8450 the creation of fixed versions of the array itself. */
8451 index_type_desc
= NULL
;
8454 if (index_type_desc
== NULL
)
8456 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8458 /* NOTE: elt_type---the fixed version of elt_type0---should never
8459 depend on the contents of the array in properly constructed
8461 /* Create a fixed version of the array element type.
8462 We're not providing the address of an element here,
8463 and thus the actual object value cannot be inspected to do
8464 the conversion. This should not be a problem, since arrays of
8465 unconstrained objects are not allowed. In particular, all
8466 the elements of an array of a tagged type should all be of
8467 the same type specified in the debugging info. No need to
8468 consult the object tag. */
8469 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8471 /* Make sure we always create a new array type when dealing with
8472 packed array types, since we're going to fix-up the array
8473 type length and element bitsize a little further down. */
8474 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8477 result
= create_array_type (alloc_type_copy (type0
),
8478 elt_type
, type0
->index_type ());
8483 struct type
*elt_type0
;
8486 for (i
= index_type_desc
->num_fields (); i
> 0; i
-= 1)
8487 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8489 /* NOTE: result---the fixed version of elt_type0---should never
8490 depend on the contents of the array in properly constructed
8492 /* Create a fixed version of the array element type.
8493 We're not providing the address of an element here,
8494 and thus the actual object value cannot be inspected to do
8495 the conversion. This should not be a problem, since arrays of
8496 unconstrained objects are not allowed. In particular, all
8497 the elements of an array of a tagged type should all be of
8498 the same type specified in the debugging info. No need to
8499 consult the object tag. */
8501 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8504 for (i
= index_type_desc
->num_fields () - 1; i
>= 0; i
-= 1)
8506 struct type
*range_type
=
8507 to_fixed_range_type (index_type_desc
->field (i
).type (), dval
);
8509 result
= create_array_type (alloc_type_copy (elt_type0
),
8510 result
, range_type
);
8511 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8513 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8514 error (_("array type with dynamic size is larger than varsize-limit"));
8517 /* We want to preserve the type name. This can be useful when
8518 trying to get the type name of a value that has already been
8519 printed (for instance, if the user did "print VAR; whatis $". */
8520 result
->set_name (type0
->name ());
8522 if (constrained_packed_array_p
)
8524 /* So far, the resulting type has been created as if the original
8525 type was a regular (non-packed) array type. As a result, the
8526 bitsize of the array elements needs to be set again, and the array
8527 length needs to be recomputed based on that bitsize. */
8528 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8529 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8531 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8532 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8533 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8534 TYPE_LENGTH (result
)++;
8537 TYPE_FIXED_INSTANCE (result
) = 1;
8542 /* A standard type (containing no dynamically sized components)
8543 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8544 DVAL describes a record containing any discriminants used in TYPE0,
8545 and may be NULL if there are none, or if the object of type TYPE at
8546 ADDRESS or in VALADDR contains these discriminants.
8548 If CHECK_TAG is not null, in the case of tagged types, this function
8549 attempts to locate the object's tag and use it to compute the actual
8550 type. However, when ADDRESS is null, we cannot use it to determine the
8551 location of the tag, and therefore compute the tagged type's actual type.
8552 So we return the tagged type without consulting the tag. */
8554 static struct type
*
8555 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8556 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8558 type
= ada_check_typedef (type
);
8560 /* Only un-fixed types need to be handled here. */
8561 if (!HAVE_GNAT_AUX_INFO (type
))
8564 switch (type
->code ())
8568 case TYPE_CODE_STRUCT
:
8570 struct type
*static_type
= to_static_fixed_type (type
);
8571 struct type
*fixed_record_type
=
8572 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8574 /* If STATIC_TYPE is a tagged type and we know the object's address,
8575 then we can determine its tag, and compute the object's actual
8576 type from there. Note that we have to use the fixed record
8577 type (the parent part of the record may have dynamic fields
8578 and the way the location of _tag is expressed may depend on
8581 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8584 value_tag_from_contents_and_address
8588 struct type
*real_type
= type_from_tag (tag
);
8590 value_from_contents_and_address (fixed_record_type
,
8593 fixed_record_type
= value_type (obj
);
8594 if (real_type
!= NULL
)
8595 return to_fixed_record_type
8597 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8600 /* Check to see if there is a parallel ___XVZ variable.
8601 If there is, then it provides the actual size of our type. */
8602 else if (ada_type_name (fixed_record_type
) != NULL
)
8604 const char *name
= ada_type_name (fixed_record_type
);
8606 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8607 bool xvz_found
= false;
8610 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8613 xvz_found
= get_int_var_value (xvz_name
, size
);
8615 catch (const gdb_exception_error
&except
)
8617 /* We found the variable, but somehow failed to read
8618 its value. Rethrow the same error, but with a little
8619 bit more information, to help the user understand
8620 what went wrong (Eg: the variable might have been
8622 throw_error (except
.error
,
8623 _("unable to read value of %s (%s)"),
8624 xvz_name
, except
.what ());
8627 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8629 fixed_record_type
= copy_type (fixed_record_type
);
8630 TYPE_LENGTH (fixed_record_type
) = size
;
8632 /* The FIXED_RECORD_TYPE may have be a stub. We have
8633 observed this when the debugging info is STABS, and
8634 apparently it is something that is hard to fix.
8636 In practice, we don't need the actual type definition
8637 at all, because the presence of the XVZ variable allows us
8638 to assume that there must be a XVS type as well, which we
8639 should be able to use later, when we need the actual type
8642 In the meantime, pretend that the "fixed" type we are
8643 returning is NOT a stub, because this can cause trouble
8644 when using this type to create new types targeting it.
8645 Indeed, the associated creation routines often check
8646 whether the target type is a stub and will try to replace
8647 it, thus using a type with the wrong size. This, in turn,
8648 might cause the new type to have the wrong size too.
8649 Consider the case of an array, for instance, where the size
8650 of the array is computed from the number of elements in
8651 our array multiplied by the size of its element. */
8652 TYPE_STUB (fixed_record_type
) = 0;
8655 return fixed_record_type
;
8657 case TYPE_CODE_ARRAY
:
8658 return to_fixed_array_type (type
, dval
, 1);
8659 case TYPE_CODE_UNION
:
8663 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8667 /* The same as ada_to_fixed_type_1, except that it preserves the type
8668 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8670 The typedef layer needs be preserved in order to differentiate between
8671 arrays and array pointers when both types are implemented using the same
8672 fat pointer. In the array pointer case, the pointer is encoded as
8673 a typedef of the pointer type. For instance, considering:
8675 type String_Access is access String;
8676 S1 : String_Access := null;
8678 To the debugger, S1 is defined as a typedef of type String. But
8679 to the user, it is a pointer. So if the user tries to print S1,
8680 we should not dereference the array, but print the array address
8683 If we didn't preserve the typedef layer, we would lose the fact that
8684 the type is to be presented as a pointer (needs de-reference before
8685 being printed). And we would also use the source-level type name. */
8688 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8689 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8692 struct type
*fixed_type
=
8693 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8695 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8696 then preserve the typedef layer.
8698 Implementation note: We can only check the main-type portion of
8699 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8700 from TYPE now returns a type that has the same instance flags
8701 as TYPE. For instance, if TYPE is a "typedef const", and its
8702 target type is a "struct", then the typedef elimination will return
8703 a "const" version of the target type. See check_typedef for more
8704 details about how the typedef layer elimination is done.
8706 brobecker/2010-11-19: It seems to me that the only case where it is
8707 useful to preserve the typedef layer is when dealing with fat pointers.
8708 Perhaps, we could add a check for that and preserve the typedef layer
8709 only in that situation. But this seems unnecessary so far, probably
8710 because we call check_typedef/ada_check_typedef pretty much everywhere.
8712 if (type
->code () == TYPE_CODE_TYPEDEF
8713 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8714 == TYPE_MAIN_TYPE (fixed_type
)))
8720 /* A standard (static-sized) type corresponding as well as possible to
8721 TYPE0, but based on no runtime data. */
8723 static struct type
*
8724 to_static_fixed_type (struct type
*type0
)
8731 if (TYPE_FIXED_INSTANCE (type0
))
8734 type0
= ada_check_typedef (type0
);
8736 switch (type0
->code ())
8740 case TYPE_CODE_STRUCT
:
8741 type
= dynamic_template_type (type0
);
8743 return template_to_static_fixed_type (type
);
8745 return template_to_static_fixed_type (type0
);
8746 case TYPE_CODE_UNION
:
8747 type
= ada_find_parallel_type (type0
, "___XVU");
8749 return template_to_static_fixed_type (type
);
8751 return template_to_static_fixed_type (type0
);
8755 /* A static approximation of TYPE with all type wrappers removed. */
8757 static struct type
*
8758 static_unwrap_type (struct type
*type
)
8760 if (ada_is_aligner_type (type
))
8762 struct type
*type1
= ada_check_typedef (type
)->field (0).type ();
8763 if (ada_type_name (type1
) == NULL
)
8764 type1
->set_name (ada_type_name (type
));
8766 return static_unwrap_type (type1
);
8770 struct type
*raw_real_type
= ada_get_base_type (type
);
8772 if (raw_real_type
== type
)
8775 return to_static_fixed_type (raw_real_type
);
8779 /* In some cases, incomplete and private types require
8780 cross-references that are not resolved as records (for example,
8782 type FooP is access Foo;
8784 type Foo is array ...;
8785 ). In these cases, since there is no mechanism for producing
8786 cross-references to such types, we instead substitute for FooP a
8787 stub enumeration type that is nowhere resolved, and whose tag is
8788 the name of the actual type. Call these types "non-record stubs". */
8790 /* A type equivalent to TYPE that is not a non-record stub, if one
8791 exists, otherwise TYPE. */
8794 ada_check_typedef (struct type
*type
)
8799 /* If our type is an access to an unconstrained array, which is encoded
8800 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8801 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8802 what allows us to distinguish between fat pointers that represent
8803 array types, and fat pointers that represent array access types
8804 (in both cases, the compiler implements them as fat pointers). */
8805 if (ada_is_access_to_unconstrained_array (type
))
8808 type
= check_typedef (type
);
8809 if (type
== NULL
|| type
->code () != TYPE_CODE_ENUM
8810 || !TYPE_STUB (type
)
8811 || type
->name () == NULL
)
8815 const char *name
= type
->name ();
8816 struct type
*type1
= ada_find_any_type (name
);
8821 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8822 stubs pointing to arrays, as we don't create symbols for array
8823 types, only for the typedef-to-array types). If that's the case,
8824 strip the typedef layer. */
8825 if (type1
->code () == TYPE_CODE_TYPEDEF
)
8826 type1
= ada_check_typedef (type1
);
8832 /* A value representing the data at VALADDR/ADDRESS as described by
8833 type TYPE0, but with a standard (static-sized) type that correctly
8834 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8835 type, then return VAL0 [this feature is simply to avoid redundant
8836 creation of struct values]. */
8838 static struct value
*
8839 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8842 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8844 if (type
== type0
&& val0
!= NULL
)
8847 if (VALUE_LVAL (val0
) != lval_memory
)
8849 /* Our value does not live in memory; it could be a convenience
8850 variable, for instance. Create a not_lval value using val0's
8852 return value_from_contents (type
, value_contents (val0
));
8855 return value_from_contents_and_address (type
, 0, address
);
8858 /* A value representing VAL, but with a standard (static-sized) type
8859 that correctly describes it. Does not necessarily create a new
8863 ada_to_fixed_value (struct value
*val
)
8865 val
= unwrap_value (val
);
8866 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
8873 /* Table mapping attribute numbers to names.
8874 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8876 static const char *attribute_names
[] = {
8894 ada_attribute_name (enum exp_opcode n
)
8896 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8897 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8899 return attribute_names
[0];
8902 /* Evaluate the 'POS attribute applied to ARG. */
8905 pos_atr (struct value
*arg
)
8907 struct value
*val
= coerce_ref (arg
);
8908 struct type
*type
= value_type (val
);
8911 if (!discrete_type_p (type
))
8912 error (_("'POS only defined on discrete types"));
8914 if (!discrete_position (type
, value_as_long (val
), &result
))
8915 error (_("enumeration value is invalid: can't find 'POS"));
8920 static struct value
*
8921 value_pos_atr (struct type
*type
, struct value
*arg
)
8923 return value_from_longest (type
, pos_atr (arg
));
8926 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8928 static struct value
*
8929 val_atr (struct type
*type
, LONGEST val
)
8931 gdb_assert (discrete_type_p (type
));
8932 if (type
->code () == TYPE_CODE_RANGE
)
8933 type
= TYPE_TARGET_TYPE (type
);
8934 if (type
->code () == TYPE_CODE_ENUM
)
8936 if (val
< 0 || val
>= type
->num_fields ())
8937 error (_("argument to 'VAL out of range"));
8938 val
= TYPE_FIELD_ENUMVAL (type
, val
);
8940 return value_from_longest (type
, val
);
8943 static struct value
*
8944 value_val_atr (struct type
*type
, struct value
*arg
)
8946 if (!discrete_type_p (type
))
8947 error (_("'VAL only defined on discrete types"));
8948 if (!integer_type_p (value_type (arg
)))
8949 error (_("'VAL requires integral argument"));
8951 return val_atr (type
, value_as_long (arg
));
8957 /* True if TYPE appears to be an Ada character type.
8958 [At the moment, this is true only for Character and Wide_Character;
8959 It is a heuristic test that could stand improvement]. */
8962 ada_is_character_type (struct type
*type
)
8966 /* If the type code says it's a character, then assume it really is,
8967 and don't check any further. */
8968 if (type
->code () == TYPE_CODE_CHAR
)
8971 /* Otherwise, assume it's a character type iff it is a discrete type
8972 with a known character type name. */
8973 name
= ada_type_name (type
);
8974 return (name
!= NULL
8975 && (type
->code () == TYPE_CODE_INT
8976 || type
->code () == TYPE_CODE_RANGE
)
8977 && (strcmp (name
, "character") == 0
8978 || strcmp (name
, "wide_character") == 0
8979 || strcmp (name
, "wide_wide_character") == 0
8980 || strcmp (name
, "unsigned char") == 0));
8983 /* True if TYPE appears to be an Ada string type. */
8986 ada_is_string_type (struct type
*type
)
8988 type
= ada_check_typedef (type
);
8990 && type
->code () != TYPE_CODE_PTR
8991 && (ada_is_simple_array_type (type
)
8992 || ada_is_array_descriptor_type (type
))
8993 && ada_array_arity (type
) == 1)
8995 struct type
*elttype
= ada_array_element_type (type
, 1);
8997 return ada_is_character_type (elttype
);
9003 /* The compiler sometimes provides a parallel XVS type for a given
9004 PAD type. Normally, it is safe to follow the PAD type directly,
9005 but older versions of the compiler have a bug that causes the offset
9006 of its "F" field to be wrong. Following that field in that case
9007 would lead to incorrect results, but this can be worked around
9008 by ignoring the PAD type and using the associated XVS type instead.
9010 Set to True if the debugger should trust the contents of PAD types.
9011 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9012 static bool trust_pad_over_xvs
= true;
9014 /* True if TYPE is a struct type introduced by the compiler to force the
9015 alignment of a value. Such types have a single field with a
9016 distinctive name. */
9019 ada_is_aligner_type (struct type
*type
)
9021 type
= ada_check_typedef (type
);
9023 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9026 return (type
->code () == TYPE_CODE_STRUCT
9027 && type
->num_fields () == 1
9028 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9031 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9032 the parallel type. */
9035 ada_get_base_type (struct type
*raw_type
)
9037 struct type
*real_type_namer
;
9038 struct type
*raw_real_type
;
9040 if (raw_type
== NULL
|| raw_type
->code () != TYPE_CODE_STRUCT
)
9043 if (ada_is_aligner_type (raw_type
))
9044 /* The encoding specifies that we should always use the aligner type.
9045 So, even if this aligner type has an associated XVS type, we should
9048 According to the compiler gurus, an XVS type parallel to an aligner
9049 type may exist because of a stabs limitation. In stabs, aligner
9050 types are empty because the field has a variable-sized type, and
9051 thus cannot actually be used as an aligner type. As a result,
9052 we need the associated parallel XVS type to decode the type.
9053 Since the policy in the compiler is to not change the internal
9054 representation based on the debugging info format, we sometimes
9055 end up having a redundant XVS type parallel to the aligner type. */
9058 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9059 if (real_type_namer
== NULL
9060 || real_type_namer
->code () != TYPE_CODE_STRUCT
9061 || real_type_namer
->num_fields () != 1)
9064 if (real_type_namer
->field (0).type ()->code () != TYPE_CODE_REF
)
9066 /* This is an older encoding form where the base type needs to be
9067 looked up by name. We prefer the newer encoding because it is
9069 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9070 if (raw_real_type
== NULL
)
9073 return raw_real_type
;
9076 /* The field in our XVS type is a reference to the base type. */
9077 return TYPE_TARGET_TYPE (real_type_namer
->field (0).type ());
9080 /* The type of value designated by TYPE, with all aligners removed. */
9083 ada_aligned_type (struct type
*type
)
9085 if (ada_is_aligner_type (type
))
9086 return ada_aligned_type (type
->field (0).type ());
9088 return ada_get_base_type (type
);
9092 /* The address of the aligned value in an object at address VALADDR
9093 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9096 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9098 if (ada_is_aligner_type (type
))
9099 return ada_aligned_value_addr (type
->field (0).type (),
9101 TYPE_FIELD_BITPOS (type
,
9102 0) / TARGET_CHAR_BIT
);
9109 /* The printed representation of an enumeration literal with encoded
9110 name NAME. The value is good to the next call of ada_enum_name. */
9112 ada_enum_name (const char *name
)
9114 static char *result
;
9115 static size_t result_len
= 0;
9118 /* First, unqualify the enumeration name:
9119 1. Search for the last '.' character. If we find one, then skip
9120 all the preceding characters, the unqualified name starts
9121 right after that dot.
9122 2. Otherwise, we may be debugging on a target where the compiler
9123 translates dots into "__". Search forward for double underscores,
9124 but stop searching when we hit an overloading suffix, which is
9125 of the form "__" followed by digits. */
9127 tmp
= strrchr (name
, '.');
9132 while ((tmp
= strstr (name
, "__")) != NULL
)
9134 if (isdigit (tmp
[2]))
9145 if (name
[1] == 'U' || name
[1] == 'W')
9147 if (sscanf (name
+ 2, "%x", &v
) != 1)
9150 else if (((name
[1] >= '0' && name
[1] <= '9')
9151 || (name
[1] >= 'a' && name
[1] <= 'z'))
9154 GROW_VECT (result
, result_len
, 4);
9155 xsnprintf (result
, result_len
, "'%c'", name
[1]);
9161 GROW_VECT (result
, result_len
, 16);
9162 if (isascii (v
) && isprint (v
))
9163 xsnprintf (result
, result_len
, "'%c'", v
);
9164 else if (name
[1] == 'U')
9165 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9167 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9173 tmp
= strstr (name
, "__");
9175 tmp
= strstr (name
, "$");
9178 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9179 strncpy (result
, name
, tmp
- name
);
9180 result
[tmp
- name
] = '\0';
9188 /* Evaluate the subexpression of EXP starting at *POS as for
9189 evaluate_type, updating *POS to point just past the evaluated
9192 static struct value
*
9193 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9195 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9198 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9201 static struct value
*
9202 unwrap_value (struct value
*val
)
9204 struct type
*type
= ada_check_typedef (value_type (val
));
9206 if (ada_is_aligner_type (type
))
9208 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9209 struct type
*val_type
= ada_check_typedef (value_type (v
));
9211 if (ada_type_name (val_type
) == NULL
)
9212 val_type
->set_name (ada_type_name (type
));
9214 return unwrap_value (v
);
9218 struct type
*raw_real_type
=
9219 ada_check_typedef (ada_get_base_type (type
));
9221 /* If there is no parallel XVS or XVE type, then the value is
9222 already unwrapped. Return it without further modification. */
9223 if ((type
== raw_real_type
)
9224 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9228 coerce_unspec_val_to_type
9229 (val
, ada_to_fixed_type (raw_real_type
, 0,
9230 value_address (val
),
9235 static struct value
*
9236 cast_from_fixed (struct type
*type
, struct value
*arg
)
9238 struct value
*scale
= ada_scaling_factor (value_type (arg
));
9239 arg
= value_cast (value_type (scale
), arg
);
9241 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9242 return value_cast (type
, arg
);
9245 static struct value
*
9246 cast_to_fixed (struct type
*type
, struct value
*arg
)
9248 if (type
== value_type (arg
))
9251 struct value
*scale
= ada_scaling_factor (type
);
9252 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg
)))
9253 arg
= cast_from_fixed (value_type (scale
), arg
);
9255 arg
= value_cast (value_type (scale
), arg
);
9257 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9258 return value_cast (type
, arg
);
9261 /* Given two array types T1 and T2, return nonzero iff both arrays
9262 contain the same number of elements. */
9265 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9267 LONGEST lo1
, hi1
, lo2
, hi2
;
9269 /* Get the array bounds in order to verify that the size of
9270 the two arrays match. */
9271 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9272 || !get_array_bounds (t2
, &lo2
, &hi2
))
9273 error (_("unable to determine array bounds"));
9275 /* To make things easier for size comparison, normalize a bit
9276 the case of empty arrays by making sure that the difference
9277 between upper bound and lower bound is always -1. */
9283 return (hi1
- lo1
== hi2
- lo2
);
9286 /* Assuming that VAL is an array of integrals, and TYPE represents
9287 an array with the same number of elements, but with wider integral
9288 elements, return an array "casted" to TYPE. In practice, this
9289 means that the returned array is built by casting each element
9290 of the original array into TYPE's (wider) element type. */
9292 static struct value
*
9293 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9295 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9300 /* Verify that both val and type are arrays of scalars, and
9301 that the size of val's elements is smaller than the size
9302 of type's element. */
9303 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
9304 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9305 gdb_assert (value_type (val
)->code () == TYPE_CODE_ARRAY
);
9306 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9307 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9308 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9310 if (!get_array_bounds (type
, &lo
, &hi
))
9311 error (_("unable to determine array bounds"));
9313 res
= allocate_value (type
);
9315 /* Promote each array element. */
9316 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9318 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9320 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9321 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9327 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9328 return the converted value. */
9330 static struct value
*
9331 coerce_for_assign (struct type
*type
, struct value
*val
)
9333 struct type
*type2
= value_type (val
);
9338 type2
= ada_check_typedef (type2
);
9339 type
= ada_check_typedef (type
);
9341 if (type2
->code () == TYPE_CODE_PTR
9342 && type
->code () == TYPE_CODE_ARRAY
)
9344 val
= ada_value_ind (val
);
9345 type2
= value_type (val
);
9348 if (type2
->code () == TYPE_CODE_ARRAY
9349 && type
->code () == TYPE_CODE_ARRAY
)
9351 if (!ada_same_array_size_p (type
, type2
))
9352 error (_("cannot assign arrays of different length"));
9354 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9355 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9356 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9357 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9359 /* Allow implicit promotion of the array elements to
9361 return ada_promote_array_of_integrals (type
, val
);
9364 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9365 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9366 error (_("Incompatible types in assignment"));
9367 deprecated_set_value_type (val
, type
);
9372 static struct value
*
9373 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9376 struct type
*type1
, *type2
;
9379 arg1
= coerce_ref (arg1
);
9380 arg2
= coerce_ref (arg2
);
9381 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9382 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9384 if (type1
->code () != TYPE_CODE_INT
9385 || type2
->code () != TYPE_CODE_INT
)
9386 return value_binop (arg1
, arg2
, op
);
9395 return value_binop (arg1
, arg2
, op
);
9398 v2
= value_as_long (arg2
);
9400 error (_("second operand of %s must not be zero."), op_string (op
));
9402 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
9403 return value_binop (arg1
, arg2
, op
);
9405 v1
= value_as_long (arg1
);
9410 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9411 v
+= v
> 0 ? -1 : 1;
9419 /* Should not reach this point. */
9423 val
= allocate_value (type1
);
9424 store_unsigned_integer (value_contents_raw (val
),
9425 TYPE_LENGTH (value_type (val
)),
9426 type_byte_order (type1
), v
);
9431 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9433 if (ada_is_direct_array_type (value_type (arg1
))
9434 || ada_is_direct_array_type (value_type (arg2
)))
9436 struct type
*arg1_type
, *arg2_type
;
9438 /* Automatically dereference any array reference before
9439 we attempt to perform the comparison. */
9440 arg1
= ada_coerce_ref (arg1
);
9441 arg2
= ada_coerce_ref (arg2
);
9443 arg1
= ada_coerce_to_simple_array (arg1
);
9444 arg2
= ada_coerce_to_simple_array (arg2
);
9446 arg1_type
= ada_check_typedef (value_type (arg1
));
9447 arg2_type
= ada_check_typedef (value_type (arg2
));
9449 if (arg1_type
->code () != TYPE_CODE_ARRAY
9450 || arg2_type
->code () != TYPE_CODE_ARRAY
)
9451 error (_("Attempt to compare array with non-array"));
9452 /* FIXME: The following works only for types whose
9453 representations use all bits (no padding or undefined bits)
9454 and do not have user-defined equality. */
9455 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9456 && memcmp (value_contents (arg1
), value_contents (arg2
),
9457 TYPE_LENGTH (arg1_type
)) == 0);
9459 return value_equal (arg1
, arg2
);
9462 /* Total number of component associations in the aggregate starting at
9463 index PC in EXP. Assumes that index PC is the start of an
9467 num_component_specs (struct expression
*exp
, int pc
)
9471 m
= exp
->elts
[pc
+ 1].longconst
;
9474 for (i
= 0; i
< m
; i
+= 1)
9476 switch (exp
->elts
[pc
].opcode
)
9482 n
+= exp
->elts
[pc
+ 1].longconst
;
9485 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9490 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9491 component of LHS (a simple array or a record), updating *POS past
9492 the expression, assuming that LHS is contained in CONTAINER. Does
9493 not modify the inferior's memory, nor does it modify LHS (unless
9494 LHS == CONTAINER). */
9497 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9498 struct expression
*exp
, int *pos
)
9500 struct value
*mark
= value_mark ();
9502 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9504 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
9506 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9507 struct value
*index_val
= value_from_longest (index_type
, index
);
9509 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9513 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9514 elt
= ada_to_fixed_value (elt
);
9517 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9518 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9520 value_assign_to_component (container
, elt
,
9521 ada_evaluate_subexp (NULL
, exp
, pos
,
9524 value_free_to_mark (mark
);
9527 /* Assuming that LHS represents an lvalue having a record or array
9528 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9529 of that aggregate's value to LHS, advancing *POS past the
9530 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9531 lvalue containing LHS (possibly LHS itself). Does not modify
9532 the inferior's memory, nor does it modify the contents of
9533 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9535 static struct value
*
9536 assign_aggregate (struct value
*container
,
9537 struct value
*lhs
, struct expression
*exp
,
9538 int *pos
, enum noside noside
)
9540 struct type
*lhs_type
;
9541 int n
= exp
->elts
[*pos
+1].longconst
;
9542 LONGEST low_index
, high_index
;
9545 int max_indices
, num_indices
;
9549 if (noside
!= EVAL_NORMAL
)
9551 for (i
= 0; i
< n
; i
+= 1)
9552 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9556 container
= ada_coerce_ref (container
);
9557 if (ada_is_direct_array_type (value_type (container
)))
9558 container
= ada_coerce_to_simple_array (container
);
9559 lhs
= ada_coerce_ref (lhs
);
9560 if (!deprecated_value_modifiable (lhs
))
9561 error (_("Left operand of assignment is not a modifiable lvalue."));
9563 lhs_type
= check_typedef (value_type (lhs
));
9564 if (ada_is_direct_array_type (lhs_type
))
9566 lhs
= ada_coerce_to_simple_array (lhs
);
9567 lhs_type
= check_typedef (value_type (lhs
));
9568 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
9569 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
9571 else if (lhs_type
->code () == TYPE_CODE_STRUCT
)
9574 high_index
= num_visible_fields (lhs_type
) - 1;
9577 error (_("Left-hand side must be array or record."));
9579 num_specs
= num_component_specs (exp
, *pos
- 3);
9580 max_indices
= 4 * num_specs
+ 4;
9581 indices
= XALLOCAVEC (LONGEST
, max_indices
);
9582 indices
[0] = indices
[1] = low_index
- 1;
9583 indices
[2] = indices
[3] = high_index
+ 1;
9586 for (i
= 0; i
< n
; i
+= 1)
9588 switch (exp
->elts
[*pos
].opcode
)
9591 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9592 &num_indices
, max_indices
,
9593 low_index
, high_index
);
9596 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9597 &num_indices
, max_indices
,
9598 low_index
, high_index
);
9602 error (_("Misplaced 'others' clause"));
9603 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9604 num_indices
, low_index
, high_index
);
9607 error (_("Internal error: bad aggregate clause"));
9614 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9615 construct at *POS, updating *POS past the construct, given that
9616 the positions are relative to lower bound LOW, where HIGH is the
9617 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9618 updating *NUM_INDICES as needed. CONTAINER is as for
9619 assign_aggregate. */
9621 aggregate_assign_positional (struct value
*container
,
9622 struct value
*lhs
, struct expression
*exp
,
9623 int *pos
, LONGEST
*indices
, int *num_indices
,
9624 int max_indices
, LONGEST low
, LONGEST high
)
9626 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9628 if (ind
- 1 == high
)
9629 warning (_("Extra components in aggregate ignored."));
9632 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
9634 assign_component (container
, lhs
, ind
, exp
, pos
);
9637 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9640 /* Assign into the components of LHS indexed by the OP_CHOICES
9641 construct at *POS, updating *POS past the construct, given that
9642 the allowable indices are LOW..HIGH. Record the indices assigned
9643 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9644 needed. CONTAINER is as for assign_aggregate. */
9646 aggregate_assign_from_choices (struct value
*container
,
9647 struct value
*lhs
, struct expression
*exp
,
9648 int *pos
, LONGEST
*indices
, int *num_indices
,
9649 int max_indices
, LONGEST low
, LONGEST high
)
9652 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9653 int choice_pos
, expr_pc
;
9654 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9656 choice_pos
= *pos
+= 3;
9658 for (j
= 0; j
< n_choices
; j
+= 1)
9659 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9661 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9663 for (j
= 0; j
< n_choices
; j
+= 1)
9665 LONGEST lower
, upper
;
9666 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9668 if (op
== OP_DISCRETE_RANGE
)
9671 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9673 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9678 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9690 name
= &exp
->elts
[choice_pos
+ 2].string
;
9693 name
= exp
->elts
[choice_pos
+ 2].symbol
->natural_name ();
9696 error (_("Invalid record component association."));
9698 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9700 if (! find_struct_field (name
, value_type (lhs
), 0,
9701 NULL
, NULL
, NULL
, NULL
, &ind
))
9702 error (_("Unknown component name: %s."), name
);
9703 lower
= upper
= ind
;
9706 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9707 error (_("Index in component association out of bounds."));
9709 add_component_interval (lower
, upper
, indices
, num_indices
,
9711 while (lower
<= upper
)
9716 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9722 /* Assign the value of the expression in the OP_OTHERS construct in
9723 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9724 have not been previously assigned. The index intervals already assigned
9725 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9726 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9728 aggregate_assign_others (struct value
*container
,
9729 struct value
*lhs
, struct expression
*exp
,
9730 int *pos
, LONGEST
*indices
, int num_indices
,
9731 LONGEST low
, LONGEST high
)
9734 int expr_pc
= *pos
+ 1;
9736 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9740 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9745 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9748 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9751 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9752 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9753 modifying *SIZE as needed. It is an error if *SIZE exceeds
9754 MAX_SIZE. The resulting intervals do not overlap. */
9756 add_component_interval (LONGEST low
, LONGEST high
,
9757 LONGEST
* indices
, int *size
, int max_size
)
9761 for (i
= 0; i
< *size
; i
+= 2) {
9762 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9766 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
9767 if (high
< indices
[kh
])
9769 if (low
< indices
[i
])
9771 indices
[i
+ 1] = indices
[kh
- 1];
9772 if (high
> indices
[i
+ 1])
9773 indices
[i
+ 1] = high
;
9774 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
9775 *size
-= kh
- i
- 2;
9778 else if (high
< indices
[i
])
9782 if (*size
== max_size
)
9783 error (_("Internal error: miscounted aggregate components."));
9785 for (j
= *size
-1; j
>= i
+2; j
-= 1)
9786 indices
[j
] = indices
[j
- 2];
9788 indices
[i
+ 1] = high
;
9791 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9794 static struct value
*
9795 ada_value_cast (struct type
*type
, struct value
*arg2
)
9797 if (type
== ada_check_typedef (value_type (arg2
)))
9800 if (ada_is_gnat_encoded_fixed_point_type (type
))
9801 return cast_to_fixed (type
, arg2
);
9803 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
9804 return cast_from_fixed (type
, arg2
);
9806 return value_cast (type
, arg2
);
9809 /* Evaluating Ada expressions, and printing their result.
9810 ------------------------------------------------------
9815 We usually evaluate an Ada expression in order to print its value.
9816 We also evaluate an expression in order to print its type, which
9817 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9818 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9819 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9820 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9823 Evaluating expressions is a little more complicated for Ada entities
9824 than it is for entities in languages such as C. The main reason for
9825 this is that Ada provides types whose definition might be dynamic.
9826 One example of such types is variant records. Or another example
9827 would be an array whose bounds can only be known at run time.
9829 The following description is a general guide as to what should be
9830 done (and what should NOT be done) in order to evaluate an expression
9831 involving such types, and when. This does not cover how the semantic
9832 information is encoded by GNAT as this is covered separatly. For the
9833 document used as the reference for the GNAT encoding, see exp_dbug.ads
9834 in the GNAT sources.
9836 Ideally, we should embed each part of this description next to its
9837 associated code. Unfortunately, the amount of code is so vast right
9838 now that it's hard to see whether the code handling a particular
9839 situation might be duplicated or not. One day, when the code is
9840 cleaned up, this guide might become redundant with the comments
9841 inserted in the code, and we might want to remove it.
9843 2. ``Fixing'' an Entity, the Simple Case:
9844 -----------------------------------------
9846 When evaluating Ada expressions, the tricky issue is that they may
9847 reference entities whose type contents and size are not statically
9848 known. Consider for instance a variant record:
9850 type Rec (Empty : Boolean := True) is record
9853 when False => Value : Integer;
9856 Yes : Rec := (Empty => False, Value => 1);
9857 No : Rec := (empty => True);
9859 The size and contents of that record depends on the value of the
9860 descriminant (Rec.Empty). At this point, neither the debugging
9861 information nor the associated type structure in GDB are able to
9862 express such dynamic types. So what the debugger does is to create
9863 "fixed" versions of the type that applies to the specific object.
9864 We also informally refer to this operation as "fixing" an object,
9865 which means creating its associated fixed type.
9867 Example: when printing the value of variable "Yes" above, its fixed
9868 type would look like this:
9875 On the other hand, if we printed the value of "No", its fixed type
9882 Things become a little more complicated when trying to fix an entity
9883 with a dynamic type that directly contains another dynamic type,
9884 such as an array of variant records, for instance. There are
9885 two possible cases: Arrays, and records.
9887 3. ``Fixing'' Arrays:
9888 ---------------------
9890 The type structure in GDB describes an array in terms of its bounds,
9891 and the type of its elements. By design, all elements in the array
9892 have the same type and we cannot represent an array of variant elements
9893 using the current type structure in GDB. When fixing an array,
9894 we cannot fix the array element, as we would potentially need one
9895 fixed type per element of the array. As a result, the best we can do
9896 when fixing an array is to produce an array whose bounds and size
9897 are correct (allowing us to read it from memory), but without having
9898 touched its element type. Fixing each element will be done later,
9899 when (if) necessary.
9901 Arrays are a little simpler to handle than records, because the same
9902 amount of memory is allocated for each element of the array, even if
9903 the amount of space actually used by each element differs from element
9904 to element. Consider for instance the following array of type Rec:
9906 type Rec_Array is array (1 .. 2) of Rec;
9908 The actual amount of memory occupied by each element might be different
9909 from element to element, depending on the value of their discriminant.
9910 But the amount of space reserved for each element in the array remains
9911 fixed regardless. So we simply need to compute that size using
9912 the debugging information available, from which we can then determine
9913 the array size (we multiply the number of elements of the array by
9914 the size of each element).
9916 The simplest case is when we have an array of a constrained element
9917 type. For instance, consider the following type declarations:
9919 type Bounded_String (Max_Size : Integer) is
9921 Buffer : String (1 .. Max_Size);
9923 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9925 In this case, the compiler describes the array as an array of
9926 variable-size elements (identified by its XVS suffix) for which
9927 the size can be read in the parallel XVZ variable.
9929 In the case of an array of an unconstrained element type, the compiler
9930 wraps the array element inside a private PAD type. This type should not
9931 be shown to the user, and must be "unwrap"'ed before printing. Note
9932 that we also use the adjective "aligner" in our code to designate
9933 these wrapper types.
9935 In some cases, the size allocated for each element is statically
9936 known. In that case, the PAD type already has the correct size,
9937 and the array element should remain unfixed.
9939 But there are cases when this size is not statically known.
9940 For instance, assuming that "Five" is an integer variable:
9942 type Dynamic is array (1 .. Five) of Integer;
9943 type Wrapper (Has_Length : Boolean := False) is record
9946 when True => Length : Integer;
9950 type Wrapper_Array is array (1 .. 2) of Wrapper;
9952 Hello : Wrapper_Array := (others => (Has_Length => True,
9953 Data => (others => 17),
9957 The debugging info would describe variable Hello as being an
9958 array of a PAD type. The size of that PAD type is not statically
9959 known, but can be determined using a parallel XVZ variable.
9960 In that case, a copy of the PAD type with the correct size should
9961 be used for the fixed array.
9963 3. ``Fixing'' record type objects:
9964 ----------------------------------
9966 Things are slightly different from arrays in the case of dynamic
9967 record types. In this case, in order to compute the associated
9968 fixed type, we need to determine the size and offset of each of
9969 its components. This, in turn, requires us to compute the fixed
9970 type of each of these components.
9972 Consider for instance the example:
9974 type Bounded_String (Max_Size : Natural) is record
9975 Str : String (1 .. Max_Size);
9978 My_String : Bounded_String (Max_Size => 10);
9980 In that case, the position of field "Length" depends on the size
9981 of field Str, which itself depends on the value of the Max_Size
9982 discriminant. In order to fix the type of variable My_String,
9983 we need to fix the type of field Str. Therefore, fixing a variant
9984 record requires us to fix each of its components.
9986 However, if a component does not have a dynamic size, the component
9987 should not be fixed. In particular, fields that use a PAD type
9988 should not fixed. Here is an example where this might happen
9989 (assuming type Rec above):
9991 type Container (Big : Boolean) is record
9995 when True => Another : Integer;
9999 My_Container : Container := (Big => False,
10000 First => (Empty => True),
10003 In that example, the compiler creates a PAD type for component First,
10004 whose size is constant, and then positions the component After just
10005 right after it. The offset of component After is therefore constant
10008 The debugger computes the position of each field based on an algorithm
10009 that uses, among other things, the actual position and size of the field
10010 preceding it. Let's now imagine that the user is trying to print
10011 the value of My_Container. If the type fixing was recursive, we would
10012 end up computing the offset of field After based on the size of the
10013 fixed version of field First. And since in our example First has
10014 only one actual field, the size of the fixed type is actually smaller
10015 than the amount of space allocated to that field, and thus we would
10016 compute the wrong offset of field After.
10018 To make things more complicated, we need to watch out for dynamic
10019 components of variant records (identified by the ___XVL suffix in
10020 the component name). Even if the target type is a PAD type, the size
10021 of that type might not be statically known. So the PAD type needs
10022 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10023 we might end up with the wrong size for our component. This can be
10024 observed with the following type declarations:
10026 type Octal is new Integer range 0 .. 7;
10027 type Octal_Array is array (Positive range <>) of Octal;
10028 pragma Pack (Octal_Array);
10030 type Octal_Buffer (Size : Positive) is record
10031 Buffer : Octal_Array (1 .. Size);
10035 In that case, Buffer is a PAD type whose size is unset and needs
10036 to be computed by fixing the unwrapped type.
10038 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10039 ----------------------------------------------------------
10041 Lastly, when should the sub-elements of an entity that remained unfixed
10042 thus far, be actually fixed?
10044 The answer is: Only when referencing that element. For instance
10045 when selecting one component of a record, this specific component
10046 should be fixed at that point in time. Or when printing the value
10047 of a record, each component should be fixed before its value gets
10048 printed. Similarly for arrays, the element of the array should be
10049 fixed when printing each element of the array, or when extracting
10050 one element out of that array. On the other hand, fixing should
10051 not be performed on the elements when taking a slice of an array!
10053 Note that one of the side effects of miscomputing the offset and
10054 size of each field is that we end up also miscomputing the size
10055 of the containing type. This can have adverse results when computing
10056 the value of an entity. GDB fetches the value of an entity based
10057 on the size of its type, and thus a wrong size causes GDB to fetch
10058 the wrong amount of memory. In the case where the computed size is
10059 too small, GDB fetches too little data to print the value of our
10060 entity. Results in this case are unpredictable, as we usually read
10061 past the buffer containing the data =:-o. */
10063 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10064 for that subexpression cast to TO_TYPE. Advance *POS over the
10068 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
10069 enum noside noside
, struct type
*to_type
)
10073 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
10074 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
10079 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
10081 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10082 return value_zero (to_type
, not_lval
);
10084 val
= evaluate_var_msym_value (noside
,
10085 exp
->elts
[pc
+ 1].objfile
,
10086 exp
->elts
[pc
+ 2].msymbol
);
10089 val
= evaluate_var_value (noside
,
10090 exp
->elts
[pc
+ 1].block
,
10091 exp
->elts
[pc
+ 2].symbol
);
10093 if (noside
== EVAL_SKIP
)
10094 return eval_skip_value (exp
);
10096 val
= ada_value_cast (to_type
, val
);
10098 /* Follow the Ada language semantics that do not allow taking
10099 an address of the result of a cast (view conversion in Ada). */
10100 if (VALUE_LVAL (val
) == lval_memory
)
10102 if (value_lazy (val
))
10103 value_fetch_lazy (val
);
10104 VALUE_LVAL (val
) = not_lval
;
10109 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
10110 if (noside
== EVAL_SKIP
)
10111 return eval_skip_value (exp
);
10112 return ada_value_cast (to_type
, val
);
10115 /* Implement the evaluate_exp routine in the exp_descriptor structure
10116 for the Ada language. */
10118 static struct value
*
10119 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10120 int *pos
, enum noside noside
)
10122 enum exp_opcode op
;
10126 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10129 struct value
**argvec
;
10133 op
= exp
->elts
[pc
].opcode
;
10139 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10141 if (noside
== EVAL_NORMAL
)
10142 arg1
= unwrap_value (arg1
);
10144 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10145 then we need to perform the conversion manually, because
10146 evaluate_subexp_standard doesn't do it. This conversion is
10147 necessary in Ada because the different kinds of float/fixed
10148 types in Ada have different representations.
10150 Similarly, we need to perform the conversion from OP_LONG
10152 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10153 arg1
= ada_value_cast (expect_type
, arg1
);
10159 struct value
*result
;
10162 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10163 /* The result type will have code OP_STRING, bashed there from
10164 OP_ARRAY. Bash it back. */
10165 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10166 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10172 type
= exp
->elts
[pc
+ 1].type
;
10173 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10177 type
= exp
->elts
[pc
+ 1].type
;
10178 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10181 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10182 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10184 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10185 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10187 return ada_value_assign (arg1
, arg1
);
10189 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10190 except if the lhs of our assignment is a convenience variable.
10191 In the case of assigning to a convenience variable, the lhs
10192 should be exactly the result of the evaluation of the rhs. */
10193 type
= value_type (arg1
);
10194 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10196 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10197 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10199 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10203 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10204 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
10205 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10207 (_("Fixed-point values must be assigned to fixed-point variables"));
10209 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10210 return ada_value_assign (arg1
, arg2
);
10213 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10214 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10215 if (noside
== EVAL_SKIP
)
10217 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10218 return (value_from_longest
10219 (value_type (arg1
),
10220 value_as_long (arg1
) + value_as_long (arg2
)));
10221 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10222 return (value_from_longest
10223 (value_type (arg2
),
10224 value_as_long (arg1
) + value_as_long (arg2
)));
10225 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10226 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10227 && value_type (arg1
) != value_type (arg2
))
10228 error (_("Operands of fixed-point addition must have the same type"));
10229 /* Do the addition, and cast the result to the type of the first
10230 argument. We cannot cast the result to a reference type, so if
10231 ARG1 is a reference type, find its underlying type. */
10232 type
= value_type (arg1
);
10233 while (type
->code () == TYPE_CODE_REF
)
10234 type
= TYPE_TARGET_TYPE (type
);
10235 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10236 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10239 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10240 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10241 if (noside
== EVAL_SKIP
)
10243 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10244 return (value_from_longest
10245 (value_type (arg1
),
10246 value_as_long (arg1
) - value_as_long (arg2
)));
10247 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10248 return (value_from_longest
10249 (value_type (arg2
),
10250 value_as_long (arg1
) - value_as_long (arg2
)));
10251 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10252 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10253 && value_type (arg1
) != value_type (arg2
))
10254 error (_("Operands of fixed-point subtraction "
10255 "must have the same type"));
10256 /* Do the substraction, and cast the result to the type of the first
10257 argument. We cannot cast the result to a reference type, so if
10258 ARG1 is a reference type, find its underlying type. */
10259 type
= value_type (arg1
);
10260 while (type
->code () == TYPE_CODE_REF
)
10261 type
= TYPE_TARGET_TYPE (type
);
10262 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10263 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10269 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10270 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10271 if (noside
== EVAL_SKIP
)
10273 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10275 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10276 return value_zero (value_type (arg1
), not_lval
);
10280 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10281 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10282 arg1
= cast_from_fixed (type
, arg1
);
10283 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10284 arg2
= cast_from_fixed (type
, arg2
);
10285 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10286 return ada_value_binop (arg1
, arg2
, op
);
10290 case BINOP_NOTEQUAL
:
10291 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10292 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10293 if (noside
== EVAL_SKIP
)
10295 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10299 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10300 tem
= ada_value_equal (arg1
, arg2
);
10302 if (op
== BINOP_NOTEQUAL
)
10304 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10305 return value_from_longest (type
, (LONGEST
) tem
);
10308 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10309 if (noside
== EVAL_SKIP
)
10311 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10312 return value_cast (value_type (arg1
), value_neg (arg1
));
10315 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10316 return value_neg (arg1
);
10319 case BINOP_LOGICAL_AND
:
10320 case BINOP_LOGICAL_OR
:
10321 case UNOP_LOGICAL_NOT
:
10326 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10327 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10328 return value_cast (type
, val
);
10331 case BINOP_BITWISE_AND
:
10332 case BINOP_BITWISE_IOR
:
10333 case BINOP_BITWISE_XOR
:
10337 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10339 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10341 return value_cast (value_type (arg1
), val
);
10347 if (noside
== EVAL_SKIP
)
10353 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10354 /* Only encountered when an unresolved symbol occurs in a
10355 context other than a function call, in which case, it is
10357 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10358 exp
->elts
[pc
+ 2].symbol
->print_name ());
10360 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10362 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10363 /* Check to see if this is a tagged type. We also need to handle
10364 the case where the type is a reference to a tagged type, but
10365 we have to be careful to exclude pointers to tagged types.
10366 The latter should be shown as usual (as a pointer), whereas
10367 a reference should mostly be transparent to the user. */
10368 if (ada_is_tagged_type (type
, 0)
10369 || (type
->code () == TYPE_CODE_REF
10370 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10372 /* Tagged types are a little special in the fact that the real
10373 type is dynamic and can only be determined by inspecting the
10374 object's tag. This means that we need to get the object's
10375 value first (EVAL_NORMAL) and then extract the actual object
10378 Note that we cannot skip the final step where we extract
10379 the object type from its tag, because the EVAL_NORMAL phase
10380 results in dynamic components being resolved into fixed ones.
10381 This can cause problems when trying to print the type
10382 description of tagged types whose parent has a dynamic size:
10383 We use the type name of the "_parent" component in order
10384 to print the name of the ancestor type in the type description.
10385 If that component had a dynamic size, the resolution into
10386 a fixed type would result in the loss of that type name,
10387 thus preventing us from printing the name of the ancestor
10388 type in the type description. */
10389 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
10391 if (type
->code () != TYPE_CODE_REF
)
10393 struct type
*actual_type
;
10395 actual_type
= type_from_tag (ada_value_tag (arg1
));
10396 if (actual_type
== NULL
)
10397 /* If, for some reason, we were unable to determine
10398 the actual type from the tag, then use the static
10399 approximation that we just computed as a fallback.
10400 This can happen if the debugging information is
10401 incomplete, for instance. */
10402 actual_type
= type
;
10403 return value_zero (actual_type
, not_lval
);
10407 /* In the case of a ref, ada_coerce_ref takes care
10408 of determining the actual type. But the evaluation
10409 should return a ref as it should be valid to ask
10410 for its address; so rebuild a ref after coerce. */
10411 arg1
= ada_coerce_ref (arg1
);
10412 return value_ref (arg1
, TYPE_CODE_REF
);
10416 /* Records and unions for which GNAT encodings have been
10417 generated need to be statically fixed as well.
10418 Otherwise, non-static fixing produces a type where
10419 all dynamic properties are removed, which prevents "ptype"
10420 from being able to completely describe the type.
10421 For instance, a case statement in a variant record would be
10422 replaced by the relevant components based on the actual
10423 value of the discriminants. */
10424 if ((type
->code () == TYPE_CODE_STRUCT
10425 && dynamic_template_type (type
) != NULL
)
10426 || (type
->code () == TYPE_CODE_UNION
10427 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10430 return value_zero (to_static_fixed_type (type
), not_lval
);
10434 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10435 return ada_to_fixed_value (arg1
);
10440 /* Allocate arg vector, including space for the function to be
10441 called in argvec[0] and a terminating NULL. */
10442 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10443 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10445 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10446 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10447 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10448 exp
->elts
[pc
+ 5].symbol
->print_name ());
10451 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10452 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10455 if (noside
== EVAL_SKIP
)
10459 if (ada_is_constrained_packed_array_type
10460 (desc_base_type (value_type (argvec
[0]))))
10461 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10462 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10463 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10464 /* This is a packed array that has already been fixed, and
10465 therefore already coerced to a simple array. Nothing further
10468 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10470 /* Make sure we dereference references so that all the code below
10471 feels like it's really handling the referenced value. Wrapping
10472 types (for alignment) may be there, so make sure we strip them as
10474 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10476 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10477 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10478 argvec
[0] = value_addr (argvec
[0]);
10480 type
= ada_check_typedef (value_type (argvec
[0]));
10482 /* Ada allows us to implicitly dereference arrays when subscripting
10483 them. So, if this is an array typedef (encoding use for array
10484 access types encoded as fat pointers), strip it now. */
10485 if (type
->code () == TYPE_CODE_TYPEDEF
)
10486 type
= ada_typedef_target_type (type
);
10488 if (type
->code () == TYPE_CODE_PTR
)
10490 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10492 case TYPE_CODE_FUNC
:
10493 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10495 case TYPE_CODE_ARRAY
:
10497 case TYPE_CODE_STRUCT
:
10498 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10499 argvec
[0] = ada_value_ind (argvec
[0]);
10500 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10503 error (_("cannot subscript or call something of type `%s'"),
10504 ada_type_name (value_type (argvec
[0])));
10509 switch (type
->code ())
10511 case TYPE_CODE_FUNC
:
10512 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10514 if (TYPE_TARGET_TYPE (type
) == NULL
)
10515 error_call_unknown_return_type (NULL
);
10516 return allocate_value (TYPE_TARGET_TYPE (type
));
10518 return call_function_by_hand (argvec
[0], NULL
,
10519 gdb::make_array_view (argvec
+ 1,
10521 case TYPE_CODE_INTERNAL_FUNCTION
:
10522 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10523 /* We don't know anything about what the internal
10524 function might return, but we have to return
10526 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10529 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10530 argvec
[0], nargs
, argvec
+ 1);
10532 case TYPE_CODE_STRUCT
:
10536 arity
= ada_array_arity (type
);
10537 type
= ada_array_element_type (type
, nargs
);
10539 error (_("cannot subscript or call a record"));
10540 if (arity
!= nargs
)
10541 error (_("wrong number of subscripts; expecting %d"), arity
);
10542 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10543 return value_zero (ada_aligned_type (type
), lval_memory
);
10545 unwrap_value (ada_value_subscript
10546 (argvec
[0], nargs
, argvec
+ 1));
10548 case TYPE_CODE_ARRAY
:
10549 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10551 type
= ada_array_element_type (type
, nargs
);
10553 error (_("element type of array unknown"));
10555 return value_zero (ada_aligned_type (type
), lval_memory
);
10558 unwrap_value (ada_value_subscript
10559 (ada_coerce_to_simple_array (argvec
[0]),
10560 nargs
, argvec
+ 1));
10561 case TYPE_CODE_PTR
: /* Pointer to array */
10562 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10564 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10565 type
= ada_array_element_type (type
, nargs
);
10567 error (_("element type of array unknown"));
10569 return value_zero (ada_aligned_type (type
), lval_memory
);
10572 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10573 nargs
, argvec
+ 1));
10576 error (_("Attempt to index or call something other than an "
10577 "array or function"));
10582 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10583 struct value
*low_bound_val
=
10584 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10585 struct value
*high_bound_val
=
10586 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10588 LONGEST high_bound
;
10590 low_bound_val
= coerce_ref (low_bound_val
);
10591 high_bound_val
= coerce_ref (high_bound_val
);
10592 low_bound
= value_as_long (low_bound_val
);
10593 high_bound
= value_as_long (high_bound_val
);
10595 if (noside
== EVAL_SKIP
)
10598 /* If this is a reference to an aligner type, then remove all
10600 if (value_type (array
)->code () == TYPE_CODE_REF
10601 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10602 TYPE_TARGET_TYPE (value_type (array
)) =
10603 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10605 if (ada_is_constrained_packed_array_type (value_type (array
)))
10606 error (_("cannot slice a packed array"));
10608 /* If this is a reference to an array or an array lvalue,
10609 convert to a pointer. */
10610 if (value_type (array
)->code () == TYPE_CODE_REF
10611 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10612 && VALUE_LVAL (array
) == lval_memory
))
10613 array
= value_addr (array
);
10615 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10616 && ada_is_array_descriptor_type (ada_check_typedef
10617 (value_type (array
))))
10618 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10621 array
= ada_coerce_to_simple_array_ptr (array
);
10623 /* If we have more than one level of pointer indirection,
10624 dereference the value until we get only one level. */
10625 while (value_type (array
)->code () == TYPE_CODE_PTR
10626 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10628 array
= value_ind (array
);
10630 /* Make sure we really do have an array type before going further,
10631 to avoid a SEGV when trying to get the index type or the target
10632 type later down the road if the debug info generated by
10633 the compiler is incorrect or incomplete. */
10634 if (!ada_is_simple_array_type (value_type (array
)))
10635 error (_("cannot take slice of non-array"));
10637 if (ada_check_typedef (value_type (array
))->code ()
10640 struct type
*type0
= ada_check_typedef (value_type (array
));
10642 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10643 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10646 struct type
*arr_type0
=
10647 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10649 return ada_value_slice_from_ptr (array
, arr_type0
,
10650 longest_to_int (low_bound
),
10651 longest_to_int (high_bound
));
10654 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10656 else if (high_bound
< low_bound
)
10657 return empty_array (value_type (array
), low_bound
, high_bound
);
10659 return ada_value_slice (array
, longest_to_int (low_bound
),
10660 longest_to_int (high_bound
));
10663 case UNOP_IN_RANGE
:
10665 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10666 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10668 if (noside
== EVAL_SKIP
)
10671 switch (type
->code ())
10674 lim_warning (_("Membership test incompletely implemented; "
10675 "always returns true"));
10676 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10677 return value_from_longest (type
, (LONGEST
) 1);
10679 case TYPE_CODE_RANGE
:
10680 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
10681 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
10682 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10683 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10684 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10686 value_from_longest (type
,
10687 (value_less (arg1
, arg3
)
10688 || value_equal (arg1
, arg3
))
10689 && (value_less (arg2
, arg1
)
10690 || value_equal (arg2
, arg1
)));
10693 case BINOP_IN_BOUNDS
:
10695 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10696 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10698 if (noside
== EVAL_SKIP
)
10701 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10703 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10704 return value_zero (type
, not_lval
);
10707 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10709 type
= ada_index_type (value_type (arg2
), tem
, "range");
10711 type
= value_type (arg1
);
10713 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10714 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10716 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10717 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10718 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10720 value_from_longest (type
,
10721 (value_less (arg1
, arg3
)
10722 || value_equal (arg1
, arg3
))
10723 && (value_less (arg2
, arg1
)
10724 || value_equal (arg2
, arg1
)));
10726 case TERNOP_IN_RANGE
:
10727 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10728 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10729 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10731 if (noside
== EVAL_SKIP
)
10734 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10735 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10736 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10738 value_from_longest (type
,
10739 (value_less (arg1
, arg3
)
10740 || value_equal (arg1
, arg3
))
10741 && (value_less (arg2
, arg1
)
10742 || value_equal (arg2
, arg1
)));
10746 case OP_ATR_LENGTH
:
10748 struct type
*type_arg
;
10750 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10752 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10754 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10758 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10762 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10763 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10764 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10767 if (noside
== EVAL_SKIP
)
10769 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10771 if (type_arg
== NULL
)
10772 type_arg
= value_type (arg1
);
10774 if (ada_is_constrained_packed_array_type (type_arg
))
10775 type_arg
= decode_constrained_packed_array_type (type_arg
);
10777 if (!discrete_type_p (type_arg
))
10781 default: /* Should never happen. */
10782 error (_("unexpected attribute encountered"));
10785 type_arg
= ada_index_type (type_arg
, tem
,
10786 ada_attribute_name (op
));
10788 case OP_ATR_LENGTH
:
10789 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10794 return value_zero (type_arg
, not_lval
);
10796 else if (type_arg
== NULL
)
10798 arg1
= ada_coerce_ref (arg1
);
10800 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10801 arg1
= ada_coerce_to_simple_array (arg1
);
10803 if (op
== OP_ATR_LENGTH
)
10804 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10807 type
= ada_index_type (value_type (arg1
), tem
,
10808 ada_attribute_name (op
));
10810 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10815 default: /* Should never happen. */
10816 error (_("unexpected attribute encountered"));
10818 return value_from_longest
10819 (type
, ada_array_bound (arg1
, tem
, 0));
10821 return value_from_longest
10822 (type
, ada_array_bound (arg1
, tem
, 1));
10823 case OP_ATR_LENGTH
:
10824 return value_from_longest
10825 (type
, ada_array_length (arg1
, tem
));
10828 else if (discrete_type_p (type_arg
))
10830 struct type
*range_type
;
10831 const char *name
= ada_type_name (type_arg
);
10834 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10835 range_type
= to_fixed_range_type (type_arg
, NULL
);
10836 if (range_type
== NULL
)
10837 range_type
= type_arg
;
10841 error (_("unexpected attribute encountered"));
10843 return value_from_longest
10844 (range_type
, ada_discrete_type_low_bound (range_type
));
10846 return value_from_longest
10847 (range_type
, ada_discrete_type_high_bound (range_type
));
10848 case OP_ATR_LENGTH
:
10849 error (_("the 'length attribute applies only to array types"));
10852 else if (type_arg
->code () == TYPE_CODE_FLT
)
10853 error (_("unimplemented type attribute"));
10858 if (ada_is_constrained_packed_array_type (type_arg
))
10859 type_arg
= decode_constrained_packed_array_type (type_arg
);
10861 if (op
== OP_ATR_LENGTH
)
10862 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10865 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10867 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10873 error (_("unexpected attribute encountered"));
10875 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10876 return value_from_longest (type
, low
);
10878 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10879 return value_from_longest (type
, high
);
10880 case OP_ATR_LENGTH
:
10881 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10882 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10883 return value_from_longest (type
, high
- low
+ 1);
10889 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10890 if (noside
== EVAL_SKIP
)
10893 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10894 return value_zero (ada_tag_type (arg1
), not_lval
);
10896 return ada_value_tag (arg1
);
10900 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10901 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10902 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10903 if (noside
== EVAL_SKIP
)
10905 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10906 return value_zero (value_type (arg1
), not_lval
);
10909 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10910 return value_binop (arg1
, arg2
,
10911 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10914 case OP_ATR_MODULUS
:
10916 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10918 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10919 if (noside
== EVAL_SKIP
)
10922 if (!ada_is_modular_type (type_arg
))
10923 error (_("'modulus must be applied to modular type"));
10925 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10926 ada_modulus (type_arg
));
10931 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10932 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10933 if (noside
== EVAL_SKIP
)
10935 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10936 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10937 return value_zero (type
, not_lval
);
10939 return value_pos_atr (type
, arg1
);
10942 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10943 type
= value_type (arg1
);
10945 /* If the argument is a reference, then dereference its type, since
10946 the user is really asking for the size of the actual object,
10947 not the size of the pointer. */
10948 if (type
->code () == TYPE_CODE_REF
)
10949 type
= TYPE_TARGET_TYPE (type
);
10951 if (noside
== EVAL_SKIP
)
10953 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10954 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
10956 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
10957 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
10960 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10961 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10962 type
= exp
->elts
[pc
+ 2].type
;
10963 if (noside
== EVAL_SKIP
)
10965 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10966 return value_zero (type
, not_lval
);
10968 return value_val_atr (type
, arg1
);
10971 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10972 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10973 if (noside
== EVAL_SKIP
)
10975 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10976 return value_zero (value_type (arg1
), not_lval
);
10979 /* For integer exponentiation operations,
10980 only promote the first argument. */
10981 if (is_integral_type (value_type (arg2
)))
10982 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10984 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10986 return value_binop (arg1
, arg2
, op
);
10990 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10991 if (noside
== EVAL_SKIP
)
10997 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10998 if (noside
== EVAL_SKIP
)
11000 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11001 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
11002 return value_neg (arg1
);
11007 preeval_pos
= *pos
;
11008 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11009 if (noside
== EVAL_SKIP
)
11011 type
= ada_check_typedef (value_type (arg1
));
11012 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11014 if (ada_is_array_descriptor_type (type
))
11015 /* GDB allows dereferencing GNAT array descriptors. */
11017 struct type
*arrType
= ada_type_of_array (arg1
, 0);
11019 if (arrType
== NULL
)
11020 error (_("Attempt to dereference null array pointer."));
11021 return value_at_lazy (arrType
, 0);
11023 else if (type
->code () == TYPE_CODE_PTR
11024 || type
->code () == TYPE_CODE_REF
11025 /* In C you can dereference an array to get the 1st elt. */
11026 || type
->code () == TYPE_CODE_ARRAY
)
11028 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11029 only be determined by inspecting the object's tag.
11030 This means that we need to evaluate completely the
11031 expression in order to get its type. */
11033 if ((type
->code () == TYPE_CODE_REF
11034 || type
->code () == TYPE_CODE_PTR
)
11035 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
11037 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11039 type
= value_type (ada_value_ind (arg1
));
11043 type
= to_static_fixed_type
11045 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
11047 ada_ensure_varsize_limit (type
);
11048 return value_zero (type
, lval_memory
);
11050 else if (type
->code () == TYPE_CODE_INT
)
11052 /* GDB allows dereferencing an int. */
11053 if (expect_type
== NULL
)
11054 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11059 to_static_fixed_type (ada_aligned_type (expect_type
));
11060 return value_zero (expect_type
, lval_memory
);
11064 error (_("Attempt to take contents of a non-pointer value."));
11066 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11067 type
= ada_check_typedef (value_type (arg1
));
11069 if (type
->code () == TYPE_CODE_INT
)
11070 /* GDB allows dereferencing an int. If we were given
11071 the expect_type, then use that as the target type.
11072 Otherwise, assume that the target type is an int. */
11074 if (expect_type
!= NULL
)
11075 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11078 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11079 (CORE_ADDR
) value_as_address (arg1
));
11082 if (ada_is_array_descriptor_type (type
))
11083 /* GDB allows dereferencing GNAT array descriptors. */
11084 return ada_coerce_to_simple_array (arg1
);
11086 return ada_value_ind (arg1
);
11088 case STRUCTOP_STRUCT
:
11089 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11090 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11091 preeval_pos
= *pos
;
11092 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11093 if (noside
== EVAL_SKIP
)
11095 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11097 struct type
*type1
= value_type (arg1
);
11099 if (ada_is_tagged_type (type1
, 1))
11101 type
= ada_lookup_struct_elt_type (type1
,
11102 &exp
->elts
[pc
+ 2].string
,
11105 /* If the field is not found, check if it exists in the
11106 extension of this object's type. This means that we
11107 need to evaluate completely the expression. */
11111 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11113 arg1
= ada_value_struct_elt (arg1
,
11114 &exp
->elts
[pc
+ 2].string
,
11116 arg1
= unwrap_value (arg1
);
11117 type
= value_type (ada_to_fixed_value (arg1
));
11122 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11125 return value_zero (ada_aligned_type (type
), lval_memory
);
11129 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11130 arg1
= unwrap_value (arg1
);
11131 return ada_to_fixed_value (arg1
);
11135 /* The value is not supposed to be used. This is here to make it
11136 easier to accommodate expressions that contain types. */
11138 if (noside
== EVAL_SKIP
)
11140 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11141 return allocate_value (exp
->elts
[pc
+ 1].type
);
11143 error (_("Attempt to use a type name as an expression"));
11148 case OP_DISCRETE_RANGE
:
11149 case OP_POSITIONAL
:
11151 if (noside
== EVAL_NORMAL
)
11155 error (_("Undefined name, ambiguous name, or renaming used in "
11156 "component association: %s."), &exp
->elts
[pc
+2].string
);
11158 error (_("Aggregates only allowed on the right of an assignment"));
11160 internal_error (__FILE__
, __LINE__
,
11161 _("aggregate apparently mangled"));
11164 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11166 for (tem
= 0; tem
< nargs
; tem
+= 1)
11167 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11172 return eval_skip_value (exp
);
11178 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11179 type name that encodes the 'small and 'delta information.
11180 Otherwise, return NULL. */
11182 static const char *
11183 gnat_encoded_fixed_type_info (struct type
*type
)
11185 const char *name
= ada_type_name (type
);
11186 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: type
->code ();
11188 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11190 const char *tail
= strstr (name
, "___XF_");
11197 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11198 return gnat_encoded_fixed_type_info (TYPE_TARGET_TYPE (type
));
11203 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11206 ada_is_gnat_encoded_fixed_point_type (struct type
*type
)
11208 return gnat_encoded_fixed_type_info (type
) != NULL
;
11211 /* Return non-zero iff TYPE represents a System.Address type. */
11214 ada_is_system_address_type (struct type
*type
)
11216 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11219 /* Assuming that TYPE is the representation of an Ada fixed-point
11220 type, return the target floating-point type to be used to represent
11221 of this type during internal computation. */
11223 static struct type
*
11224 ada_scaling_type (struct type
*type
)
11226 return builtin_type (get_type_arch (type
))->builtin_long_double
;
11229 /* Assuming that TYPE is the representation of an Ada fixed-point
11230 type, return its delta, or NULL if the type is malformed and the
11231 delta cannot be determined. */
11234 gnat_encoded_fixed_point_delta (struct type
*type
)
11236 const char *encoding
= gnat_encoded_fixed_type_info (type
);
11237 struct type
*scale_type
= ada_scaling_type (type
);
11239 long long num
, den
;
11241 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11244 return value_binop (value_from_longest (scale_type
, num
),
11245 value_from_longest (scale_type
, den
), BINOP_DIV
);
11248 /* Assuming that ada_is_gnat_encoded_fixed_point_type (TYPE), return
11249 the scaling factor ('SMALL value) associated with the type. */
11252 ada_scaling_factor (struct type
*type
)
11254 const char *encoding
= gnat_encoded_fixed_type_info (type
);
11255 struct type
*scale_type
= ada_scaling_type (type
);
11257 long long num0
, den0
, num1
, den1
;
11260 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11261 &num0
, &den0
, &num1
, &den1
);
11264 return value_from_longest (scale_type
, 1);
11266 return value_binop (value_from_longest (scale_type
, num1
),
11267 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11269 return value_binop (value_from_longest (scale_type
, num0
),
11270 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11277 /* Scan STR beginning at position K for a discriminant name, and
11278 return the value of that discriminant field of DVAL in *PX. If
11279 PNEW_K is not null, put the position of the character beyond the
11280 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11281 not alter *PX and *PNEW_K if unsuccessful. */
11284 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11287 static char *bound_buffer
= NULL
;
11288 static size_t bound_buffer_len
= 0;
11289 const char *pstart
, *pend
, *bound
;
11290 struct value
*bound_val
;
11292 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11296 pend
= strstr (pstart
, "__");
11300 k
+= strlen (bound
);
11304 int len
= pend
- pstart
;
11306 /* Strip __ and beyond. */
11307 GROW_VECT (bound_buffer
, bound_buffer_len
, len
+ 1);
11308 strncpy (bound_buffer
, pstart
, len
);
11309 bound_buffer
[len
] = '\0';
11311 bound
= bound_buffer
;
11315 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11316 if (bound_val
== NULL
)
11319 *px
= value_as_long (bound_val
);
11320 if (pnew_k
!= NULL
)
11325 /* Value of variable named NAME in the current environment. If
11326 no such variable found, then if ERR_MSG is null, returns 0, and
11327 otherwise causes an error with message ERR_MSG. */
11329 static struct value
*
11330 get_var_value (const char *name
, const char *err_msg
)
11332 lookup_name_info
lookup_name (name
, symbol_name_match_type::FULL
);
11334 std::vector
<struct block_symbol
> syms
;
11335 int nsyms
= ada_lookup_symbol_list_worker (lookup_name
,
11336 get_selected_block (0),
11337 VAR_DOMAIN
, &syms
, 1);
11341 if (err_msg
== NULL
)
11344 error (("%s"), err_msg
);
11347 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11350 /* Value of integer variable named NAME in the current environment.
11351 If no such variable is found, returns false. Otherwise, sets VALUE
11352 to the variable's value and returns true. */
11355 get_int_var_value (const char *name
, LONGEST
&value
)
11357 struct value
*var_val
= get_var_value (name
, 0);
11362 value
= value_as_long (var_val
);
11367 /* Return a range type whose base type is that of the range type named
11368 NAME in the current environment, and whose bounds are calculated
11369 from NAME according to the GNAT range encoding conventions.
11370 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11371 corresponding range type from debug information; fall back to using it
11372 if symbol lookup fails. If a new type must be created, allocate it
11373 like ORIG_TYPE was. The bounds information, in general, is encoded
11374 in NAME, the base type given in the named range type. */
11376 static struct type
*
11377 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11380 struct type
*base_type
;
11381 const char *subtype_info
;
11383 gdb_assert (raw_type
!= NULL
);
11384 gdb_assert (raw_type
->name () != NULL
);
11386 if (raw_type
->code () == TYPE_CODE_RANGE
)
11387 base_type
= TYPE_TARGET_TYPE (raw_type
);
11389 base_type
= raw_type
;
11391 name
= raw_type
->name ();
11392 subtype_info
= strstr (name
, "___XD");
11393 if (subtype_info
== NULL
)
11395 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11396 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11398 if (L
< INT_MIN
|| U
> INT_MAX
)
11401 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11406 static char *name_buf
= NULL
;
11407 static size_t name_len
= 0;
11408 int prefix_len
= subtype_info
- name
;
11411 const char *bounds_str
;
11414 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11415 strncpy (name_buf
, name
, prefix_len
);
11416 name_buf
[prefix_len
] = '\0';
11419 bounds_str
= strchr (subtype_info
, '_');
11422 if (*subtype_info
== 'L')
11424 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11425 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11427 if (bounds_str
[n
] == '_')
11429 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11435 strcpy (name_buf
+ prefix_len
, "___L");
11436 if (!get_int_var_value (name_buf
, L
))
11438 lim_warning (_("Unknown lower bound, using 1."));
11443 if (*subtype_info
== 'U')
11445 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11446 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11451 strcpy (name_buf
+ prefix_len
, "___U");
11452 if (!get_int_var_value (name_buf
, U
))
11454 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11459 type
= create_static_range_type (alloc_type_copy (raw_type
),
11461 /* create_static_range_type alters the resulting type's length
11462 to match the size of the base_type, which is not what we want.
11463 Set it back to the original range type's length. */
11464 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11465 type
->set_name (name
);
11470 /* True iff NAME is the name of a range type. */
11473 ada_is_range_type_name (const char *name
)
11475 return (name
!= NULL
&& strstr (name
, "___XD"));
11479 /* Modular types */
11481 /* True iff TYPE is an Ada modular type. */
11484 ada_is_modular_type (struct type
*type
)
11486 struct type
*subranged_type
= get_base_type (type
);
11488 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11489 && subranged_type
->code () == TYPE_CODE_INT
11490 && TYPE_UNSIGNED (subranged_type
));
11493 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11496 ada_modulus (struct type
*type
)
11498 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
11502 /* Ada exception catchpoint support:
11503 ---------------------------------
11505 We support 3 kinds of exception catchpoints:
11506 . catchpoints on Ada exceptions
11507 . catchpoints on unhandled Ada exceptions
11508 . catchpoints on failed assertions
11510 Exceptions raised during failed assertions, or unhandled exceptions
11511 could perfectly be caught with the general catchpoint on Ada exceptions.
11512 However, we can easily differentiate these two special cases, and having
11513 the option to distinguish these two cases from the rest can be useful
11514 to zero-in on certain situations.
11516 Exception catchpoints are a specialized form of breakpoint,
11517 since they rely on inserting breakpoints inside known routines
11518 of the GNAT runtime. The implementation therefore uses a standard
11519 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11522 Support in the runtime for exception catchpoints have been changed
11523 a few times already, and these changes affect the implementation
11524 of these catchpoints. In order to be able to support several
11525 variants of the runtime, we use a sniffer that will determine
11526 the runtime variant used by the program being debugged. */
11528 /* Ada's standard exceptions.
11530 The Ada 83 standard also defined Numeric_Error. But there so many
11531 situations where it was unclear from the Ada 83 Reference Manual
11532 (RM) whether Constraint_Error or Numeric_Error should be raised,
11533 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11534 Interpretation saying that anytime the RM says that Numeric_Error
11535 should be raised, the implementation may raise Constraint_Error.
11536 Ada 95 went one step further and pretty much removed Numeric_Error
11537 from the list of standard exceptions (it made it a renaming of
11538 Constraint_Error, to help preserve compatibility when compiling
11539 an Ada83 compiler). As such, we do not include Numeric_Error from
11540 this list of standard exceptions. */
11542 static const char *standard_exc
[] = {
11543 "constraint_error",
11549 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11551 /* A structure that describes how to support exception catchpoints
11552 for a given executable. */
11554 struct exception_support_info
11556 /* The name of the symbol to break on in order to insert
11557 a catchpoint on exceptions. */
11558 const char *catch_exception_sym
;
11560 /* The name of the symbol to break on in order to insert
11561 a catchpoint on unhandled exceptions. */
11562 const char *catch_exception_unhandled_sym
;
11564 /* The name of the symbol to break on in order to insert
11565 a catchpoint on failed assertions. */
11566 const char *catch_assert_sym
;
11568 /* The name of the symbol to break on in order to insert
11569 a catchpoint on exception handling. */
11570 const char *catch_handlers_sym
;
11572 /* Assuming that the inferior just triggered an unhandled exception
11573 catchpoint, this function is responsible for returning the address
11574 in inferior memory where the name of that exception is stored.
11575 Return zero if the address could not be computed. */
11576 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11579 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11580 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11582 /* The following exception support info structure describes how to
11583 implement exception catchpoints with the latest version of the
11584 Ada runtime (as of 2019-08-??). */
11586 static const struct exception_support_info default_exception_support_info
=
11588 "__gnat_debug_raise_exception", /* catch_exception_sym */
11589 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11590 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11591 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11592 ada_unhandled_exception_name_addr
11595 /* The following exception support info structure describes how to
11596 implement exception catchpoints with an earlier version of the
11597 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11599 static const struct exception_support_info exception_support_info_v0
=
11601 "__gnat_debug_raise_exception", /* catch_exception_sym */
11602 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11603 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11604 "__gnat_begin_handler", /* catch_handlers_sym */
11605 ada_unhandled_exception_name_addr
11608 /* The following exception support info structure describes how to
11609 implement exception catchpoints with a slightly older version
11610 of the Ada runtime. */
11612 static const struct exception_support_info exception_support_info_fallback
=
11614 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11615 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11616 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11617 "__gnat_begin_handler", /* catch_handlers_sym */
11618 ada_unhandled_exception_name_addr_from_raise
11621 /* Return nonzero if we can detect the exception support routines
11622 described in EINFO.
11624 This function errors out if an abnormal situation is detected
11625 (for instance, if we find the exception support routines, but
11626 that support is found to be incomplete). */
11629 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11631 struct symbol
*sym
;
11633 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11634 that should be compiled with debugging information. As a result, we
11635 expect to find that symbol in the symtabs. */
11637 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11640 /* Perhaps we did not find our symbol because the Ada runtime was
11641 compiled without debugging info, or simply stripped of it.
11642 It happens on some GNU/Linux distributions for instance, where
11643 users have to install a separate debug package in order to get
11644 the runtime's debugging info. In that situation, let the user
11645 know why we cannot insert an Ada exception catchpoint.
11647 Note: Just for the purpose of inserting our Ada exception
11648 catchpoint, we could rely purely on the associated minimal symbol.
11649 But we would be operating in degraded mode anyway, since we are
11650 still lacking the debugging info needed later on to extract
11651 the name of the exception being raised (this name is printed in
11652 the catchpoint message, and is also used when trying to catch
11653 a specific exception). We do not handle this case for now. */
11654 struct bound_minimal_symbol msym
11655 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11657 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11658 error (_("Your Ada runtime appears to be missing some debugging "
11659 "information.\nCannot insert Ada exception catchpoint "
11660 "in this configuration."));
11665 /* Make sure that the symbol we found corresponds to a function. */
11667 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11669 error (_("Symbol \"%s\" is not a function (class = %d)"),
11670 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11674 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11677 struct bound_minimal_symbol msym
11678 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11680 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11681 error (_("Your Ada runtime appears to be missing some debugging "
11682 "information.\nCannot insert Ada exception catchpoint "
11683 "in this configuration."));
11688 /* Make sure that the symbol we found corresponds to a function. */
11690 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11692 error (_("Symbol \"%s\" is not a function (class = %d)"),
11693 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11700 /* Inspect the Ada runtime and determine which exception info structure
11701 should be used to provide support for exception catchpoints.
11703 This function will always set the per-inferior exception_info,
11704 or raise an error. */
11707 ada_exception_support_info_sniffer (void)
11709 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11711 /* If the exception info is already known, then no need to recompute it. */
11712 if (data
->exception_info
!= NULL
)
11715 /* Check the latest (default) exception support info. */
11716 if (ada_has_this_exception_support (&default_exception_support_info
))
11718 data
->exception_info
= &default_exception_support_info
;
11722 /* Try the v0 exception suport info. */
11723 if (ada_has_this_exception_support (&exception_support_info_v0
))
11725 data
->exception_info
= &exception_support_info_v0
;
11729 /* Try our fallback exception suport info. */
11730 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11732 data
->exception_info
= &exception_support_info_fallback
;
11736 /* Sometimes, it is normal for us to not be able to find the routine
11737 we are looking for. This happens when the program is linked with
11738 the shared version of the GNAT runtime, and the program has not been
11739 started yet. Inform the user of these two possible causes if
11742 if (ada_update_initial_language (language_unknown
) != language_ada
)
11743 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11745 /* If the symbol does not exist, then check that the program is
11746 already started, to make sure that shared libraries have been
11747 loaded. If it is not started, this may mean that the symbol is
11748 in a shared library. */
11750 if (inferior_ptid
.pid () == 0)
11751 error (_("Unable to insert catchpoint. Try to start the program first."));
11753 /* At this point, we know that we are debugging an Ada program and
11754 that the inferior has been started, but we still are not able to
11755 find the run-time symbols. That can mean that we are in
11756 configurable run time mode, or that a-except as been optimized
11757 out by the linker... In any case, at this point it is not worth
11758 supporting this feature. */
11760 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11763 /* True iff FRAME is very likely to be that of a function that is
11764 part of the runtime system. This is all very heuristic, but is
11765 intended to be used as advice as to what frames are uninteresting
11769 is_known_support_routine (struct frame_info
*frame
)
11771 enum language func_lang
;
11773 const char *fullname
;
11775 /* If this code does not have any debugging information (no symtab),
11776 This cannot be any user code. */
11778 symtab_and_line sal
= find_frame_sal (frame
);
11779 if (sal
.symtab
== NULL
)
11782 /* If there is a symtab, but the associated source file cannot be
11783 located, then assume this is not user code: Selecting a frame
11784 for which we cannot display the code would not be very helpful
11785 for the user. This should also take care of case such as VxWorks
11786 where the kernel has some debugging info provided for a few units. */
11788 fullname
= symtab_to_fullname (sal
.symtab
);
11789 if (access (fullname
, R_OK
) != 0)
11792 /* Check the unit filename against the Ada runtime file naming.
11793 We also check the name of the objfile against the name of some
11794 known system libraries that sometimes come with debugging info
11797 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11799 re_comp (known_runtime_file_name_patterns
[i
]);
11800 if (re_exec (lbasename (sal
.symtab
->filename
)))
11802 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11803 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11807 /* Check whether the function is a GNAT-generated entity. */
11809 gdb::unique_xmalloc_ptr
<char> func_name
11810 = find_frame_funname (frame
, &func_lang
, NULL
);
11811 if (func_name
== NULL
)
11814 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11816 re_comp (known_auxiliary_function_name_patterns
[i
]);
11817 if (re_exec (func_name
.get ()))
11824 /* Find the first frame that contains debugging information and that is not
11825 part of the Ada run-time, starting from FI and moving upward. */
11828 ada_find_printable_frame (struct frame_info
*fi
)
11830 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11832 if (!is_known_support_routine (fi
))
11841 /* Assuming that the inferior just triggered an unhandled exception
11842 catchpoint, return the address in inferior memory where the name
11843 of the exception is stored.
11845 Return zero if the address could not be computed. */
11848 ada_unhandled_exception_name_addr (void)
11850 return parse_and_eval_address ("e.full_name");
11853 /* Same as ada_unhandled_exception_name_addr, except that this function
11854 should be used when the inferior uses an older version of the runtime,
11855 where the exception name needs to be extracted from a specific frame
11856 several frames up in the callstack. */
11859 ada_unhandled_exception_name_addr_from_raise (void)
11862 struct frame_info
*fi
;
11863 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11865 /* To determine the name of this exception, we need to select
11866 the frame corresponding to RAISE_SYM_NAME. This frame is
11867 at least 3 levels up, so we simply skip the first 3 frames
11868 without checking the name of their associated function. */
11869 fi
= get_current_frame ();
11870 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11872 fi
= get_prev_frame (fi
);
11876 enum language func_lang
;
11878 gdb::unique_xmalloc_ptr
<char> func_name
11879 = find_frame_funname (fi
, &func_lang
, NULL
);
11880 if (func_name
!= NULL
)
11882 if (strcmp (func_name
.get (),
11883 data
->exception_info
->catch_exception_sym
) == 0)
11884 break; /* We found the frame we were looking for... */
11886 fi
= get_prev_frame (fi
);
11893 return parse_and_eval_address ("id.full_name");
11896 /* Assuming the inferior just triggered an Ada exception catchpoint
11897 (of any type), return the address in inferior memory where the name
11898 of the exception is stored, if applicable.
11900 Assumes the selected frame is the current frame.
11902 Return zero if the address could not be computed, or if not relevant. */
11905 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11906 struct breakpoint
*b
)
11908 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11912 case ada_catch_exception
:
11913 return (parse_and_eval_address ("e.full_name"));
11916 case ada_catch_exception_unhandled
:
11917 return data
->exception_info
->unhandled_exception_name_addr ();
11920 case ada_catch_handlers
:
11921 return 0; /* The runtimes does not provide access to the exception
11925 case ada_catch_assert
:
11926 return 0; /* Exception name is not relevant in this case. */
11930 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11934 return 0; /* Should never be reached. */
11937 /* Assuming the inferior is stopped at an exception catchpoint,
11938 return the message which was associated to the exception, if
11939 available. Return NULL if the message could not be retrieved.
11941 Note: The exception message can be associated to an exception
11942 either through the use of the Raise_Exception function, or
11943 more simply (Ada 2005 and later), via:
11945 raise Exception_Name with "exception message";
11949 static gdb::unique_xmalloc_ptr
<char>
11950 ada_exception_message_1 (void)
11952 struct value
*e_msg_val
;
11955 /* For runtimes that support this feature, the exception message
11956 is passed as an unbounded string argument called "message". */
11957 e_msg_val
= parse_and_eval ("message");
11958 if (e_msg_val
== NULL
)
11959 return NULL
; /* Exception message not supported. */
11961 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
11962 gdb_assert (e_msg_val
!= NULL
);
11963 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
11965 /* If the message string is empty, then treat it as if there was
11966 no exception message. */
11967 if (e_msg_len
<= 0)
11970 return target_read_string (value_address (e_msg_val
), INT_MAX
);
11973 /* Same as ada_exception_message_1, except that all exceptions are
11974 contained here (returning NULL instead). */
11976 static gdb::unique_xmalloc_ptr
<char>
11977 ada_exception_message (void)
11979 gdb::unique_xmalloc_ptr
<char> e_msg
;
11983 e_msg
= ada_exception_message_1 ();
11985 catch (const gdb_exception_error
&e
)
11987 e_msg
.reset (nullptr);
11993 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11994 any error that ada_exception_name_addr_1 might cause to be thrown.
11995 When an error is intercepted, a warning with the error message is printed,
11996 and zero is returned. */
11999 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
12000 struct breakpoint
*b
)
12002 CORE_ADDR result
= 0;
12006 result
= ada_exception_name_addr_1 (ex
, b
);
12009 catch (const gdb_exception_error
&e
)
12011 warning (_("failed to get exception name: %s"), e
.what ());
12018 static std::string ada_exception_catchpoint_cond_string
12019 (const char *excep_string
,
12020 enum ada_exception_catchpoint_kind ex
);
12022 /* Ada catchpoints.
12024 In the case of catchpoints on Ada exceptions, the catchpoint will
12025 stop the target on every exception the program throws. When a user
12026 specifies the name of a specific exception, we translate this
12027 request into a condition expression (in text form), and then parse
12028 it into an expression stored in each of the catchpoint's locations.
12029 We then use this condition to check whether the exception that was
12030 raised is the one the user is interested in. If not, then the
12031 target is resumed again. We store the name of the requested
12032 exception, in order to be able to re-set the condition expression
12033 when symbols change. */
12035 /* An instance of this type is used to represent an Ada catchpoint
12036 breakpoint location. */
12038 class ada_catchpoint_location
: public bp_location
12041 ada_catchpoint_location (breakpoint
*owner
)
12042 : bp_location (owner
, bp_loc_software_breakpoint
)
12045 /* The condition that checks whether the exception that was raised
12046 is the specific exception the user specified on catchpoint
12048 expression_up excep_cond_expr
;
12051 /* An instance of this type is used to represent an Ada catchpoint. */
12053 struct ada_catchpoint
: public breakpoint
12055 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
12060 /* The name of the specific exception the user specified. */
12061 std::string excep_string
;
12063 /* What kind of catchpoint this is. */
12064 enum ada_exception_catchpoint_kind m_kind
;
12067 /* Parse the exception condition string in the context of each of the
12068 catchpoint's locations, and store them for later evaluation. */
12071 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12072 enum ada_exception_catchpoint_kind ex
)
12074 struct bp_location
*bl
;
12076 /* Nothing to do if there's no specific exception to catch. */
12077 if (c
->excep_string
.empty ())
12080 /* Same if there are no locations... */
12081 if (c
->loc
== NULL
)
12084 /* Compute the condition expression in text form, from the specific
12085 expection we want to catch. */
12086 std::string cond_string
12087 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
12089 /* Iterate over all the catchpoint's locations, and parse an
12090 expression for each. */
12091 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
12093 struct ada_catchpoint_location
*ada_loc
12094 = (struct ada_catchpoint_location
*) bl
;
12097 if (!bl
->shlib_disabled
)
12101 s
= cond_string
.c_str ();
12104 exp
= parse_exp_1 (&s
, bl
->address
,
12105 block_for_pc (bl
->address
),
12108 catch (const gdb_exception_error
&e
)
12110 warning (_("failed to reevaluate internal exception condition "
12111 "for catchpoint %d: %s"),
12112 c
->number
, e
.what ());
12116 ada_loc
->excep_cond_expr
= std::move (exp
);
12120 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12121 structure for all exception catchpoint kinds. */
12123 static struct bp_location
*
12124 allocate_location_exception (struct breakpoint
*self
)
12126 return new ada_catchpoint_location (self
);
12129 /* Implement the RE_SET method in the breakpoint_ops structure for all
12130 exception catchpoint kinds. */
12133 re_set_exception (struct breakpoint
*b
)
12135 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12137 /* Call the base class's method. This updates the catchpoint's
12139 bkpt_breakpoint_ops
.re_set (b
);
12141 /* Reparse the exception conditional expressions. One for each
12143 create_excep_cond_exprs (c
, c
->m_kind
);
12146 /* Returns true if we should stop for this breakpoint hit. If the
12147 user specified a specific exception, we only want to cause a stop
12148 if the program thrown that exception. */
12151 should_stop_exception (const struct bp_location
*bl
)
12153 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12154 const struct ada_catchpoint_location
*ada_loc
12155 = (const struct ada_catchpoint_location
*) bl
;
12158 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12159 if (c
->m_kind
== ada_catch_assert
)
12160 clear_internalvar (var
);
12167 if (c
->m_kind
== ada_catch_handlers
)
12168 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12169 ".all.occurrence.id");
12173 struct value
*exc
= parse_and_eval (expr
);
12174 set_internalvar (var
, exc
);
12176 catch (const gdb_exception_error
&ex
)
12178 clear_internalvar (var
);
12182 /* With no specific exception, should always stop. */
12183 if (c
->excep_string
.empty ())
12186 if (ada_loc
->excep_cond_expr
== NULL
)
12188 /* We will have a NULL expression if back when we were creating
12189 the expressions, this location's had failed to parse. */
12196 struct value
*mark
;
12198 mark
= value_mark ();
12199 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12200 value_free_to_mark (mark
);
12202 catch (const gdb_exception
&ex
)
12204 exception_fprintf (gdb_stderr
, ex
,
12205 _("Error in testing exception condition:\n"));
12211 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12212 for all exception catchpoint kinds. */
12215 check_status_exception (bpstat bs
)
12217 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
12220 /* Implement the PRINT_IT method in the breakpoint_ops structure
12221 for all exception catchpoint kinds. */
12223 static enum print_stop_action
12224 print_it_exception (bpstat bs
)
12226 struct ui_out
*uiout
= current_uiout
;
12227 struct breakpoint
*b
= bs
->breakpoint_at
;
12229 annotate_catchpoint (b
->number
);
12231 if (uiout
->is_mi_like_p ())
12233 uiout
->field_string ("reason",
12234 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12235 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12238 uiout
->text (b
->disposition
== disp_del
12239 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12240 uiout
->field_signed ("bkptno", b
->number
);
12241 uiout
->text (", ");
12243 /* ada_exception_name_addr relies on the selected frame being the
12244 current frame. Need to do this here because this function may be
12245 called more than once when printing a stop, and below, we'll
12246 select the first frame past the Ada run-time (see
12247 ada_find_printable_frame). */
12248 select_frame (get_current_frame ());
12250 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12253 case ada_catch_exception
:
12254 case ada_catch_exception_unhandled
:
12255 case ada_catch_handlers
:
12257 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12258 char exception_name
[256];
12262 read_memory (addr
, (gdb_byte
*) exception_name
,
12263 sizeof (exception_name
) - 1);
12264 exception_name
[sizeof (exception_name
) - 1] = '\0';
12268 /* For some reason, we were unable to read the exception
12269 name. This could happen if the Runtime was compiled
12270 without debugging info, for instance. In that case,
12271 just replace the exception name by the generic string
12272 "exception" - it will read as "an exception" in the
12273 notification we are about to print. */
12274 memcpy (exception_name
, "exception", sizeof ("exception"));
12276 /* In the case of unhandled exception breakpoints, we print
12277 the exception name as "unhandled EXCEPTION_NAME", to make
12278 it clearer to the user which kind of catchpoint just got
12279 hit. We used ui_out_text to make sure that this extra
12280 info does not pollute the exception name in the MI case. */
12281 if (c
->m_kind
== ada_catch_exception_unhandled
)
12282 uiout
->text ("unhandled ");
12283 uiout
->field_string ("exception-name", exception_name
);
12286 case ada_catch_assert
:
12287 /* In this case, the name of the exception is not really
12288 important. Just print "failed assertion" to make it clearer
12289 that his program just hit an assertion-failure catchpoint.
12290 We used ui_out_text because this info does not belong in
12292 uiout
->text ("failed assertion");
12296 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12297 if (exception_message
!= NULL
)
12299 uiout
->text (" (");
12300 uiout
->field_string ("exception-message", exception_message
.get ());
12304 uiout
->text (" at ");
12305 ada_find_printable_frame (get_current_frame ());
12307 return PRINT_SRC_AND_LOC
;
12310 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12311 for all exception catchpoint kinds. */
12314 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12316 struct ui_out
*uiout
= current_uiout
;
12317 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12318 struct value_print_options opts
;
12320 get_user_print_options (&opts
);
12322 if (opts
.addressprint
)
12323 uiout
->field_skip ("addr");
12325 annotate_field (5);
12328 case ada_catch_exception
:
12329 if (!c
->excep_string
.empty ())
12331 std::string msg
= string_printf (_("`%s' Ada exception"),
12332 c
->excep_string
.c_str ());
12334 uiout
->field_string ("what", msg
);
12337 uiout
->field_string ("what", "all Ada exceptions");
12341 case ada_catch_exception_unhandled
:
12342 uiout
->field_string ("what", "unhandled Ada exceptions");
12345 case ada_catch_handlers
:
12346 if (!c
->excep_string
.empty ())
12348 uiout
->field_fmt ("what",
12349 _("`%s' Ada exception handlers"),
12350 c
->excep_string
.c_str ());
12353 uiout
->field_string ("what", "all Ada exceptions handlers");
12356 case ada_catch_assert
:
12357 uiout
->field_string ("what", "failed Ada assertions");
12361 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12366 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12367 for all exception catchpoint kinds. */
12370 print_mention_exception (struct breakpoint
*b
)
12372 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12373 struct ui_out
*uiout
= current_uiout
;
12375 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12376 : _("Catchpoint "));
12377 uiout
->field_signed ("bkptno", b
->number
);
12378 uiout
->text (": ");
12382 case ada_catch_exception
:
12383 if (!c
->excep_string
.empty ())
12385 std::string info
= string_printf (_("`%s' Ada exception"),
12386 c
->excep_string
.c_str ());
12387 uiout
->text (info
.c_str ());
12390 uiout
->text (_("all Ada exceptions"));
12393 case ada_catch_exception_unhandled
:
12394 uiout
->text (_("unhandled Ada exceptions"));
12397 case ada_catch_handlers
:
12398 if (!c
->excep_string
.empty ())
12401 = string_printf (_("`%s' Ada exception handlers"),
12402 c
->excep_string
.c_str ());
12403 uiout
->text (info
.c_str ());
12406 uiout
->text (_("all Ada exceptions handlers"));
12409 case ada_catch_assert
:
12410 uiout
->text (_("failed Ada assertions"));
12414 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12419 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12420 for all exception catchpoint kinds. */
12423 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12425 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12429 case ada_catch_exception
:
12430 fprintf_filtered (fp
, "catch exception");
12431 if (!c
->excep_string
.empty ())
12432 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12435 case ada_catch_exception_unhandled
:
12436 fprintf_filtered (fp
, "catch exception unhandled");
12439 case ada_catch_handlers
:
12440 fprintf_filtered (fp
, "catch handlers");
12443 case ada_catch_assert
:
12444 fprintf_filtered (fp
, "catch assert");
12448 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12450 print_recreate_thread (b
, fp
);
12453 /* Virtual tables for various breakpoint types. */
12454 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12455 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12456 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12457 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12459 /* See ada-lang.h. */
12462 is_ada_exception_catchpoint (breakpoint
*bp
)
12464 return (bp
->ops
== &catch_exception_breakpoint_ops
12465 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12466 || bp
->ops
== &catch_assert_breakpoint_ops
12467 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12470 /* Split the arguments specified in a "catch exception" command.
12471 Set EX to the appropriate catchpoint type.
12472 Set EXCEP_STRING to the name of the specific exception if
12473 specified by the user.
12474 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12475 "catch handlers" command. False otherwise.
12476 If a condition is found at the end of the arguments, the condition
12477 expression is stored in COND_STRING (memory must be deallocated
12478 after use). Otherwise COND_STRING is set to NULL. */
12481 catch_ada_exception_command_split (const char *args
,
12482 bool is_catch_handlers_cmd
,
12483 enum ada_exception_catchpoint_kind
*ex
,
12484 std::string
*excep_string
,
12485 std::string
*cond_string
)
12487 std::string exception_name
;
12489 exception_name
= extract_arg (&args
);
12490 if (exception_name
== "if")
12492 /* This is not an exception name; this is the start of a condition
12493 expression for a catchpoint on all exceptions. So, "un-get"
12494 this token, and set exception_name to NULL. */
12495 exception_name
.clear ();
12499 /* Check to see if we have a condition. */
12501 args
= skip_spaces (args
);
12502 if (startswith (args
, "if")
12503 && (isspace (args
[2]) || args
[2] == '\0'))
12506 args
= skip_spaces (args
);
12508 if (args
[0] == '\0')
12509 error (_("Condition missing after `if' keyword"));
12510 *cond_string
= args
;
12512 args
+= strlen (args
);
12515 /* Check that we do not have any more arguments. Anything else
12518 if (args
[0] != '\0')
12519 error (_("Junk at end of expression"));
12521 if (is_catch_handlers_cmd
)
12523 /* Catch handling of exceptions. */
12524 *ex
= ada_catch_handlers
;
12525 *excep_string
= exception_name
;
12527 else if (exception_name
.empty ())
12529 /* Catch all exceptions. */
12530 *ex
= ada_catch_exception
;
12531 excep_string
->clear ();
12533 else if (exception_name
== "unhandled")
12535 /* Catch unhandled exceptions. */
12536 *ex
= ada_catch_exception_unhandled
;
12537 excep_string
->clear ();
12541 /* Catch a specific exception. */
12542 *ex
= ada_catch_exception
;
12543 *excep_string
= exception_name
;
12547 /* Return the name of the symbol on which we should break in order to
12548 implement a catchpoint of the EX kind. */
12550 static const char *
12551 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12553 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12555 gdb_assert (data
->exception_info
!= NULL
);
12559 case ada_catch_exception
:
12560 return (data
->exception_info
->catch_exception_sym
);
12562 case ada_catch_exception_unhandled
:
12563 return (data
->exception_info
->catch_exception_unhandled_sym
);
12565 case ada_catch_assert
:
12566 return (data
->exception_info
->catch_assert_sym
);
12568 case ada_catch_handlers
:
12569 return (data
->exception_info
->catch_handlers_sym
);
12572 internal_error (__FILE__
, __LINE__
,
12573 _("unexpected catchpoint kind (%d)"), ex
);
12577 /* Return the breakpoint ops "virtual table" used for catchpoints
12580 static const struct breakpoint_ops
*
12581 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12585 case ada_catch_exception
:
12586 return (&catch_exception_breakpoint_ops
);
12588 case ada_catch_exception_unhandled
:
12589 return (&catch_exception_unhandled_breakpoint_ops
);
12591 case ada_catch_assert
:
12592 return (&catch_assert_breakpoint_ops
);
12594 case ada_catch_handlers
:
12595 return (&catch_handlers_breakpoint_ops
);
12598 internal_error (__FILE__
, __LINE__
,
12599 _("unexpected catchpoint kind (%d)"), ex
);
12603 /* Return the condition that will be used to match the current exception
12604 being raised with the exception that the user wants to catch. This
12605 assumes that this condition is used when the inferior just triggered
12606 an exception catchpoint.
12607 EX: the type of catchpoints used for catching Ada exceptions. */
12610 ada_exception_catchpoint_cond_string (const char *excep_string
,
12611 enum ada_exception_catchpoint_kind ex
)
12614 bool is_standard_exc
= false;
12615 std::string result
;
12617 if (ex
== ada_catch_handlers
)
12619 /* For exception handlers catchpoints, the condition string does
12620 not use the same parameter as for the other exceptions. */
12621 result
= ("long_integer (GNAT_GCC_exception_Access"
12622 "(gcc_exception).all.occurrence.id)");
12625 result
= "long_integer (e)";
12627 /* The standard exceptions are a special case. They are defined in
12628 runtime units that have been compiled without debugging info; if
12629 EXCEP_STRING is the not-fully-qualified name of a standard
12630 exception (e.g. "constraint_error") then, during the evaluation
12631 of the condition expression, the symbol lookup on this name would
12632 *not* return this standard exception. The catchpoint condition
12633 may then be set only on user-defined exceptions which have the
12634 same not-fully-qualified name (e.g. my_package.constraint_error).
12636 To avoid this unexcepted behavior, these standard exceptions are
12637 systematically prefixed by "standard". This means that "catch
12638 exception constraint_error" is rewritten into "catch exception
12639 standard.constraint_error".
12641 If an exception named constraint_error is defined in another package of
12642 the inferior program, then the only way to specify this exception as a
12643 breakpoint condition is to use its fully-qualified named:
12644 e.g. my_package.constraint_error. */
12646 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12648 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12650 is_standard_exc
= true;
12657 if (is_standard_exc
)
12658 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12660 string_appendf (result
, "long_integer (&%s)", excep_string
);
12665 /* Return the symtab_and_line that should be used to insert an exception
12666 catchpoint of the TYPE kind.
12668 ADDR_STRING returns the name of the function where the real
12669 breakpoint that implements the catchpoints is set, depending on the
12670 type of catchpoint we need to create. */
12672 static struct symtab_and_line
12673 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12674 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12676 const char *sym_name
;
12677 struct symbol
*sym
;
12679 /* First, find out which exception support info to use. */
12680 ada_exception_support_info_sniffer ();
12682 /* Then lookup the function on which we will break in order to catch
12683 the Ada exceptions requested by the user. */
12684 sym_name
= ada_exception_sym_name (ex
);
12685 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12688 error (_("Catchpoint symbol not found: %s"), sym_name
);
12690 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12691 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12693 /* Set ADDR_STRING. */
12694 *addr_string
= sym_name
;
12697 *ops
= ada_exception_breakpoint_ops (ex
);
12699 return find_function_start_sal (sym
, 1);
12702 /* Create an Ada exception catchpoint.
12704 EX_KIND is the kind of exception catchpoint to be created.
12706 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12707 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12708 of the exception to which this catchpoint applies.
12710 COND_STRING, if not empty, is the catchpoint condition.
12712 TEMPFLAG, if nonzero, means that the underlying breakpoint
12713 should be temporary.
12715 FROM_TTY is the usual argument passed to all commands implementations. */
12718 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12719 enum ada_exception_catchpoint_kind ex_kind
,
12720 const std::string
&excep_string
,
12721 const std::string
&cond_string
,
12726 std::string addr_string
;
12727 const struct breakpoint_ops
*ops
= NULL
;
12728 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12730 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12731 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12732 ops
, tempflag
, disabled
, from_tty
);
12733 c
->excep_string
= excep_string
;
12734 create_excep_cond_exprs (c
.get (), ex_kind
);
12735 if (!cond_string
.empty ())
12736 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
);
12737 install_breakpoint (0, std::move (c
), 1);
12740 /* Implement the "catch exception" command. */
12743 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12744 struct cmd_list_element
*command
)
12746 const char *arg
= arg_entry
;
12747 struct gdbarch
*gdbarch
= get_current_arch ();
12749 enum ada_exception_catchpoint_kind ex_kind
;
12750 std::string excep_string
;
12751 std::string cond_string
;
12753 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12757 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12759 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12760 excep_string
, cond_string
,
12761 tempflag
, 1 /* enabled */,
12765 /* Implement the "catch handlers" command. */
12768 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12769 struct cmd_list_element
*command
)
12771 const char *arg
= arg_entry
;
12772 struct gdbarch
*gdbarch
= get_current_arch ();
12774 enum ada_exception_catchpoint_kind ex_kind
;
12775 std::string excep_string
;
12776 std::string cond_string
;
12778 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12782 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12784 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12785 excep_string
, cond_string
,
12786 tempflag
, 1 /* enabled */,
12790 /* Completion function for the Ada "catch" commands. */
12793 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12794 const char *text
, const char *word
)
12796 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12798 for (const ada_exc_info
&info
: exceptions
)
12800 if (startswith (info
.name
, word
))
12801 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12805 /* Split the arguments specified in a "catch assert" command.
12807 ARGS contains the command's arguments (or the empty string if
12808 no arguments were passed).
12810 If ARGS contains a condition, set COND_STRING to that condition
12811 (the memory needs to be deallocated after use). */
12814 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12816 args
= skip_spaces (args
);
12818 /* Check whether a condition was provided. */
12819 if (startswith (args
, "if")
12820 && (isspace (args
[2]) || args
[2] == '\0'))
12823 args
= skip_spaces (args
);
12824 if (args
[0] == '\0')
12825 error (_("condition missing after `if' keyword"));
12826 cond_string
.assign (args
);
12829 /* Otherwise, there should be no other argument at the end of
12831 else if (args
[0] != '\0')
12832 error (_("Junk at end of arguments."));
12835 /* Implement the "catch assert" command. */
12838 catch_assert_command (const char *arg_entry
, int from_tty
,
12839 struct cmd_list_element
*command
)
12841 const char *arg
= arg_entry
;
12842 struct gdbarch
*gdbarch
= get_current_arch ();
12844 std::string cond_string
;
12846 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12850 catch_ada_assert_command_split (arg
, cond_string
);
12851 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12853 tempflag
, 1 /* enabled */,
12857 /* Return non-zero if the symbol SYM is an Ada exception object. */
12860 ada_is_exception_sym (struct symbol
*sym
)
12862 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12864 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12865 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12866 && SYMBOL_CLASS (sym
) != LOC_CONST
12867 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12868 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12871 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12872 Ada exception object. This matches all exceptions except the ones
12873 defined by the Ada language. */
12876 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12880 if (!ada_is_exception_sym (sym
))
12883 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12884 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
12885 return 0; /* A standard exception. */
12887 /* Numeric_Error is also a standard exception, so exclude it.
12888 See the STANDARD_EXC description for more details as to why
12889 this exception is not listed in that array. */
12890 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
12896 /* A helper function for std::sort, comparing two struct ada_exc_info
12899 The comparison is determined first by exception name, and then
12900 by exception address. */
12903 ada_exc_info::operator< (const ada_exc_info
&other
) const
12907 result
= strcmp (name
, other
.name
);
12910 if (result
== 0 && addr
< other
.addr
)
12916 ada_exc_info::operator== (const ada_exc_info
&other
) const
12918 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
12921 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12922 routine, but keeping the first SKIP elements untouched.
12924 All duplicates are also removed. */
12927 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
12930 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
12931 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
12932 exceptions
->end ());
12935 /* Add all exceptions defined by the Ada standard whose name match
12936 a regular expression.
12938 If PREG is not NULL, then this regexp_t object is used to
12939 perform the symbol name matching. Otherwise, no name-based
12940 filtering is performed.
12942 EXCEPTIONS is a vector of exceptions to which matching exceptions
12946 ada_add_standard_exceptions (compiled_regex
*preg
,
12947 std::vector
<ada_exc_info
> *exceptions
)
12951 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12954 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
12956 struct bound_minimal_symbol msymbol
12957 = ada_lookup_simple_minsym (standard_exc
[i
]);
12959 if (msymbol
.minsym
!= NULL
)
12961 struct ada_exc_info info
12962 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
12964 exceptions
->push_back (info
);
12970 /* Add all Ada exceptions defined locally and accessible from the given
12973 If PREG is not NULL, then this regexp_t object is used to
12974 perform the symbol name matching. Otherwise, no name-based
12975 filtering is performed.
12977 EXCEPTIONS is a vector of exceptions to which matching exceptions
12981 ada_add_exceptions_from_frame (compiled_regex
*preg
,
12982 struct frame_info
*frame
,
12983 std::vector
<ada_exc_info
> *exceptions
)
12985 const struct block
*block
= get_frame_block (frame
, 0);
12989 struct block_iterator iter
;
12990 struct symbol
*sym
;
12992 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
12994 switch (SYMBOL_CLASS (sym
))
13001 if (ada_is_exception_sym (sym
))
13003 struct ada_exc_info info
= {sym
->print_name (),
13004 SYMBOL_VALUE_ADDRESS (sym
)};
13006 exceptions
->push_back (info
);
13010 if (BLOCK_FUNCTION (block
) != NULL
)
13012 block
= BLOCK_SUPERBLOCK (block
);
13016 /* Return true if NAME matches PREG or if PREG is NULL. */
13019 name_matches_regex (const char *name
, compiled_regex
*preg
)
13021 return (preg
== NULL
13022 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
13025 /* Add all exceptions defined globally whose name name match
13026 a regular expression, excluding standard exceptions.
13028 The reason we exclude standard exceptions is that they need
13029 to be handled separately: Standard exceptions are defined inside
13030 a runtime unit which is normally not compiled with debugging info,
13031 and thus usually do not show up in our symbol search. However,
13032 if the unit was in fact built with debugging info, we need to
13033 exclude them because they would duplicate the entry we found
13034 during the special loop that specifically searches for those
13035 standard exceptions.
13037 If PREG is not NULL, then this regexp_t object is used to
13038 perform the symbol name matching. Otherwise, no name-based
13039 filtering is performed.
13041 EXCEPTIONS is a vector of exceptions to which matching exceptions
13045 ada_add_global_exceptions (compiled_regex
*preg
,
13046 std::vector
<ada_exc_info
> *exceptions
)
13048 /* In Ada, the symbol "search name" is a linkage name, whereas the
13049 regular expression used to do the matching refers to the natural
13050 name. So match against the decoded name. */
13051 expand_symtabs_matching (NULL
,
13052 lookup_name_info::match_any (),
13053 [&] (const char *search_name
)
13055 std::string decoded
= ada_decode (search_name
);
13056 return name_matches_regex (decoded
.c_str (), preg
);
13061 for (objfile
*objfile
: current_program_space
->objfiles ())
13063 for (compunit_symtab
*s
: objfile
->compunits ())
13065 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13068 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13070 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13071 struct block_iterator iter
;
13072 struct symbol
*sym
;
13074 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13075 if (ada_is_non_standard_exception_sym (sym
)
13076 && name_matches_regex (sym
->natural_name (), preg
))
13078 struct ada_exc_info info
13079 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
13081 exceptions
->push_back (info
);
13088 /* Implements ada_exceptions_list with the regular expression passed
13089 as a regex_t, rather than a string.
13091 If not NULL, PREG is used to filter out exceptions whose names
13092 do not match. Otherwise, all exceptions are listed. */
13094 static std::vector
<ada_exc_info
>
13095 ada_exceptions_list_1 (compiled_regex
*preg
)
13097 std::vector
<ada_exc_info
> result
;
13100 /* First, list the known standard exceptions. These exceptions
13101 need to be handled separately, as they are usually defined in
13102 runtime units that have been compiled without debugging info. */
13104 ada_add_standard_exceptions (preg
, &result
);
13106 /* Next, find all exceptions whose scope is local and accessible
13107 from the currently selected frame. */
13109 if (has_stack_frames ())
13111 prev_len
= result
.size ();
13112 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13114 if (result
.size () > prev_len
)
13115 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13118 /* Add all exceptions whose scope is global. */
13120 prev_len
= result
.size ();
13121 ada_add_global_exceptions (preg
, &result
);
13122 if (result
.size () > prev_len
)
13123 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13128 /* Return a vector of ada_exc_info.
13130 If REGEXP is NULL, all exceptions are included in the result.
13131 Otherwise, it should contain a valid regular expression,
13132 and only the exceptions whose names match that regular expression
13133 are included in the result.
13135 The exceptions are sorted in the following order:
13136 - Standard exceptions (defined by the Ada language), in
13137 alphabetical order;
13138 - Exceptions only visible from the current frame, in
13139 alphabetical order;
13140 - Exceptions whose scope is global, in alphabetical order. */
13142 std::vector
<ada_exc_info
>
13143 ada_exceptions_list (const char *regexp
)
13145 if (regexp
== NULL
)
13146 return ada_exceptions_list_1 (NULL
);
13148 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13149 return ada_exceptions_list_1 (®
);
13152 /* Implement the "info exceptions" command. */
13155 info_exceptions_command (const char *regexp
, int from_tty
)
13157 struct gdbarch
*gdbarch
= get_current_arch ();
13159 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13161 if (regexp
!= NULL
)
13163 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13165 printf_filtered (_("All defined Ada exceptions:\n"));
13167 for (const ada_exc_info
&info
: exceptions
)
13168 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13172 /* Information about operators given special treatment in functions
13174 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13176 #define ADA_OPERATORS \
13177 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13178 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13179 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13180 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13181 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13182 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13183 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13184 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13185 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13186 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13187 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13188 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13189 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13190 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13191 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13192 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13193 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13194 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13195 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13198 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13201 switch (exp
->elts
[pc
- 1].opcode
)
13204 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13207 #define OP_DEFN(op, len, args, binop) \
13208 case op: *oplenp = len; *argsp = args; break;
13214 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13219 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13224 /* Implementation of the exp_descriptor method operator_check. */
13227 ada_operator_check (struct expression
*exp
, int pos
,
13228 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13231 const union exp_element
*const elts
= exp
->elts
;
13232 struct type
*type
= NULL
;
13234 switch (elts
[pos
].opcode
)
13236 case UNOP_IN_RANGE
:
13238 type
= elts
[pos
+ 1].type
;
13242 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13245 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13247 if (type
&& TYPE_OBJFILE (type
)
13248 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13254 static const char *
13255 ada_op_name (enum exp_opcode opcode
)
13260 return op_name_standard (opcode
);
13262 #define OP_DEFN(op, len, args, binop) case op: return #op;
13267 return "OP_AGGREGATE";
13269 return "OP_CHOICES";
13275 /* As for operator_length, but assumes PC is pointing at the first
13276 element of the operator, and gives meaningful results only for the
13277 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13280 ada_forward_operator_length (struct expression
*exp
, int pc
,
13281 int *oplenp
, int *argsp
)
13283 switch (exp
->elts
[pc
].opcode
)
13286 *oplenp
= *argsp
= 0;
13289 #define OP_DEFN(op, len, args, binop) \
13290 case op: *oplenp = len; *argsp = args; break;
13296 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13301 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13307 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13309 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13317 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13319 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13324 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13328 /* Ada attributes ('Foo). */
13331 case OP_ATR_LENGTH
:
13335 case OP_ATR_MODULUS
:
13342 case UNOP_IN_RANGE
:
13344 /* XXX: gdb_sprint_host_address, type_sprint */
13345 fprintf_filtered (stream
, _("Type @"));
13346 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13347 fprintf_filtered (stream
, " (");
13348 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13349 fprintf_filtered (stream
, ")");
13351 case BINOP_IN_BOUNDS
:
13352 fprintf_filtered (stream
, " (%d)",
13353 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13355 case TERNOP_IN_RANGE
:
13360 case OP_DISCRETE_RANGE
:
13361 case OP_POSITIONAL
:
13368 char *name
= &exp
->elts
[elt
+ 2].string
;
13369 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13371 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13376 return dump_subexp_body_standard (exp
, stream
, elt
);
13380 for (i
= 0; i
< nargs
; i
+= 1)
13381 elt
= dump_subexp (exp
, stream
, elt
);
13386 /* The Ada extension of print_subexp (q.v.). */
13389 ada_print_subexp (struct expression
*exp
, int *pos
,
13390 struct ui_file
*stream
, enum precedence prec
)
13392 int oplen
, nargs
, i
;
13394 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13396 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13403 print_subexp_standard (exp
, pos
, stream
, prec
);
13407 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13410 case BINOP_IN_BOUNDS
:
13411 /* XXX: sprint_subexp */
13412 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13413 fputs_filtered (" in ", stream
);
13414 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13415 fputs_filtered ("'range", stream
);
13416 if (exp
->elts
[pc
+ 1].longconst
> 1)
13417 fprintf_filtered (stream
, "(%ld)",
13418 (long) exp
->elts
[pc
+ 1].longconst
);
13421 case TERNOP_IN_RANGE
:
13422 if (prec
>= PREC_EQUAL
)
13423 fputs_filtered ("(", stream
);
13424 /* XXX: sprint_subexp */
13425 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13426 fputs_filtered (" in ", stream
);
13427 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13428 fputs_filtered (" .. ", stream
);
13429 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13430 if (prec
>= PREC_EQUAL
)
13431 fputs_filtered (")", stream
);
13436 case OP_ATR_LENGTH
:
13440 case OP_ATR_MODULUS
:
13445 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13447 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13448 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13449 &type_print_raw_options
);
13453 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13454 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13459 for (tem
= 1; tem
< nargs
; tem
+= 1)
13461 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13462 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13464 fputs_filtered (")", stream
);
13469 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13470 fputs_filtered ("'(", stream
);
13471 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13472 fputs_filtered (")", stream
);
13475 case UNOP_IN_RANGE
:
13476 /* XXX: sprint_subexp */
13477 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13478 fputs_filtered (" in ", stream
);
13479 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13480 &type_print_raw_options
);
13483 case OP_DISCRETE_RANGE
:
13484 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13485 fputs_filtered ("..", stream
);
13486 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13490 fputs_filtered ("others => ", stream
);
13491 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13495 for (i
= 0; i
< nargs
-1; i
+= 1)
13498 fputs_filtered ("|", stream
);
13499 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13501 fputs_filtered (" => ", stream
);
13502 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13505 case OP_POSITIONAL
:
13506 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13510 fputs_filtered ("(", stream
);
13511 for (i
= 0; i
< nargs
; i
+= 1)
13514 fputs_filtered (", ", stream
);
13515 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13517 fputs_filtered (")", stream
);
13522 /* Table mapping opcodes into strings for printing operators
13523 and precedences of the operators. */
13525 static const struct op_print ada_op_print_tab
[] = {
13526 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13527 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13528 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13529 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13530 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13531 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13532 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13533 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13534 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13535 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13536 {">", BINOP_GTR
, PREC_ORDER
, 0},
13537 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13538 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13539 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13540 {"+", BINOP_ADD
, PREC_ADD
, 0},
13541 {"-", BINOP_SUB
, PREC_ADD
, 0},
13542 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13543 {"*", BINOP_MUL
, PREC_MUL
, 0},
13544 {"/", BINOP_DIV
, PREC_MUL
, 0},
13545 {"rem", BINOP_REM
, PREC_MUL
, 0},
13546 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13547 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13548 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13549 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13550 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13551 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13552 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13553 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13554 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13555 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13556 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13557 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13560 enum ada_primitive_types
{
13561 ada_primitive_type_int
,
13562 ada_primitive_type_long
,
13563 ada_primitive_type_short
,
13564 ada_primitive_type_char
,
13565 ada_primitive_type_float
,
13566 ada_primitive_type_double
,
13567 ada_primitive_type_void
,
13568 ada_primitive_type_long_long
,
13569 ada_primitive_type_long_double
,
13570 ada_primitive_type_natural
,
13571 ada_primitive_type_positive
,
13572 ada_primitive_type_system_address
,
13573 ada_primitive_type_storage_offset
,
13574 nr_ada_primitive_types
13578 /* Language vector */
13580 /* Not really used, but needed in the ada_language_defn. */
13583 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
13585 ada_emit_char (c
, type
, stream
, quoter
, 1);
13589 parse (struct parser_state
*ps
)
13591 warnings_issued
= 0;
13592 return ada_parse (ps
);
13595 static const struct exp_descriptor ada_exp_descriptor
= {
13597 ada_operator_length
,
13598 ada_operator_check
,
13600 ada_dump_subexp_body
,
13601 ada_evaluate_subexp
13604 /* symbol_name_matcher_ftype adapter for wild_match. */
13607 do_wild_match (const char *symbol_search_name
,
13608 const lookup_name_info
&lookup_name
,
13609 completion_match_result
*comp_match_res
)
13611 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13614 /* symbol_name_matcher_ftype adapter for full_match. */
13617 do_full_match (const char *symbol_search_name
,
13618 const lookup_name_info
&lookup_name
,
13619 completion_match_result
*comp_match_res
)
13621 return full_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13624 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13627 do_exact_match (const char *symbol_search_name
,
13628 const lookup_name_info
&lookup_name
,
13629 completion_match_result
*comp_match_res
)
13631 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13634 /* Build the Ada lookup name for LOOKUP_NAME. */
13636 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13638 gdb::string_view user_name
= lookup_name
.name ();
13640 if (user_name
[0] == '<')
13642 if (user_name
.back () == '>')
13644 = user_name
.substr (1, user_name
.size () - 2).to_string ();
13647 = user_name
.substr (1, user_name
.size () - 1).to_string ();
13648 m_encoded_p
= true;
13649 m_verbatim_p
= true;
13650 m_wild_match_p
= false;
13651 m_standard_p
= false;
13655 m_verbatim_p
= false;
13657 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13661 const char *folded
= ada_fold_name (user_name
);
13662 const char *encoded
= ada_encode_1 (folded
, false);
13663 if (encoded
!= NULL
)
13664 m_encoded_name
= encoded
;
13666 m_encoded_name
= user_name
.to_string ();
13669 m_encoded_name
= user_name
.to_string ();
13671 /* Handle the 'package Standard' special case. See description
13672 of m_standard_p. */
13673 if (startswith (m_encoded_name
.c_str (), "standard__"))
13675 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13676 m_standard_p
= true;
13679 m_standard_p
= false;
13681 /* If the name contains a ".", then the user is entering a fully
13682 qualified entity name, and the match must not be done in wild
13683 mode. Similarly, if the user wants to complete what looks
13684 like an encoded name, the match must not be done in wild
13685 mode. Also, in the standard__ special case always do
13686 non-wild matching. */
13688 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13691 && user_name
.find ('.') == std::string::npos
);
13695 /* symbol_name_matcher_ftype method for Ada. This only handles
13696 completion mode. */
13699 ada_symbol_name_matches (const char *symbol_search_name
,
13700 const lookup_name_info
&lookup_name
,
13701 completion_match_result
*comp_match_res
)
13703 return lookup_name
.ada ().matches (symbol_search_name
,
13704 lookup_name
.match_type (),
13708 /* A name matcher that matches the symbol name exactly, with
13712 literal_symbol_name_matcher (const char *symbol_search_name
,
13713 const lookup_name_info
&lookup_name
,
13714 completion_match_result
*comp_match_res
)
13716 gdb::string_view name_view
= lookup_name
.name ();
13718 if (lookup_name
.completion_mode ()
13719 ? (strncmp (symbol_search_name
, name_view
.data (),
13720 name_view
.size ()) == 0)
13721 : symbol_search_name
== name_view
)
13723 if (comp_match_res
!= NULL
)
13724 comp_match_res
->set_match (symbol_search_name
);
13731 /* Implement the "get_symbol_name_matcher" language_defn method for
13734 static symbol_name_matcher_ftype
*
13735 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13737 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13738 return literal_symbol_name_matcher
;
13740 if (lookup_name
.completion_mode ())
13741 return ada_symbol_name_matches
;
13744 if (lookup_name
.ada ().wild_match_p ())
13745 return do_wild_match
;
13746 else if (lookup_name
.ada ().verbatim_p ())
13747 return do_exact_match
;
13749 return do_full_match
;
13753 static const char *ada_extensions
[] =
13755 ".adb", ".ads", ".a", ".ada", ".dg", NULL
13758 /* Constant data that describes the Ada language. */
13760 extern const struct language_data ada_language_data
=
13762 "ada", /* Language name */
13766 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
13767 that's not quite what this means. */
13769 macro_expansion_no
,
13771 &ada_exp_descriptor
,
13774 ada_printchar
, /* Print a character constant */
13775 ada_printstr
, /* Function to print string constant */
13776 emit_char
, /* Function to print single char (not used) */
13777 ada_print_typedef
, /* Print a typedef using appropriate syntax */
13778 ada_value_print_inner
, /* la_value_print_inner */
13779 ada_value_print
, /* Print a top-level value */
13780 NULL
, /* name_of_this */
13781 true, /* la_store_sym_names_in_linkage_form_p */
13782 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
13783 ada_op_print_tab
, /* expression operators for printing */
13784 0, /* c-style arrays */
13785 1, /* String lower bound */
13786 ada_watch_location_expression
,
13788 ada_is_string_type
,
13789 "(...)" /* la_struct_too_deep_ellipsis */
13792 /* Class representing the Ada language. */
13794 class ada_language
: public language_defn
13798 : language_defn (language_ada
, ada_language_data
)
13801 /* Print an array element index using the Ada syntax. */
13803 void print_array_index (struct type
*index_type
,
13805 struct ui_file
*stream
,
13806 const value_print_options
*options
) const override
13808 struct value
*index_value
= val_atr (index_type
, index
);
13810 LA_VALUE_PRINT (index_value
, stream
, options
);
13811 fprintf_filtered (stream
, " => ");
13814 /* Implement the "read_var_value" language_defn method for Ada. */
13816 struct value
*read_var_value (struct symbol
*var
,
13817 const struct block
*var_block
,
13818 struct frame_info
*frame
) const override
13820 /* The only case where default_read_var_value is not sufficient
13821 is when VAR is a renaming... */
13822 if (frame
!= nullptr)
13824 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13825 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13826 return ada_read_renaming_var_value (var
, frame_block
);
13829 /* This is a typical case where we expect the default_read_var_value
13830 function to work. */
13831 return language_defn::read_var_value (var
, var_block
, frame
);
13834 /* See language.h. */
13835 void language_arch_info (struct gdbarch
*gdbarch
,
13836 struct language_arch_info
*lai
) const override
13838 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13840 lai
->primitive_type_vector
13841 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
13844 lai
->primitive_type_vector
[ada_primitive_type_int
]
13845 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13847 lai
->primitive_type_vector
[ada_primitive_type_long
]
13848 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13849 0, "long_integer");
13850 lai
->primitive_type_vector
[ada_primitive_type_short
]
13851 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13852 0, "short_integer");
13853 lai
->string_char_type
13854 = lai
->primitive_type_vector
[ada_primitive_type_char
]
13855 = arch_character_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
13856 lai
->primitive_type_vector
[ada_primitive_type_float
]
13857 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13858 "float", gdbarch_float_format (gdbarch
));
13859 lai
->primitive_type_vector
[ada_primitive_type_double
]
13860 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13861 "long_float", gdbarch_double_format (gdbarch
));
13862 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
13863 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13864 0, "long_long_integer");
13865 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
13866 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13867 "long_long_float", gdbarch_long_double_format (gdbarch
));
13868 lai
->primitive_type_vector
[ada_primitive_type_natural
]
13869 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13871 lai
->primitive_type_vector
[ada_primitive_type_positive
]
13872 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13874 lai
->primitive_type_vector
[ada_primitive_type_void
]
13875 = builtin
->builtin_void
;
13877 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
13878 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
13880 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
13881 ->set_name ("system__address");
13883 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
13884 type. This is a signed integral type whose size is the same as
13885 the size of addresses. */
13887 unsigned int addr_length
= TYPE_LENGTH
13888 (lai
->primitive_type_vector
[ada_primitive_type_system_address
]);
13890 lai
->primitive_type_vector
[ada_primitive_type_storage_offset
]
13891 = arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
13895 lai
->bool_type_symbol
= NULL
;
13896 lai
->bool_type_default
= builtin
->builtin_bool
;
13899 /* See language.h. */
13901 bool iterate_over_symbols
13902 (const struct block
*block
, const lookup_name_info
&name
,
13903 domain_enum domain
,
13904 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
13906 std::vector
<struct block_symbol
> results
;
13908 ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
13909 for (block_symbol
&sym
: results
)
13911 if (!callback (&sym
))
13918 /* See language.h. */
13919 bool sniff_from_mangled_name (const char *mangled
,
13920 char **out
) const override
13922 std::string demangled
= ada_decode (mangled
);
13926 if (demangled
!= mangled
&& demangled
[0] != '<')
13928 /* Set the gsymbol language to Ada, but still return 0.
13929 Two reasons for that:
13931 1. For Ada, we prefer computing the symbol's decoded name
13932 on the fly rather than pre-compute it, in order to save
13933 memory (Ada projects are typically very large).
13935 2. There are some areas in the definition of the GNAT
13936 encoding where, with a bit of bad luck, we might be able
13937 to decode a non-Ada symbol, generating an incorrect
13938 demangled name (Eg: names ending with "TB" for instance
13939 are identified as task bodies and so stripped from
13940 the decoded name returned).
13942 Returning true, here, but not setting *DEMANGLED, helps us get
13943 a little bit of the best of both worlds. Because we're last,
13944 we should not affect any of the other languages that were
13945 able to demangle the symbol before us; we get to correctly
13946 tag Ada symbols as such; and even if we incorrectly tagged a
13947 non-Ada symbol, which should be rare, any routing through the
13948 Ada language should be transparent (Ada tries to behave much
13949 like C/C++ with non-Ada symbols). */
13956 /* See language.h. */
13958 char *demangle (const char *mangled
, int options
) const override
13960 return ada_la_decode (mangled
, options
);
13963 /* See language.h. */
13965 void print_type (struct type
*type
, const char *varstring
,
13966 struct ui_file
*stream
, int show
, int level
,
13967 const struct type_print_options
*flags
) const override
13969 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
13972 /* See language.h. */
13974 const char *word_break_characters (void) const override
13976 return ada_completer_word_break_characters
;
13979 /* See language.h. */
13981 void collect_symbol_completion_matches (completion_tracker
&tracker
,
13982 complete_symbol_mode mode
,
13983 symbol_name_match_type name_match_type
,
13984 const char *text
, const char *word
,
13985 enum type_code code
) const override
13987 struct symbol
*sym
;
13988 const struct block
*b
, *surrounding_static_block
= 0;
13989 struct block_iterator iter
;
13991 gdb_assert (code
== TYPE_CODE_UNDEF
);
13993 lookup_name_info
lookup_name (text
, name_match_type
, true);
13995 /* First, look at the partial symtab symbols. */
13996 expand_symtabs_matching (NULL
,
14002 /* At this point scan through the misc symbol vectors and add each
14003 symbol you find to the list. Eventually we want to ignore
14004 anything that isn't a text symbol (everything else will be
14005 handled by the psymtab code above). */
14007 for (objfile
*objfile
: current_program_space
->objfiles ())
14009 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
14013 if (completion_skip_symbol (mode
, msymbol
))
14016 language symbol_language
= msymbol
->language ();
14018 /* Ada minimal symbols won't have their language set to Ada. If
14019 we let completion_list_add_name compare using the
14020 default/C-like matcher, then when completing e.g., symbols in a
14021 package named "pck", we'd match internal Ada symbols like
14022 "pckS", which are invalid in an Ada expression, unless you wrap
14023 them in '<' '>' to request a verbatim match.
14025 Unfortunately, some Ada encoded names successfully demangle as
14026 C++ symbols (using an old mangling scheme), such as "name__2Xn"
14027 -> "Xn::name(void)" and thus some Ada minimal symbols end up
14028 with the wrong language set. Paper over that issue here. */
14029 if (symbol_language
== language_auto
14030 || symbol_language
== language_cplus
)
14031 symbol_language
= language_ada
;
14033 completion_list_add_name (tracker
,
14035 msymbol
->linkage_name (),
14036 lookup_name
, text
, word
);
14040 /* Search upwards from currently selected frame (so that we can
14041 complete on local vars. */
14043 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
14045 if (!BLOCK_SUPERBLOCK (b
))
14046 surrounding_static_block
= b
; /* For elmin of dups */
14048 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14050 if (completion_skip_symbol (mode
, sym
))
14053 completion_list_add_name (tracker
,
14055 sym
->linkage_name (),
14056 lookup_name
, text
, word
);
14060 /* Go through the symtabs and check the externs and statics for
14061 symbols which match. */
14063 for (objfile
*objfile
: current_program_space
->objfiles ())
14065 for (compunit_symtab
*s
: objfile
->compunits ())
14068 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
14069 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14071 if (completion_skip_symbol (mode
, sym
))
14074 completion_list_add_name (tracker
,
14076 sym
->linkage_name (),
14077 lookup_name
, text
, word
);
14082 for (objfile
*objfile
: current_program_space
->objfiles ())
14084 for (compunit_symtab
*s
: objfile
->compunits ())
14087 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
14088 /* Don't do this block twice. */
14089 if (b
== surrounding_static_block
)
14091 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
14093 if (completion_skip_symbol (mode
, sym
))
14096 completion_list_add_name (tracker
,
14098 sym
->linkage_name (),
14099 lookup_name
, text
, word
);
14106 /* See language.h. */
14108 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14109 (const lookup_name_info
&lookup_name
) const override
14111 return ada_get_symbol_name_matcher (lookup_name
);
14115 /* Single instance of the Ada language class. */
14117 static ada_language ada_language_defn
;
14119 /* Command-list for the "set/show ada" prefix command. */
14120 static struct cmd_list_element
*set_ada_list
;
14121 static struct cmd_list_element
*show_ada_list
;
14124 initialize_ada_catchpoint_ops (void)
14126 struct breakpoint_ops
*ops
;
14128 initialize_breakpoint_ops ();
14130 ops
= &catch_exception_breakpoint_ops
;
14131 *ops
= bkpt_breakpoint_ops
;
14132 ops
->allocate_location
= allocate_location_exception
;
14133 ops
->re_set
= re_set_exception
;
14134 ops
->check_status
= check_status_exception
;
14135 ops
->print_it
= print_it_exception
;
14136 ops
->print_one
= print_one_exception
;
14137 ops
->print_mention
= print_mention_exception
;
14138 ops
->print_recreate
= print_recreate_exception
;
14140 ops
= &catch_exception_unhandled_breakpoint_ops
;
14141 *ops
= bkpt_breakpoint_ops
;
14142 ops
->allocate_location
= allocate_location_exception
;
14143 ops
->re_set
= re_set_exception
;
14144 ops
->check_status
= check_status_exception
;
14145 ops
->print_it
= print_it_exception
;
14146 ops
->print_one
= print_one_exception
;
14147 ops
->print_mention
= print_mention_exception
;
14148 ops
->print_recreate
= print_recreate_exception
;
14150 ops
= &catch_assert_breakpoint_ops
;
14151 *ops
= bkpt_breakpoint_ops
;
14152 ops
->allocate_location
= allocate_location_exception
;
14153 ops
->re_set
= re_set_exception
;
14154 ops
->check_status
= check_status_exception
;
14155 ops
->print_it
= print_it_exception
;
14156 ops
->print_one
= print_one_exception
;
14157 ops
->print_mention
= print_mention_exception
;
14158 ops
->print_recreate
= print_recreate_exception
;
14160 ops
= &catch_handlers_breakpoint_ops
;
14161 *ops
= bkpt_breakpoint_ops
;
14162 ops
->allocate_location
= allocate_location_exception
;
14163 ops
->re_set
= re_set_exception
;
14164 ops
->check_status
= check_status_exception
;
14165 ops
->print_it
= print_it_exception
;
14166 ops
->print_one
= print_one_exception
;
14167 ops
->print_mention
= print_mention_exception
;
14168 ops
->print_recreate
= print_recreate_exception
;
14171 /* This module's 'new_objfile' observer. */
14174 ada_new_objfile_observer (struct objfile
*objfile
)
14176 ada_clear_symbol_cache ();
14179 /* This module's 'free_objfile' observer. */
14182 ada_free_objfile_observer (struct objfile
*objfile
)
14184 ada_clear_symbol_cache ();
14187 void _initialize_ada_language ();
14189 _initialize_ada_language ()
14191 initialize_ada_catchpoint_ops ();
14193 add_basic_prefix_cmd ("ada", no_class
,
14194 _("Prefix command for changing Ada-specific settings."),
14195 &set_ada_list
, "set ada ", 0, &setlist
);
14197 add_show_prefix_cmd ("ada", no_class
,
14198 _("Generic command for showing Ada-specific settings."),
14199 &show_ada_list
, "show ada ", 0, &showlist
);
14201 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14202 &trust_pad_over_xvs
, _("\
14203 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14204 Show whether an optimization trusting PAD types over XVS types is activated."),
14206 This is related to the encoding used by the GNAT compiler. The debugger\n\
14207 should normally trust the contents of PAD types, but certain older versions\n\
14208 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14209 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14210 work around this bug. It is always safe to turn this option \"off\", but\n\
14211 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14212 this option to \"off\" unless necessary."),
14213 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14215 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14216 &print_signatures
, _("\
14217 Enable or disable the output of formal and return types for functions in the \
14218 overloads selection menu."), _("\
14219 Show whether the output of formal and return types for functions in the \
14220 overloads selection menu is activated."),
14221 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14223 add_catch_command ("exception", _("\
14224 Catch Ada exceptions, when raised.\n\
14225 Usage: catch exception [ARG] [if CONDITION]\n\
14226 Without any argument, stop when any Ada exception is raised.\n\
14227 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14228 being raised does not have a handler (and will therefore lead to the task's\n\
14230 Otherwise, the catchpoint only stops when the name of the exception being\n\
14231 raised is the same as ARG.\n\
14232 CONDITION is a boolean expression that is evaluated to see whether the\n\
14233 exception should cause a stop."),
14234 catch_ada_exception_command
,
14235 catch_ada_completer
,
14239 add_catch_command ("handlers", _("\
14240 Catch Ada exceptions, when handled.\n\
14241 Usage: catch handlers [ARG] [if CONDITION]\n\
14242 Without any argument, stop when any Ada exception is handled.\n\
14243 With an argument, catch only exceptions with the given name.\n\
14244 CONDITION is a boolean expression that is evaluated to see whether the\n\
14245 exception should cause a stop."),
14246 catch_ada_handlers_command
,
14247 catch_ada_completer
,
14250 add_catch_command ("assert", _("\
14251 Catch failed Ada assertions, when raised.\n\
14252 Usage: catch assert [if CONDITION]\n\
14253 CONDITION is a boolean expression that is evaluated to see whether the\n\
14254 exception should cause a stop."),
14255 catch_assert_command
,
14260 varsize_limit
= 65536;
14261 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14262 &varsize_limit
, _("\
14263 Set the maximum number of bytes allowed in a variable-size object."), _("\
14264 Show the maximum number of bytes allowed in a variable-size object."), _("\
14265 Attempts to access an object whose size is not a compile-time constant\n\
14266 and exceeds this limit will cause an error."),
14267 NULL
, NULL
, &setlist
, &showlist
);
14269 add_info ("exceptions", info_exceptions_command
,
14271 List all Ada exception names.\n\
14272 Usage: info exceptions [REGEXP]\n\
14273 If a regular expression is passed as an argument, only those matching\n\
14274 the regular expression are listed."));
14276 add_basic_prefix_cmd ("ada", class_maintenance
,
14277 _("Set Ada maintenance-related variables."),
14278 &maint_set_ada_cmdlist
, "maintenance set ada ",
14279 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14281 add_show_prefix_cmd ("ada", class_maintenance
,
14282 _("Show Ada maintenance-related variables."),
14283 &maint_show_ada_cmdlist
, "maintenance show ada ",
14284 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14286 add_setshow_boolean_cmd
14287 ("ignore-descriptive-types", class_maintenance
,
14288 &ada_ignore_descriptive_types_p
,
14289 _("Set whether descriptive types generated by GNAT should be ignored."),
14290 _("Show whether descriptive types generated by GNAT should be ignored."),
14292 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14293 DWARF attribute."),
14294 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14296 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14297 NULL
, xcalloc
, xfree
);
14299 /* The ada-lang observers. */
14300 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14301 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14302 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);