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 ());
6275 /* Add the list of possible symbol names completing TEXT to TRACKER.
6276 WORD is the entire command on which completion is made. */
6279 ada_collect_symbol_completion_matches (completion_tracker
&tracker
,
6280 complete_symbol_mode mode
,
6281 symbol_name_match_type name_match_type
,
6282 const char *text
, const char *word
,
6283 enum type_code code
)
6286 const struct block
*b
, *surrounding_static_block
= 0;
6287 struct block_iterator iter
;
6289 gdb_assert (code
== TYPE_CODE_UNDEF
);
6291 lookup_name_info
lookup_name (text
, name_match_type
, true);
6293 /* First, look at the partial symtab symbols. */
6294 expand_symtabs_matching (NULL
,
6300 /* At this point scan through the misc symbol vectors and add each
6301 symbol you find to the list. Eventually we want to ignore
6302 anything that isn't a text symbol (everything else will be
6303 handled by the psymtab code above). */
6305 for (objfile
*objfile
: current_program_space
->objfiles ())
6307 for (minimal_symbol
*msymbol
: objfile
->msymbols ())
6311 if (completion_skip_symbol (mode
, msymbol
))
6314 language symbol_language
= msymbol
->language ();
6316 /* Ada minimal symbols won't have their language set to Ada. If
6317 we let completion_list_add_name compare using the
6318 default/C-like matcher, then when completing e.g., symbols in a
6319 package named "pck", we'd match internal Ada symbols like
6320 "pckS", which are invalid in an Ada expression, unless you wrap
6321 them in '<' '>' to request a verbatim match.
6323 Unfortunately, some Ada encoded names successfully demangle as
6324 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6325 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6326 with the wrong language set. Paper over that issue here. */
6327 if (symbol_language
== language_auto
6328 || symbol_language
== language_cplus
)
6329 symbol_language
= language_ada
;
6331 completion_list_add_name (tracker
,
6333 msymbol
->linkage_name (),
6334 lookup_name
, text
, word
);
6338 /* Search upwards from currently selected frame (so that we can
6339 complete on local vars. */
6341 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
6343 if (!BLOCK_SUPERBLOCK (b
))
6344 surrounding_static_block
= b
; /* For elmin of dups */
6346 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6348 if (completion_skip_symbol (mode
, sym
))
6351 completion_list_add_name (tracker
,
6353 sym
->linkage_name (),
6354 lookup_name
, text
, word
);
6358 /* Go through the symtabs and check the externs and statics for
6359 symbols which match. */
6361 for (objfile
*objfile
: current_program_space
->objfiles ())
6363 for (compunit_symtab
*s
: objfile
->compunits ())
6366 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), GLOBAL_BLOCK
);
6367 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6369 if (completion_skip_symbol (mode
, sym
))
6372 completion_list_add_name (tracker
,
6374 sym
->linkage_name (),
6375 lookup_name
, text
, word
);
6380 for (objfile
*objfile
: current_program_space
->objfiles ())
6382 for (compunit_symtab
*s
: objfile
->compunits ())
6385 b
= BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s
), STATIC_BLOCK
);
6386 /* Don't do this block twice. */
6387 if (b
== surrounding_static_block
)
6389 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6391 if (completion_skip_symbol (mode
, sym
))
6394 completion_list_add_name (tracker
,
6396 sym
->linkage_name (),
6397 lookup_name
, text
, word
);
6405 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6406 for tagged types. */
6409 ada_is_dispatch_table_ptr_type (struct type
*type
)
6413 if (type
->code () != TYPE_CODE_PTR
)
6416 name
= TYPE_TARGET_TYPE (type
)->name ();
6420 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6423 /* Return non-zero if TYPE is an interface tag. */
6426 ada_is_interface_tag (struct type
*type
)
6428 const char *name
= type
->name ();
6433 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6436 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6437 to be invisible to users. */
6440 ada_is_ignored_field (struct type
*type
, int field_num
)
6442 if (field_num
< 0 || field_num
> type
->num_fields ())
6445 /* Check the name of that field. */
6447 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6449 /* Anonymous field names should not be printed.
6450 brobecker/2007-02-20: I don't think this can actually happen
6451 but we don't want to print the value of anonymous fields anyway. */
6455 /* Normally, fields whose name start with an underscore ("_")
6456 are fields that have been internally generated by the compiler,
6457 and thus should not be printed. The "_parent" field is special,
6458 however: This is a field internally generated by the compiler
6459 for tagged types, and it contains the components inherited from
6460 the parent type. This field should not be printed as is, but
6461 should not be ignored either. */
6462 if (name
[0] == '_' && !startswith (name
, "_parent"))
6466 /* If this is the dispatch table of a tagged type or an interface tag,
6468 if (ada_is_tagged_type (type
, 1)
6469 && (ada_is_dispatch_table_ptr_type (type
->field (field_num
).type ())
6470 || ada_is_interface_tag (type
->field (field_num
).type ())))
6473 /* Not a special field, so it should not be ignored. */
6477 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6478 pointer or reference type whose ultimate target has a tag field. */
6481 ada_is_tagged_type (struct type
*type
, int refok
)
6483 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1) != NULL
);
6486 /* True iff TYPE represents the type of X'Tag */
6489 ada_is_tag_type (struct type
*type
)
6491 type
= ada_check_typedef (type
);
6493 if (type
== NULL
|| type
->code () != TYPE_CODE_PTR
)
6497 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6499 return (name
!= NULL
6500 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6504 /* The type of the tag on VAL. */
6506 static struct type
*
6507 ada_tag_type (struct value
*val
)
6509 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0);
6512 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6513 retired at Ada 05). */
6516 is_ada95_tag (struct value
*tag
)
6518 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6521 /* The value of the tag on VAL. */
6523 static struct value
*
6524 ada_value_tag (struct value
*val
)
6526 return ada_value_struct_elt (val
, "_tag", 0);
6529 /* The value of the tag on the object of type TYPE whose contents are
6530 saved at VALADDR, if it is non-null, or is at memory address
6533 static struct value
*
6534 value_tag_from_contents_and_address (struct type
*type
,
6535 const gdb_byte
*valaddr
,
6538 int tag_byte_offset
;
6539 struct type
*tag_type
;
6541 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6544 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6546 : valaddr
+ tag_byte_offset
);
6547 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6549 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6554 static struct type
*
6555 type_from_tag (struct value
*tag
)
6557 gdb::unique_xmalloc_ptr
<char> type_name
= ada_tag_name (tag
);
6559 if (type_name
!= NULL
)
6560 return ada_find_any_type (ada_encode (type_name
.get ()));
6564 /* Given a value OBJ of a tagged type, return a value of this
6565 type at the base address of the object. The base address, as
6566 defined in Ada.Tags, it is the address of the primary tag of
6567 the object, and therefore where the field values of its full
6568 view can be fetched. */
6571 ada_tag_value_at_base_address (struct value
*obj
)
6574 LONGEST offset_to_top
= 0;
6575 struct type
*ptr_type
, *obj_type
;
6577 CORE_ADDR base_address
;
6579 obj_type
= value_type (obj
);
6581 /* It is the responsability of the caller to deref pointers. */
6583 if (obj_type
->code () == TYPE_CODE_PTR
|| obj_type
->code () == TYPE_CODE_REF
)
6586 tag
= ada_value_tag (obj
);
6590 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6592 if (is_ada95_tag (tag
))
6595 ptr_type
= language_lookup_primitive_type
6596 (language_def (language_ada
), target_gdbarch(), "storage_offset");
6597 ptr_type
= lookup_pointer_type (ptr_type
);
6598 val
= value_cast (ptr_type
, tag
);
6602 /* It is perfectly possible that an exception be raised while
6603 trying to determine the base address, just like for the tag;
6604 see ada_tag_name for more details. We do not print the error
6605 message for the same reason. */
6609 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6612 catch (const gdb_exception_error
&e
)
6617 /* If offset is null, nothing to do. */
6619 if (offset_to_top
== 0)
6622 /* -1 is a special case in Ada.Tags; however, what should be done
6623 is not quite clear from the documentation. So do nothing for
6626 if (offset_to_top
== -1)
6629 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6630 from the base address. This was however incompatible with
6631 C++ dispatch table: C++ uses a *negative* value to *add*
6632 to the base address. Ada's convention has therefore been
6633 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6634 use the same convention. Here, we support both cases by
6635 checking the sign of OFFSET_TO_TOP. */
6637 if (offset_to_top
> 0)
6638 offset_to_top
= -offset_to_top
;
6640 base_address
= value_address (obj
) + offset_to_top
;
6641 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6643 /* Make sure that we have a proper tag at the new address.
6644 Otherwise, offset_to_top is bogus (which can happen when
6645 the object is not initialized yet). */
6650 obj_type
= type_from_tag (tag
);
6655 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6658 /* Return the "ada__tags__type_specific_data" type. */
6660 static struct type
*
6661 ada_get_tsd_type (struct inferior
*inf
)
6663 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6665 if (data
->tsd_type
== 0)
6666 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6667 return data
->tsd_type
;
6670 /* Return the TSD (type-specific data) associated to the given TAG.
6671 TAG is assumed to be the tag of a tagged-type entity.
6673 May return NULL if we are unable to get the TSD. */
6675 static struct value
*
6676 ada_get_tsd_from_tag (struct value
*tag
)
6681 /* First option: The TSD is simply stored as a field of our TAG.
6682 Only older versions of GNAT would use this format, but we have
6683 to test it first, because there are no visible markers for
6684 the current approach except the absence of that field. */
6686 val
= ada_value_struct_elt (tag
, "tsd", 1);
6690 /* Try the second representation for the dispatch table (in which
6691 there is no explicit 'tsd' field in the referent of the tag pointer,
6692 and instead the tsd pointer is stored just before the dispatch
6695 type
= ada_get_tsd_type (current_inferior());
6698 type
= lookup_pointer_type (lookup_pointer_type (type
));
6699 val
= value_cast (type
, tag
);
6702 return value_ind (value_ptradd (val
, -1));
6705 /* Given the TSD of a tag (type-specific data), return a string
6706 containing the name of the associated type.
6708 May return NULL if we are unable to determine the tag name. */
6710 static gdb::unique_xmalloc_ptr
<char>
6711 ada_tag_name_from_tsd (struct value
*tsd
)
6716 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6719 gdb::unique_xmalloc_ptr
<char> buffer
6720 = target_read_string (value_as_address (val
), INT_MAX
);
6721 if (buffer
== nullptr)
6724 for (p
= buffer
.get (); *p
!= '\0'; ++p
)
6733 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6736 Return NULL if the TAG is not an Ada tag, or if we were unable to
6737 determine the name of that tag. */
6739 gdb::unique_xmalloc_ptr
<char>
6740 ada_tag_name (struct value
*tag
)
6742 gdb::unique_xmalloc_ptr
<char> name
;
6744 if (!ada_is_tag_type (value_type (tag
)))
6747 /* It is perfectly possible that an exception be raised while trying
6748 to determine the TAG's name, even under normal circumstances:
6749 The associated variable may be uninitialized or corrupted, for
6750 instance. We do not let any exception propagate past this point.
6751 instead we return NULL.
6753 We also do not print the error message either (which often is very
6754 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6755 the caller print a more meaningful message if necessary. */
6758 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6761 name
= ada_tag_name_from_tsd (tsd
);
6763 catch (const gdb_exception_error
&e
)
6770 /* The parent type of TYPE, or NULL if none. */
6773 ada_parent_type (struct type
*type
)
6777 type
= ada_check_typedef (type
);
6779 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
6782 for (i
= 0; i
< type
->num_fields (); i
+= 1)
6783 if (ada_is_parent_field (type
, i
))
6785 struct type
*parent_type
= type
->field (i
).type ();
6787 /* If the _parent field is a pointer, then dereference it. */
6788 if (parent_type
->code () == TYPE_CODE_PTR
)
6789 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6790 /* If there is a parallel XVS type, get the actual base type. */
6791 parent_type
= ada_get_base_type (parent_type
);
6793 return ada_check_typedef (parent_type
);
6799 /* True iff field number FIELD_NUM of structure type TYPE contains the
6800 parent-type (inherited) fields of a derived type. Assumes TYPE is
6801 a structure type with at least FIELD_NUM+1 fields. */
6804 ada_is_parent_field (struct type
*type
, int field_num
)
6806 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6808 return (name
!= NULL
6809 && (startswith (name
, "PARENT")
6810 || startswith (name
, "_parent")));
6813 /* True iff field number FIELD_NUM of structure type TYPE is a
6814 transparent wrapper field (which should be silently traversed when doing
6815 field selection and flattened when printing). Assumes TYPE is a
6816 structure type with at least FIELD_NUM+1 fields. Such fields are always
6820 ada_is_wrapper_field (struct type
*type
, int field_num
)
6822 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6824 if (name
!= NULL
&& strcmp (name
, "RETVAL") == 0)
6826 /* This happens in functions with "out" or "in out" parameters
6827 which are passed by copy. For such functions, GNAT describes
6828 the function's return type as being a struct where the return
6829 value is in a field called RETVAL, and where the other "out"
6830 or "in out" parameters are fields of that struct. This is not
6835 return (name
!= NULL
6836 && (startswith (name
, "PARENT")
6837 || strcmp (name
, "REP") == 0
6838 || startswith (name
, "_parent")
6839 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6842 /* True iff field number FIELD_NUM of structure or union type TYPE
6843 is a variant wrapper. Assumes TYPE is a structure type with at least
6844 FIELD_NUM+1 fields. */
6847 ada_is_variant_part (struct type
*type
, int field_num
)
6849 /* Only Ada types are eligible. */
6850 if (!ADA_TYPE_P (type
))
6853 struct type
*field_type
= type
->field (field_num
).type ();
6855 return (field_type
->code () == TYPE_CODE_UNION
6856 || (is_dynamic_field (type
, field_num
)
6857 && (TYPE_TARGET_TYPE (field_type
)->code ()
6858 == TYPE_CODE_UNION
)));
6861 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6862 whose discriminants are contained in the record type OUTER_TYPE,
6863 returns the type of the controlling discriminant for the variant.
6864 May return NULL if the type could not be found. */
6867 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6869 const char *name
= ada_variant_discrim_name (var_type
);
6871 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1);
6874 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6875 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6876 represents a 'when others' clause; otherwise 0. */
6879 ada_is_others_clause (struct type
*type
, int field_num
)
6881 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6883 return (name
!= NULL
&& name
[0] == 'O');
6886 /* Assuming that TYPE0 is the type of the variant part of a record,
6887 returns the name of the discriminant controlling the variant.
6888 The value is valid until the next call to ada_variant_discrim_name. */
6891 ada_variant_discrim_name (struct type
*type0
)
6893 static char *result
= NULL
;
6894 static size_t result_len
= 0;
6897 const char *discrim_end
;
6898 const char *discrim_start
;
6900 if (type0
->code () == TYPE_CODE_PTR
)
6901 type
= TYPE_TARGET_TYPE (type0
);
6905 name
= ada_type_name (type
);
6907 if (name
== NULL
|| name
[0] == '\000')
6910 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6913 if (startswith (discrim_end
, "___XVN"))
6916 if (discrim_end
== name
)
6919 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6922 if (discrim_start
== name
+ 1)
6924 if ((discrim_start
> name
+ 3
6925 && startswith (discrim_start
- 3, "___"))
6926 || discrim_start
[-1] == '.')
6930 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6931 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6932 result
[discrim_end
- discrim_start
] = '\0';
6936 /* Scan STR for a subtype-encoded number, beginning at position K.
6937 Put the position of the character just past the number scanned in
6938 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6939 Return 1 if there was a valid number at the given position, and 0
6940 otherwise. A "subtype-encoded" number consists of the absolute value
6941 in decimal, followed by the letter 'm' to indicate a negative number.
6942 Assumes 0m does not occur. */
6945 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6949 if (!isdigit (str
[k
]))
6952 /* Do it the hard way so as not to make any assumption about
6953 the relationship of unsigned long (%lu scan format code) and
6956 while (isdigit (str
[k
]))
6958 RU
= RU
* 10 + (str
[k
] - '0');
6965 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6971 /* NOTE on the above: Technically, C does not say what the results of
6972 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6973 number representable as a LONGEST (although either would probably work
6974 in most implementations). When RU>0, the locution in the then branch
6975 above is always equivalent to the negative of RU. */
6982 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6983 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6984 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6987 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6989 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
7003 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
7013 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
7014 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
7016 if (val
>= L
&& val
<= U
)
7028 /* FIXME: Lots of redundancy below. Try to consolidate. */
7030 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7031 ARG_TYPE, extract and return the value of one of its (non-static)
7032 fields. FIELDNO says which field. Differs from value_primitive_field
7033 only in that it can handle packed values of arbitrary type. */
7036 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
7037 struct type
*arg_type
)
7041 arg_type
= ada_check_typedef (arg_type
);
7042 type
= arg_type
->field (fieldno
).type ();
7044 /* Handle packed fields. It might be that the field is not packed
7045 relative to its containing structure, but the structure itself is
7046 packed; in this case we must take the bit-field path. */
7047 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0 || value_bitpos (arg1
) != 0)
7049 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
7050 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
7052 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
7053 offset
+ bit_pos
/ 8,
7054 bit_pos
% 8, bit_size
, type
);
7057 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
7060 /* Find field with name NAME in object of type TYPE. If found,
7061 set the following for each argument that is non-null:
7062 - *FIELD_TYPE_P to the field's type;
7063 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7064 an object of that type;
7065 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7066 - *BIT_SIZE_P to its size in bits if the field is packed, and
7068 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7069 fields up to but not including the desired field, or by the total
7070 number of fields if not found. A NULL value of NAME never
7071 matches; the function just counts visible fields in this case.
7073 Notice that we need to handle when a tagged record hierarchy
7074 has some components with the same name, like in this scenario:
7076 type Top_T is tagged record
7082 type Middle_T is new Top.Top_T with record
7083 N : Character := 'a';
7087 type Bottom_T is new Middle.Middle_T with record
7089 C : Character := '5';
7091 A : Character := 'J';
7094 Let's say we now have a variable declared and initialized as follow:
7096 TC : Top_A := new Bottom_T;
7098 And then we use this variable to call this function
7100 procedure Assign (Obj: in out Top_T; TV : Integer);
7104 Assign (Top_T (B), 12);
7106 Now, we're in the debugger, and we're inside that procedure
7107 then and we want to print the value of obj.c:
7109 Usually, the tagged record or one of the parent type owns the
7110 component to print and there's no issue but in this particular
7111 case, what does it mean to ask for Obj.C? Since the actual
7112 type for object is type Bottom_T, it could mean two things: type
7113 component C from the Middle_T view, but also component C from
7114 Bottom_T. So in that "undefined" case, when the component is
7115 not found in the non-resolved type (which includes all the
7116 components of the parent type), then resolve it and see if we
7117 get better luck once expanded.
7119 In the case of homonyms in the derived tagged type, we don't
7120 guaranty anything, and pick the one that's easiest for us
7123 Returns 1 if found, 0 otherwise. */
7126 find_struct_field (const char *name
, struct type
*type
, int offset
,
7127 struct type
**field_type_p
,
7128 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
7132 int parent_offset
= -1;
7134 type
= ada_check_typedef (type
);
7136 if (field_type_p
!= NULL
)
7137 *field_type_p
= NULL
;
7138 if (byte_offset_p
!= NULL
)
7140 if (bit_offset_p
!= NULL
)
7142 if (bit_size_p
!= NULL
)
7145 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7147 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
7148 int fld_offset
= offset
+ bit_pos
/ 8;
7149 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7151 if (t_field_name
== NULL
)
7154 else if (ada_is_parent_field (type
, i
))
7156 /* This is a field pointing us to the parent type of a tagged
7157 type. As hinted in this function's documentation, we give
7158 preference to fields in the current record first, so what
7159 we do here is just record the index of this field before
7160 we skip it. If it turns out we couldn't find our field
7161 in the current record, then we'll get back to it and search
7162 inside it whether the field might exist in the parent. */
7168 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
7170 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7172 if (field_type_p
!= NULL
)
7173 *field_type_p
= type
->field (i
).type ();
7174 if (byte_offset_p
!= NULL
)
7175 *byte_offset_p
= fld_offset
;
7176 if (bit_offset_p
!= NULL
)
7177 *bit_offset_p
= bit_pos
% 8;
7178 if (bit_size_p
!= NULL
)
7179 *bit_size_p
= bit_size
;
7182 else if (ada_is_wrapper_field (type
, i
))
7184 if (find_struct_field (name
, type
->field (i
).type (), fld_offset
,
7185 field_type_p
, byte_offset_p
, bit_offset_p
,
7186 bit_size_p
, index_p
))
7189 else if (ada_is_variant_part (type
, i
))
7191 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7194 struct type
*field_type
7195 = ada_check_typedef (type
->field (i
).type ());
7197 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7199 if (find_struct_field (name
, field_type
->field (j
).type (),
7201 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7202 field_type_p
, byte_offset_p
,
7203 bit_offset_p
, bit_size_p
, index_p
))
7207 else if (index_p
!= NULL
)
7211 /* Field not found so far. If this is a tagged type which
7212 has a parent, try finding that field in the parent now. */
7214 if (parent_offset
!= -1)
7216 int bit_pos
= TYPE_FIELD_BITPOS (type
, parent_offset
);
7217 int fld_offset
= offset
+ bit_pos
/ 8;
7219 if (find_struct_field (name
, type
->field (parent_offset
).type (),
7220 fld_offset
, field_type_p
, byte_offset_p
,
7221 bit_offset_p
, bit_size_p
, index_p
))
7228 /* Number of user-visible fields in record type TYPE. */
7231 num_visible_fields (struct type
*type
)
7236 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
7240 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7241 and search in it assuming it has (class) type TYPE.
7242 If found, return value, else return NULL.
7244 Searches recursively through wrapper fields (e.g., '_parent').
7246 In the case of homonyms in the tagged types, please refer to the
7247 long explanation in find_struct_field's function documentation. */
7249 static struct value
*
7250 ada_search_struct_field (const char *name
, struct value
*arg
, int offset
,
7254 int parent_offset
= -1;
7256 type
= ada_check_typedef (type
);
7257 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7259 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7261 if (t_field_name
== NULL
)
7264 else if (ada_is_parent_field (type
, i
))
7266 /* This is a field pointing us to the parent type of a tagged
7267 type. As hinted in this function's documentation, we give
7268 preference to fields in the current record first, so what
7269 we do here is just record the index of this field before
7270 we skip it. If it turns out we couldn't find our field
7271 in the current record, then we'll get back to it and search
7272 inside it whether the field might exist in the parent. */
7278 else if (field_name_match (t_field_name
, name
))
7279 return ada_value_primitive_field (arg
, offset
, i
, type
);
7281 else if (ada_is_wrapper_field (type
, i
))
7283 struct value
*v
= /* Do not let indent join lines here. */
7284 ada_search_struct_field (name
, arg
,
7285 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7286 type
->field (i
).type ());
7292 else if (ada_is_variant_part (type
, i
))
7294 /* PNH: Do we ever get here? See find_struct_field. */
7296 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7297 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7299 for (j
= 0; j
< field_type
->num_fields (); j
+= 1)
7301 struct value
*v
= ada_search_struct_field
/* Force line
7304 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7305 field_type
->field (j
).type ());
7313 /* Field not found so far. If this is a tagged type which
7314 has a parent, try finding that field in the parent now. */
7316 if (parent_offset
!= -1)
7318 struct value
*v
= ada_search_struct_field (
7319 name
, arg
, offset
+ TYPE_FIELD_BITPOS (type
, parent_offset
) / 8,
7320 type
->field (parent_offset
).type ());
7329 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7330 int, struct type
*);
7333 /* Return field #INDEX in ARG, where the index is that returned by
7334 * find_struct_field through its INDEX_P argument. Adjust the address
7335 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7336 * If found, return value, else return NULL. */
7338 static struct value
*
7339 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7342 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7346 /* Auxiliary function for ada_index_struct_field. Like
7347 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7350 static struct value
*
7351 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7355 type
= ada_check_typedef (type
);
7357 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7359 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7361 else if (ada_is_wrapper_field (type
, i
))
7363 struct value
*v
= /* Do not let indent join lines here. */
7364 ada_index_struct_field_1 (index_p
, arg
,
7365 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7366 type
->field (i
).type ());
7372 else if (ada_is_variant_part (type
, i
))
7374 /* PNH: Do we ever get here? See ada_search_struct_field,
7375 find_struct_field. */
7376 error (_("Cannot assign this kind of variant record"));
7378 else if (*index_p
== 0)
7379 return ada_value_primitive_field (arg
, offset
, i
, type
);
7386 /* Return a string representation of type TYPE. */
7389 type_as_string (struct type
*type
)
7391 string_file tmp_stream
;
7393 type_print (type
, "", &tmp_stream
, -1);
7395 return std::move (tmp_stream
.string ());
7398 /* Given a type TYPE, look up the type of the component of type named NAME.
7399 If DISPP is non-null, add its byte displacement from the beginning of a
7400 structure (pointed to by a value) of type TYPE to *DISPP (does not
7401 work for packed fields).
7403 Matches any field whose name has NAME as a prefix, possibly
7406 TYPE can be either a struct or union. If REFOK, TYPE may also
7407 be a (pointer or reference)+ to a struct or union, and the
7408 ultimate target type will be searched.
7410 Looks recursively into variant clauses and parent types.
7412 In the case of homonyms in the tagged types, please refer to the
7413 long explanation in find_struct_field's function documentation.
7415 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7416 TYPE is not a type of the right kind. */
7418 static struct type
*
7419 ada_lookup_struct_elt_type (struct type
*type
, const char *name
, int refok
,
7423 int parent_offset
= -1;
7428 if (refok
&& type
!= NULL
)
7431 type
= ada_check_typedef (type
);
7432 if (type
->code () != TYPE_CODE_PTR
&& type
->code () != TYPE_CODE_REF
)
7434 type
= TYPE_TARGET_TYPE (type
);
7438 || (type
->code () != TYPE_CODE_STRUCT
7439 && type
->code () != TYPE_CODE_UNION
))
7444 error (_("Type %s is not a structure or union type"),
7445 type
!= NULL
? type_as_string (type
).c_str () : _("(null)"));
7448 type
= to_static_fixed_type (type
);
7450 for (i
= 0; i
< type
->num_fields (); i
+= 1)
7452 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7455 if (t_field_name
== NULL
)
7458 else if (ada_is_parent_field (type
, i
))
7460 /* This is a field pointing us to the parent type of a tagged
7461 type. As hinted in this function's documentation, we give
7462 preference to fields in the current record first, so what
7463 we do here is just record the index of this field before
7464 we skip it. If it turns out we couldn't find our field
7465 in the current record, then we'll get back to it and search
7466 inside it whether the field might exist in the parent. */
7472 else if (field_name_match (t_field_name
, name
))
7473 return type
->field (i
).type ();
7475 else if (ada_is_wrapper_field (type
, i
))
7477 t
= ada_lookup_struct_elt_type (type
->field (i
).type (), name
,
7483 else if (ada_is_variant_part (type
, i
))
7486 struct type
*field_type
= ada_check_typedef (type
->field (i
).type ());
7488 for (j
= field_type
->num_fields () - 1; j
>= 0; j
-= 1)
7490 /* FIXME pnh 2008/01/26: We check for a field that is
7491 NOT wrapped in a struct, since the compiler sometimes
7492 generates these for unchecked variant types. Revisit
7493 if the compiler changes this practice. */
7494 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7496 if (v_field_name
!= NULL
7497 && field_name_match (v_field_name
, name
))
7498 t
= field_type
->field (j
).type ();
7500 t
= ada_lookup_struct_elt_type (field_type
->field (j
).type (),
7510 /* Field not found so far. If this is a tagged type which
7511 has a parent, try finding that field in the parent now. */
7513 if (parent_offset
!= -1)
7517 t
= ada_lookup_struct_elt_type (type
->field (parent_offset
).type (),
7526 const char *name_str
= name
!= NULL
? name
: _("<null>");
7528 error (_("Type %s has no component named %s"),
7529 type_as_string (type
).c_str (), name_str
);
7535 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7536 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7537 represents an unchecked union (that is, the variant part of a
7538 record that is named in an Unchecked_Union pragma). */
7541 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7543 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7545 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1) == NULL
);
7549 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7550 within OUTER, determine which variant clause (field number in VAR_TYPE,
7551 numbering from 0) is applicable. Returns -1 if none are. */
7554 ada_which_variant_applies (struct type
*var_type
, struct value
*outer
)
7558 const char *discrim_name
= ada_variant_discrim_name (var_type
);
7559 struct value
*discrim
;
7560 LONGEST discrim_val
;
7562 /* Using plain value_from_contents_and_address here causes problems
7563 because we will end up trying to resolve a type that is currently
7564 being constructed. */
7565 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7566 if (discrim
== NULL
)
7568 discrim_val
= value_as_long (discrim
);
7571 for (i
= 0; i
< var_type
->num_fields (); i
+= 1)
7573 if (ada_is_others_clause (var_type
, i
))
7575 else if (ada_in_variant (discrim_val
, var_type
, i
))
7579 return others_clause
;
7584 /* Dynamic-Sized Records */
7586 /* Strategy: The type ostensibly attached to a value with dynamic size
7587 (i.e., a size that is not statically recorded in the debugging
7588 data) does not accurately reflect the size or layout of the value.
7589 Our strategy is to convert these values to values with accurate,
7590 conventional types that are constructed on the fly. */
7592 /* There is a subtle and tricky problem here. In general, we cannot
7593 determine the size of dynamic records without its data. However,
7594 the 'struct value' data structure, which GDB uses to represent
7595 quantities in the inferior process (the target), requires the size
7596 of the type at the time of its allocation in order to reserve space
7597 for GDB's internal copy of the data. That's why the
7598 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7599 rather than struct value*s.
7601 However, GDB's internal history variables ($1, $2, etc.) are
7602 struct value*s containing internal copies of the data that are not, in
7603 general, the same as the data at their corresponding addresses in
7604 the target. Fortunately, the types we give to these values are all
7605 conventional, fixed-size types (as per the strategy described
7606 above), so that we don't usually have to perform the
7607 'to_fixed_xxx_type' conversions to look at their values.
7608 Unfortunately, there is one exception: if one of the internal
7609 history variables is an array whose elements are unconstrained
7610 records, then we will need to create distinct fixed types for each
7611 element selected. */
7613 /* The upshot of all of this is that many routines take a (type, host
7614 address, target address) triple as arguments to represent a value.
7615 The host address, if non-null, is supposed to contain an internal
7616 copy of the relevant data; otherwise, the program is to consult the
7617 target at the target address. */
7619 /* Assuming that VAL0 represents a pointer value, the result of
7620 dereferencing it. Differs from value_ind in its treatment of
7621 dynamic-sized types. */
7624 ada_value_ind (struct value
*val0
)
7626 struct value
*val
= value_ind (val0
);
7628 if (ada_is_tagged_type (value_type (val
), 0))
7629 val
= ada_tag_value_at_base_address (val
);
7631 return ada_to_fixed_value (val
);
7634 /* The value resulting from dereferencing any "reference to"
7635 qualifiers on VAL0. */
7637 static struct value
*
7638 ada_coerce_ref (struct value
*val0
)
7640 if (value_type (val0
)->code () == TYPE_CODE_REF
)
7642 struct value
*val
= val0
;
7644 val
= coerce_ref (val
);
7646 if (ada_is_tagged_type (value_type (val
), 0))
7647 val
= ada_tag_value_at_base_address (val
);
7649 return ada_to_fixed_value (val
);
7655 /* Return the bit alignment required for field #F of template type TYPE. */
7658 field_alignment (struct type
*type
, int f
)
7660 const char *name
= TYPE_FIELD_NAME (type
, f
);
7664 /* The field name should never be null, unless the debugging information
7665 is somehow malformed. In this case, we assume the field does not
7666 require any alignment. */
7670 len
= strlen (name
);
7672 if (!isdigit (name
[len
- 1]))
7675 if (isdigit (name
[len
- 2]))
7676 align_offset
= len
- 2;
7678 align_offset
= len
- 1;
7680 if (align_offset
< 7 || !startswith (name
+ align_offset
- 6, "___XV"))
7681 return TARGET_CHAR_BIT
;
7683 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7686 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7688 static struct symbol
*
7689 ada_find_any_type_symbol (const char *name
)
7693 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7694 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7697 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7701 /* Find a type named NAME. Ignores ambiguity. This routine will look
7702 solely for types defined by debug info, it will not search the GDB
7705 static struct type
*
7706 ada_find_any_type (const char *name
)
7708 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7711 return SYMBOL_TYPE (sym
);
7716 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7717 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7718 symbol, in which case it is returned. Otherwise, this looks for
7719 symbols whose name is that of NAME_SYM suffixed with "___XR".
7720 Return symbol if found, and NULL otherwise. */
7723 ada_is_renaming_symbol (struct symbol
*name_sym
)
7725 const char *name
= name_sym
->linkage_name ();
7726 return strstr (name
, "___XR") != NULL
;
7729 /* Because of GNAT encoding conventions, several GDB symbols may match a
7730 given type name. If the type denoted by TYPE0 is to be preferred to
7731 that of TYPE1 for purposes of type printing, return non-zero;
7732 otherwise return 0. */
7735 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7739 else if (type0
== NULL
)
7741 else if (type1
->code () == TYPE_CODE_VOID
)
7743 else if (type0
->code () == TYPE_CODE_VOID
)
7745 else if (type1
->name () == NULL
&& type0
->name () != NULL
)
7747 else if (ada_is_constrained_packed_array_type (type0
))
7749 else if (ada_is_array_descriptor_type (type0
)
7750 && !ada_is_array_descriptor_type (type1
))
7754 const char *type0_name
= type0
->name ();
7755 const char *type1_name
= type1
->name ();
7757 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7758 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7764 /* The name of TYPE, which is its TYPE_NAME. Null if TYPE is
7768 ada_type_name (struct type
*type
)
7772 return type
->name ();
7775 /* Search the list of "descriptive" types associated to TYPE for a type
7776 whose name is NAME. */
7778 static struct type
*
7779 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7781 struct type
*result
, *tmp
;
7783 if (ada_ignore_descriptive_types_p
)
7786 /* If there no descriptive-type info, then there is no parallel type
7788 if (!HAVE_GNAT_AUX_INFO (type
))
7791 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7792 while (result
!= NULL
)
7794 const char *result_name
= ada_type_name (result
);
7796 if (result_name
== NULL
)
7798 warning (_("unexpected null name on descriptive type"));
7802 /* If the names match, stop. */
7803 if (strcmp (result_name
, name
) == 0)
7806 /* Otherwise, look at the next item on the list, if any. */
7807 if (HAVE_GNAT_AUX_INFO (result
))
7808 tmp
= TYPE_DESCRIPTIVE_TYPE (result
);
7812 /* If not found either, try after having resolved the typedef. */
7817 result
= check_typedef (result
);
7818 if (HAVE_GNAT_AUX_INFO (result
))
7819 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7825 /* If we didn't find a match, see whether this is a packed array. With
7826 older compilers, the descriptive type information is either absent or
7827 irrelevant when it comes to packed arrays so the above lookup fails.
7828 Fall back to using a parallel lookup by name in this case. */
7829 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7830 return ada_find_any_type (name
);
7835 /* Find a parallel type to TYPE with the specified NAME, using the
7836 descriptive type taken from the debugging information, if available,
7837 and otherwise using the (slower) name-based method. */
7839 static struct type
*
7840 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7842 struct type
*result
= NULL
;
7844 if (HAVE_GNAT_AUX_INFO (type
))
7845 result
= find_parallel_type_by_descriptive_type (type
, name
);
7847 result
= ada_find_any_type (name
);
7852 /* Same as above, but specify the name of the parallel type by appending
7853 SUFFIX to the name of TYPE. */
7856 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7859 const char *type_name
= ada_type_name (type
);
7862 if (type_name
== NULL
)
7865 len
= strlen (type_name
);
7867 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7869 strcpy (name
, type_name
);
7870 strcpy (name
+ len
, suffix
);
7872 return ada_find_parallel_type_with_name (type
, name
);
7875 /* If TYPE is a variable-size record type, return the corresponding template
7876 type describing its fields. Otherwise, return NULL. */
7878 static struct type
*
7879 dynamic_template_type (struct type
*type
)
7881 type
= ada_check_typedef (type
);
7883 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
7884 || ada_type_name (type
) == NULL
)
7888 int len
= strlen (ada_type_name (type
));
7890 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7893 return ada_find_parallel_type (type
, "___XVE");
7897 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7898 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7901 is_dynamic_field (struct type
*templ_type
, int field_num
)
7903 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7906 && templ_type
->field (field_num
).type ()->code () == TYPE_CODE_PTR
7907 && strstr (name
, "___XVL") != NULL
;
7910 /* The index of the variant field of TYPE, or -1 if TYPE does not
7911 represent a variant record type. */
7914 variant_field_index (struct type
*type
)
7918 if (type
== NULL
|| type
->code () != TYPE_CODE_STRUCT
)
7921 for (f
= 0; f
< type
->num_fields (); f
+= 1)
7923 if (ada_is_variant_part (type
, f
))
7929 /* A record type with no fields. */
7931 static struct type
*
7932 empty_record (struct type
*templ
)
7934 struct type
*type
= alloc_type_copy (templ
);
7936 type
->set_code (TYPE_CODE_STRUCT
);
7937 INIT_NONE_SPECIFIC (type
);
7938 type
->set_name ("<empty>");
7939 TYPE_LENGTH (type
) = 0;
7943 /* An ordinary record type (with fixed-length fields) that describes
7944 the value of type TYPE at VALADDR or ADDRESS (see comments at
7945 the beginning of this section) VAL according to GNAT conventions.
7946 DVAL0 should describe the (portion of a) record that contains any
7947 necessary discriminants. It should be NULL if value_type (VAL) is
7948 an outer-level type (i.e., as opposed to a branch of a variant.) A
7949 variant field (unless unchecked) is replaced by a particular branch
7952 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7953 length are not statically known are discarded. As a consequence,
7954 VALADDR, ADDRESS and DVAL0 are ignored.
7956 NOTE: Limitations: For now, we assume that dynamic fields and
7957 variants occupy whole numbers of bytes. However, they need not be
7961 ada_template_to_fixed_record_type_1 (struct type
*type
,
7962 const gdb_byte
*valaddr
,
7963 CORE_ADDR address
, struct value
*dval0
,
7964 int keep_dynamic_fields
)
7966 struct value
*mark
= value_mark ();
7969 int nfields
, bit_len
;
7975 /* Compute the number of fields in this record type that are going
7976 to be processed: unless keep_dynamic_fields, this includes only
7977 fields whose position and length are static will be processed. */
7978 if (keep_dynamic_fields
)
7979 nfields
= type
->num_fields ();
7983 while (nfields
< type
->num_fields ()
7984 && !ada_is_variant_part (type
, nfields
)
7985 && !is_dynamic_field (type
, nfields
))
7989 rtype
= alloc_type_copy (type
);
7990 rtype
->set_code (TYPE_CODE_STRUCT
);
7991 INIT_NONE_SPECIFIC (rtype
);
7992 rtype
->set_num_fields (nfields
);
7994 ((struct field
*) TYPE_ZALLOC (rtype
, nfields
* sizeof (struct field
)));
7995 rtype
->set_name (ada_type_name (type
));
7996 TYPE_FIXED_INSTANCE (rtype
) = 1;
8002 for (f
= 0; f
< nfields
; f
+= 1)
8004 off
= align_up (off
, field_alignment (type
, f
))
8005 + TYPE_FIELD_BITPOS (type
, f
);
8006 SET_FIELD_BITPOS (rtype
->field (f
), off
);
8007 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
8009 if (ada_is_variant_part (type
, f
))
8014 else if (is_dynamic_field (type
, f
))
8016 const gdb_byte
*field_valaddr
= valaddr
;
8017 CORE_ADDR field_address
= address
;
8018 struct type
*field_type
=
8019 TYPE_TARGET_TYPE (type
->field (f
).type ());
8023 /* rtype's length is computed based on the run-time
8024 value of discriminants. If the discriminants are not
8025 initialized, the type size may be completely bogus and
8026 GDB may fail to allocate a value for it. So check the
8027 size first before creating the value. */
8028 ada_ensure_varsize_limit (rtype
);
8029 /* Using plain value_from_contents_and_address here
8030 causes problems because we will end up trying to
8031 resolve a type that is currently being
8033 dval
= value_from_contents_and_address_unresolved (rtype
,
8036 rtype
= value_type (dval
);
8041 /* If the type referenced by this field is an aligner type, we need
8042 to unwrap that aligner type, because its size might not be set.
8043 Keeping the aligner type would cause us to compute the wrong
8044 size for this field, impacting the offset of the all the fields
8045 that follow this one. */
8046 if (ada_is_aligner_type (field_type
))
8048 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
8050 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
8051 field_address
= cond_offset_target (field_address
, field_offset
);
8052 field_type
= ada_aligned_type (field_type
);
8055 field_valaddr
= cond_offset_host (field_valaddr
,
8056 off
/ TARGET_CHAR_BIT
);
8057 field_address
= cond_offset_target (field_address
,
8058 off
/ TARGET_CHAR_BIT
);
8060 /* Get the fixed type of the field. Note that, in this case,
8061 we do not want to get the real type out of the tag: if
8062 the current field is the parent part of a tagged record,
8063 we will get the tag of the object. Clearly wrong: the real
8064 type of the parent is not the real type of the child. We
8065 would end up in an infinite loop. */
8066 field_type
= ada_get_base_type (field_type
);
8067 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
8068 field_address
, dval
, 0);
8069 /* If the field size is already larger than the maximum
8070 object size, then the record itself will necessarily
8071 be larger than the maximum object size. We need to make
8072 this check now, because the size might be so ridiculously
8073 large (due to an uninitialized variable in the inferior)
8074 that it would cause an overflow when adding it to the
8076 ada_ensure_varsize_limit (field_type
);
8078 rtype
->field (f
).set_type (field_type
);
8079 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8080 /* The multiplication can potentially overflow. But because
8081 the field length has been size-checked just above, and
8082 assuming that the maximum size is a reasonable value,
8083 an overflow should not happen in practice. So rather than
8084 adding overflow recovery code to this already complex code,
8085 we just assume that it's not going to happen. */
8087 TYPE_LENGTH (rtype
->field (f
).type ()) * TARGET_CHAR_BIT
;
8091 /* Note: If this field's type is a typedef, it is important
8092 to preserve the typedef layer.
8094 Otherwise, we might be transforming a typedef to a fat
8095 pointer (encoding a pointer to an unconstrained array),
8096 into a basic fat pointer (encoding an unconstrained
8097 array). As both types are implemented using the same
8098 structure, the typedef is the only clue which allows us
8099 to distinguish between the two options. Stripping it
8100 would prevent us from printing this field appropriately. */
8101 rtype
->field (f
).set_type (type
->field (f
).type ());
8102 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
8103 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
8105 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
8108 struct type
*field_type
= type
->field (f
).type ();
8110 /* We need to be careful of typedefs when computing
8111 the length of our field. If this is a typedef,
8112 get the length of the target type, not the length
8114 if (field_type
->code () == TYPE_CODE_TYPEDEF
)
8115 field_type
= ada_typedef_target_type (field_type
);
8118 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
8121 if (off
+ fld_bit_len
> bit_len
)
8122 bit_len
= off
+ fld_bit_len
;
8124 TYPE_LENGTH (rtype
) =
8125 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8128 /* We handle the variant part, if any, at the end because of certain
8129 odd cases in which it is re-ordered so as NOT to be the last field of
8130 the record. This can happen in the presence of representation
8132 if (variant_field
>= 0)
8134 struct type
*branch_type
;
8136 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8140 /* Using plain value_from_contents_and_address here causes
8141 problems because we will end up trying to resolve a type
8142 that is currently being constructed. */
8143 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8145 rtype
= value_type (dval
);
8151 to_fixed_variant_branch_type
8152 (type
->field (variant_field
).type (),
8153 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8154 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8155 if (branch_type
== NULL
)
8157 for (f
= variant_field
+ 1; f
< rtype
->num_fields (); f
+= 1)
8158 rtype
->field (f
- 1) = rtype
->field (f
);
8159 rtype
->set_num_fields (rtype
->num_fields () - 1);
8163 rtype
->field (variant_field
).set_type (branch_type
);
8164 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8166 TYPE_LENGTH (rtype
->field (variant_field
).type ()) *
8168 if (off
+ fld_bit_len
> bit_len
)
8169 bit_len
= off
+ fld_bit_len
;
8170 TYPE_LENGTH (rtype
) =
8171 align_up (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8175 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8176 should contain the alignment of that record, which should be a strictly
8177 positive value. If null or negative, then something is wrong, most
8178 probably in the debug info. In that case, we don't round up the size
8179 of the resulting type. If this record is not part of another structure,
8180 the current RTYPE length might be good enough for our purposes. */
8181 if (TYPE_LENGTH (type
) <= 0)
8184 warning (_("Invalid type size for `%s' detected: %s."),
8185 rtype
->name (), pulongest (TYPE_LENGTH (type
)));
8187 warning (_("Invalid type size for <unnamed> detected: %s."),
8188 pulongest (TYPE_LENGTH (type
)));
8192 TYPE_LENGTH (rtype
) = align_up (TYPE_LENGTH (rtype
),
8193 TYPE_LENGTH (type
));
8196 value_free_to_mark (mark
);
8197 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8198 error (_("record type with dynamic size is larger than varsize-limit"));
8202 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8205 static struct type
*
8206 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8207 CORE_ADDR address
, struct value
*dval0
)
8209 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8213 /* An ordinary record type in which ___XVL-convention fields and
8214 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8215 static approximations, containing all possible fields. Uses
8216 no runtime values. Useless for use in values, but that's OK,
8217 since the results are used only for type determinations. Works on both
8218 structs and unions. Representation note: to save space, we memorize
8219 the result of this function in the TYPE_TARGET_TYPE of the
8222 static struct type
*
8223 template_to_static_fixed_type (struct type
*type0
)
8229 /* No need no do anything if the input type is already fixed. */
8230 if (TYPE_FIXED_INSTANCE (type0
))
8233 /* Likewise if we already have computed the static approximation. */
8234 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8235 return TYPE_TARGET_TYPE (type0
);
8237 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8239 nfields
= type0
->num_fields ();
8241 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8242 recompute all over next time. */
8243 TYPE_TARGET_TYPE (type0
) = type
;
8245 for (f
= 0; f
< nfields
; f
+= 1)
8247 struct type
*field_type
= type0
->field (f
).type ();
8248 struct type
*new_type
;
8250 if (is_dynamic_field (type0
, f
))
8252 field_type
= ada_check_typedef (field_type
);
8253 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8256 new_type
= static_unwrap_type (field_type
);
8258 if (new_type
!= field_type
)
8260 /* Clone TYPE0 only the first time we get a new field type. */
8263 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8264 type
->set_code (type0
->code ());
8265 INIT_NONE_SPECIFIC (type
);
8266 type
->set_num_fields (nfields
);
8270 TYPE_ALLOC (type
, nfields
* sizeof (struct field
)));
8271 memcpy (fields
, type0
->fields (),
8272 sizeof (struct field
) * nfields
);
8273 type
->set_fields (fields
);
8275 type
->set_name (ada_type_name (type0
));
8276 TYPE_FIXED_INSTANCE (type
) = 1;
8277 TYPE_LENGTH (type
) = 0;
8279 type
->field (f
).set_type (new_type
);
8280 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8287 /* Given an object of type TYPE whose contents are at VALADDR and
8288 whose address in memory is ADDRESS, returns a revision of TYPE,
8289 which should be a non-dynamic-sized record, in which the variant
8290 part, if any, is replaced with the appropriate branch. Looks
8291 for discriminant values in DVAL0, which can be NULL if the record
8292 contains the necessary discriminant values. */
8294 static struct type
*
8295 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8296 CORE_ADDR address
, struct value
*dval0
)
8298 struct value
*mark
= value_mark ();
8301 struct type
*branch_type
;
8302 int nfields
= type
->num_fields ();
8303 int variant_field
= variant_field_index (type
);
8305 if (variant_field
== -1)
8310 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8311 type
= value_type (dval
);
8316 rtype
= alloc_type_copy (type
);
8317 rtype
->set_code (TYPE_CODE_STRUCT
);
8318 INIT_NONE_SPECIFIC (rtype
);
8319 rtype
->set_num_fields (nfields
);
8322 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8323 memcpy (fields
, type
->fields (), sizeof (struct field
) * nfields
);
8324 rtype
->set_fields (fields
);
8326 rtype
->set_name (ada_type_name (type
));
8327 TYPE_FIXED_INSTANCE (rtype
) = 1;
8328 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8330 branch_type
= to_fixed_variant_branch_type
8331 (type
->field (variant_field
).type (),
8332 cond_offset_host (valaddr
,
8333 TYPE_FIELD_BITPOS (type
, variant_field
)
8335 cond_offset_target (address
,
8336 TYPE_FIELD_BITPOS (type
, variant_field
)
8337 / TARGET_CHAR_BIT
), dval
);
8338 if (branch_type
== NULL
)
8342 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8343 rtype
->field (f
- 1) = rtype
->field (f
);
8344 rtype
->set_num_fields (rtype
->num_fields () - 1);
8348 rtype
->field (variant_field
).set_type (branch_type
);
8349 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8350 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8351 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8353 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (type
->field (variant_field
).type ());
8355 value_free_to_mark (mark
);
8359 /* An ordinary record type (with fixed-length fields) that describes
8360 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8361 beginning of this section]. Any necessary discriminants' values
8362 should be in DVAL, a record value; it may be NULL if the object
8363 at ADDR itself contains any necessary discriminant values.
8364 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8365 values from the record are needed. Except in the case that DVAL,
8366 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8367 unchecked) is replaced by a particular branch of the variant.
8369 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8370 is questionable and may be removed. It can arise during the
8371 processing of an unconstrained-array-of-record type where all the
8372 variant branches have exactly the same size. This is because in
8373 such cases, the compiler does not bother to use the XVS convention
8374 when encoding the record. I am currently dubious of this
8375 shortcut and suspect the compiler should be altered. FIXME. */
8377 static struct type
*
8378 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8379 CORE_ADDR address
, struct value
*dval
)
8381 struct type
*templ_type
;
8383 if (TYPE_FIXED_INSTANCE (type0
))
8386 templ_type
= dynamic_template_type (type0
);
8388 if (templ_type
!= NULL
)
8389 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8390 else if (variant_field_index (type0
) >= 0)
8392 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8394 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8399 TYPE_FIXED_INSTANCE (type0
) = 1;
8405 /* An ordinary record type (with fixed-length fields) that describes
8406 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8407 union type. Any necessary discriminants' values should be in DVAL,
8408 a record value. That is, this routine selects the appropriate
8409 branch of the union at ADDR according to the discriminant value
8410 indicated in the union's type name. Returns VAR_TYPE0 itself if
8411 it represents a variant subject to a pragma Unchecked_Union. */
8413 static struct type
*
8414 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8415 CORE_ADDR address
, struct value
*dval
)
8418 struct type
*templ_type
;
8419 struct type
*var_type
;
8421 if (var_type0
->code () == TYPE_CODE_PTR
)
8422 var_type
= TYPE_TARGET_TYPE (var_type0
);
8424 var_type
= var_type0
;
8426 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8428 if (templ_type
!= NULL
)
8429 var_type
= templ_type
;
8431 if (is_unchecked_variant (var_type
, value_type (dval
)))
8433 which
= ada_which_variant_applies (var_type
, dval
);
8436 return empty_record (var_type
);
8437 else if (is_dynamic_field (var_type
, which
))
8438 return to_fixed_record_type
8439 (TYPE_TARGET_TYPE (var_type
->field (which
).type ()),
8440 valaddr
, address
, dval
);
8441 else if (variant_field_index (var_type
->field (which
).type ()) >= 0)
8443 to_fixed_record_type
8444 (var_type
->field (which
).type (), valaddr
, address
, dval
);
8446 return var_type
->field (which
).type ();
8449 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8450 ENCODING_TYPE, a type following the GNAT conventions for discrete
8451 type encodings, only carries redundant information. */
8454 ada_is_redundant_range_encoding (struct type
*range_type
,
8455 struct type
*encoding_type
)
8457 const char *bounds_str
;
8461 gdb_assert (range_type
->code () == TYPE_CODE_RANGE
);
8463 if (get_base_type (range_type
)->code ()
8464 != get_base_type (encoding_type
)->code ())
8466 /* The compiler probably used a simple base type to describe
8467 the range type instead of the range's actual base type,
8468 expecting us to get the real base type from the encoding
8469 anyway. In this situation, the encoding cannot be ignored
8474 if (is_dynamic_type (range_type
))
8477 if (encoding_type
->name () == NULL
)
8480 bounds_str
= strstr (encoding_type
->name (), "___XDLU_");
8481 if (bounds_str
== NULL
)
8484 n
= 8; /* Skip "___XDLU_". */
8485 if (!ada_scan_number (bounds_str
, n
, &lo
, &n
))
8487 if (TYPE_LOW_BOUND (range_type
) != lo
)
8490 n
+= 2; /* Skip the "__" separator between the two bounds. */
8491 if (!ada_scan_number (bounds_str
, n
, &hi
, &n
))
8493 if (TYPE_HIGH_BOUND (range_type
) != hi
)
8499 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8500 a type following the GNAT encoding for describing array type
8501 indices, only carries redundant information. */
8504 ada_is_redundant_index_type_desc (struct type
*array_type
,
8505 struct type
*desc_type
)
8507 struct type
*this_layer
= check_typedef (array_type
);
8510 for (i
= 0; i
< desc_type
->num_fields (); i
++)
8512 if (!ada_is_redundant_range_encoding (this_layer
->index_type (),
8513 desc_type
->field (i
).type ()))
8515 this_layer
= check_typedef (TYPE_TARGET_TYPE (this_layer
));
8521 /* Assuming that TYPE0 is an array type describing the type of a value
8522 at ADDR, and that DVAL describes a record containing any
8523 discriminants used in TYPE0, returns a type for the value that
8524 contains no dynamic components (that is, no components whose sizes
8525 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8526 true, gives an error message if the resulting type's size is over
8529 static struct type
*
8530 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8533 struct type
*index_type_desc
;
8534 struct type
*result
;
8535 int constrained_packed_array_p
;
8536 static const char *xa_suffix
= "___XA";
8538 type0
= ada_check_typedef (type0
);
8539 if (TYPE_FIXED_INSTANCE (type0
))
8542 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8543 if (constrained_packed_array_p
)
8544 type0
= decode_constrained_packed_array_type (type0
);
8546 index_type_desc
= ada_find_parallel_type (type0
, xa_suffix
);
8548 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8549 encoding suffixed with 'P' may still be generated. If so,
8550 it should be used to find the XA type. */
8552 if (index_type_desc
== NULL
)
8554 const char *type_name
= ada_type_name (type0
);
8556 if (type_name
!= NULL
)
8558 const int len
= strlen (type_name
);
8559 char *name
= (char *) alloca (len
+ strlen (xa_suffix
));
8561 if (type_name
[len
- 1] == 'P')
8563 strcpy (name
, type_name
);
8564 strcpy (name
+ len
- 1, xa_suffix
);
8565 index_type_desc
= ada_find_parallel_type_with_name (type0
, name
);
8570 ada_fixup_array_indexes_type (index_type_desc
);
8571 if (index_type_desc
!= NULL
8572 && ada_is_redundant_index_type_desc (type0
, index_type_desc
))
8574 /* Ignore this ___XA parallel type, as it does not bring any
8575 useful information. This allows us to avoid creating fixed
8576 versions of the array's index types, which would be identical
8577 to the original ones. This, in turn, can also help avoid
8578 the creation of fixed versions of the array itself. */
8579 index_type_desc
= NULL
;
8582 if (index_type_desc
== NULL
)
8584 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8586 /* NOTE: elt_type---the fixed version of elt_type0---should never
8587 depend on the contents of the array in properly constructed
8589 /* Create a fixed version of the array element type.
8590 We're not providing the address of an element here,
8591 and thus the actual object value cannot be inspected to do
8592 the conversion. This should not be a problem, since arrays of
8593 unconstrained objects are not allowed. In particular, all
8594 the elements of an array of a tagged type should all be of
8595 the same type specified in the debugging info. No need to
8596 consult the object tag. */
8597 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8599 /* Make sure we always create a new array type when dealing with
8600 packed array types, since we're going to fix-up the array
8601 type length and element bitsize a little further down. */
8602 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8605 result
= create_array_type (alloc_type_copy (type0
),
8606 elt_type
, type0
->index_type ());
8611 struct type
*elt_type0
;
8614 for (i
= index_type_desc
->num_fields (); i
> 0; i
-= 1)
8615 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8617 /* NOTE: result---the fixed version of elt_type0---should never
8618 depend on the contents of the array in properly constructed
8620 /* Create a fixed version of the array element type.
8621 We're not providing the address of an element here,
8622 and thus the actual object value cannot be inspected to do
8623 the conversion. This should not be a problem, since arrays of
8624 unconstrained objects are not allowed. In particular, all
8625 the elements of an array of a tagged type should all be of
8626 the same type specified in the debugging info. No need to
8627 consult the object tag. */
8629 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8632 for (i
= index_type_desc
->num_fields () - 1; i
>= 0; i
-= 1)
8634 struct type
*range_type
=
8635 to_fixed_range_type (index_type_desc
->field (i
).type (), dval
);
8637 result
= create_array_type (alloc_type_copy (elt_type0
),
8638 result
, range_type
);
8639 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8641 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8642 error (_("array type with dynamic size is larger than varsize-limit"));
8645 /* We want to preserve the type name. This can be useful when
8646 trying to get the type name of a value that has already been
8647 printed (for instance, if the user did "print VAR; whatis $". */
8648 result
->set_name (type0
->name ());
8650 if (constrained_packed_array_p
)
8652 /* So far, the resulting type has been created as if the original
8653 type was a regular (non-packed) array type. As a result, the
8654 bitsize of the array elements needs to be set again, and the array
8655 length needs to be recomputed based on that bitsize. */
8656 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8657 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8659 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8660 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8661 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8662 TYPE_LENGTH (result
)++;
8665 TYPE_FIXED_INSTANCE (result
) = 1;
8670 /* A standard type (containing no dynamically sized components)
8671 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8672 DVAL describes a record containing any discriminants used in TYPE0,
8673 and may be NULL if there are none, or if the object of type TYPE at
8674 ADDRESS or in VALADDR contains these discriminants.
8676 If CHECK_TAG is not null, in the case of tagged types, this function
8677 attempts to locate the object's tag and use it to compute the actual
8678 type. However, when ADDRESS is null, we cannot use it to determine the
8679 location of the tag, and therefore compute the tagged type's actual type.
8680 So we return the tagged type without consulting the tag. */
8682 static struct type
*
8683 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8684 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8686 type
= ada_check_typedef (type
);
8688 /* Only un-fixed types need to be handled here. */
8689 if (!HAVE_GNAT_AUX_INFO (type
))
8692 switch (type
->code ())
8696 case TYPE_CODE_STRUCT
:
8698 struct type
*static_type
= to_static_fixed_type (type
);
8699 struct type
*fixed_record_type
=
8700 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8702 /* If STATIC_TYPE is a tagged type and we know the object's address,
8703 then we can determine its tag, and compute the object's actual
8704 type from there. Note that we have to use the fixed record
8705 type (the parent part of the record may have dynamic fields
8706 and the way the location of _tag is expressed may depend on
8709 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8712 value_tag_from_contents_and_address
8716 struct type
*real_type
= type_from_tag (tag
);
8718 value_from_contents_and_address (fixed_record_type
,
8721 fixed_record_type
= value_type (obj
);
8722 if (real_type
!= NULL
)
8723 return to_fixed_record_type
8725 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8728 /* Check to see if there is a parallel ___XVZ variable.
8729 If there is, then it provides the actual size of our type. */
8730 else if (ada_type_name (fixed_record_type
) != NULL
)
8732 const char *name
= ada_type_name (fixed_record_type
);
8734 = (char *) alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8735 bool xvz_found
= false;
8738 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8741 xvz_found
= get_int_var_value (xvz_name
, size
);
8743 catch (const gdb_exception_error
&except
)
8745 /* We found the variable, but somehow failed to read
8746 its value. Rethrow the same error, but with a little
8747 bit more information, to help the user understand
8748 what went wrong (Eg: the variable might have been
8750 throw_error (except
.error
,
8751 _("unable to read value of %s (%s)"),
8752 xvz_name
, except
.what ());
8755 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8757 fixed_record_type
= copy_type (fixed_record_type
);
8758 TYPE_LENGTH (fixed_record_type
) = size
;
8760 /* The FIXED_RECORD_TYPE may have be a stub. We have
8761 observed this when the debugging info is STABS, and
8762 apparently it is something that is hard to fix.
8764 In practice, we don't need the actual type definition
8765 at all, because the presence of the XVZ variable allows us
8766 to assume that there must be a XVS type as well, which we
8767 should be able to use later, when we need the actual type
8770 In the meantime, pretend that the "fixed" type we are
8771 returning is NOT a stub, because this can cause trouble
8772 when using this type to create new types targeting it.
8773 Indeed, the associated creation routines often check
8774 whether the target type is a stub and will try to replace
8775 it, thus using a type with the wrong size. This, in turn,
8776 might cause the new type to have the wrong size too.
8777 Consider the case of an array, for instance, where the size
8778 of the array is computed from the number of elements in
8779 our array multiplied by the size of its element. */
8780 TYPE_STUB (fixed_record_type
) = 0;
8783 return fixed_record_type
;
8785 case TYPE_CODE_ARRAY
:
8786 return to_fixed_array_type (type
, dval
, 1);
8787 case TYPE_CODE_UNION
:
8791 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8795 /* The same as ada_to_fixed_type_1, except that it preserves the type
8796 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8798 The typedef layer needs be preserved in order to differentiate between
8799 arrays and array pointers when both types are implemented using the same
8800 fat pointer. In the array pointer case, the pointer is encoded as
8801 a typedef of the pointer type. For instance, considering:
8803 type String_Access is access String;
8804 S1 : String_Access := null;
8806 To the debugger, S1 is defined as a typedef of type String. But
8807 to the user, it is a pointer. So if the user tries to print S1,
8808 we should not dereference the array, but print the array address
8811 If we didn't preserve the typedef layer, we would lose the fact that
8812 the type is to be presented as a pointer (needs de-reference before
8813 being printed). And we would also use the source-level type name. */
8816 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8817 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8820 struct type
*fixed_type
=
8821 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8823 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8824 then preserve the typedef layer.
8826 Implementation note: We can only check the main-type portion of
8827 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8828 from TYPE now returns a type that has the same instance flags
8829 as TYPE. For instance, if TYPE is a "typedef const", and its
8830 target type is a "struct", then the typedef elimination will return
8831 a "const" version of the target type. See check_typedef for more
8832 details about how the typedef layer elimination is done.
8834 brobecker/2010-11-19: It seems to me that the only case where it is
8835 useful to preserve the typedef layer is when dealing with fat pointers.
8836 Perhaps, we could add a check for that and preserve the typedef layer
8837 only in that situation. But this seems unnecessary so far, probably
8838 because we call check_typedef/ada_check_typedef pretty much everywhere.
8840 if (type
->code () == TYPE_CODE_TYPEDEF
8841 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8842 == TYPE_MAIN_TYPE (fixed_type
)))
8848 /* A standard (static-sized) type corresponding as well as possible to
8849 TYPE0, but based on no runtime data. */
8851 static struct type
*
8852 to_static_fixed_type (struct type
*type0
)
8859 if (TYPE_FIXED_INSTANCE (type0
))
8862 type0
= ada_check_typedef (type0
);
8864 switch (type0
->code ())
8868 case TYPE_CODE_STRUCT
:
8869 type
= dynamic_template_type (type0
);
8871 return template_to_static_fixed_type (type
);
8873 return template_to_static_fixed_type (type0
);
8874 case TYPE_CODE_UNION
:
8875 type
= ada_find_parallel_type (type0
, "___XVU");
8877 return template_to_static_fixed_type (type
);
8879 return template_to_static_fixed_type (type0
);
8883 /* A static approximation of TYPE with all type wrappers removed. */
8885 static struct type
*
8886 static_unwrap_type (struct type
*type
)
8888 if (ada_is_aligner_type (type
))
8890 struct type
*type1
= ada_check_typedef (type
)->field (0).type ();
8891 if (ada_type_name (type1
) == NULL
)
8892 type1
->set_name (ada_type_name (type
));
8894 return static_unwrap_type (type1
);
8898 struct type
*raw_real_type
= ada_get_base_type (type
);
8900 if (raw_real_type
== type
)
8903 return to_static_fixed_type (raw_real_type
);
8907 /* In some cases, incomplete and private types require
8908 cross-references that are not resolved as records (for example,
8910 type FooP is access Foo;
8912 type Foo is array ...;
8913 ). In these cases, since there is no mechanism for producing
8914 cross-references to such types, we instead substitute for FooP a
8915 stub enumeration type that is nowhere resolved, and whose tag is
8916 the name of the actual type. Call these types "non-record stubs". */
8918 /* A type equivalent to TYPE that is not a non-record stub, if one
8919 exists, otherwise TYPE. */
8922 ada_check_typedef (struct type
*type
)
8927 /* If our type is an access to an unconstrained array, which is encoded
8928 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done.
8929 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8930 what allows us to distinguish between fat pointers that represent
8931 array types, and fat pointers that represent array access types
8932 (in both cases, the compiler implements them as fat pointers). */
8933 if (ada_is_access_to_unconstrained_array (type
))
8936 type
= check_typedef (type
);
8937 if (type
== NULL
|| type
->code () != TYPE_CODE_ENUM
8938 || !TYPE_STUB (type
)
8939 || type
->name () == NULL
)
8943 const char *name
= type
->name ();
8944 struct type
*type1
= ada_find_any_type (name
);
8949 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8950 stubs pointing to arrays, as we don't create symbols for array
8951 types, only for the typedef-to-array types). If that's the case,
8952 strip the typedef layer. */
8953 if (type1
->code () == TYPE_CODE_TYPEDEF
)
8954 type1
= ada_check_typedef (type1
);
8960 /* A value representing the data at VALADDR/ADDRESS as described by
8961 type TYPE0, but with a standard (static-sized) type that correctly
8962 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8963 type, then return VAL0 [this feature is simply to avoid redundant
8964 creation of struct values]. */
8966 static struct value
*
8967 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8970 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8972 if (type
== type0
&& val0
!= NULL
)
8975 if (VALUE_LVAL (val0
) != lval_memory
)
8977 /* Our value does not live in memory; it could be a convenience
8978 variable, for instance. Create a not_lval value using val0's
8980 return value_from_contents (type
, value_contents (val0
));
8983 return value_from_contents_and_address (type
, 0, address
);
8986 /* A value representing VAL, but with a standard (static-sized) type
8987 that correctly describes it. Does not necessarily create a new
8991 ada_to_fixed_value (struct value
*val
)
8993 val
= unwrap_value (val
);
8994 val
= ada_to_fixed_value_create (value_type (val
), value_address (val
), val
);
9001 /* Table mapping attribute numbers to names.
9002 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
9004 static const char *attribute_names
[] = {
9022 ada_attribute_name (enum exp_opcode n
)
9024 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
9025 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
9027 return attribute_names
[0];
9030 /* Evaluate the 'POS attribute applied to ARG. */
9033 pos_atr (struct value
*arg
)
9035 struct value
*val
= coerce_ref (arg
);
9036 struct type
*type
= value_type (val
);
9039 if (!discrete_type_p (type
))
9040 error (_("'POS only defined on discrete types"));
9042 if (!discrete_position (type
, value_as_long (val
), &result
))
9043 error (_("enumeration value is invalid: can't find 'POS"));
9048 static struct value
*
9049 value_pos_atr (struct type
*type
, struct value
*arg
)
9051 return value_from_longest (type
, pos_atr (arg
));
9054 /* Evaluate the TYPE'VAL attribute applied to ARG. */
9056 static struct value
*
9057 val_atr (struct type
*type
, LONGEST val
)
9059 gdb_assert (discrete_type_p (type
));
9060 if (type
->code () == TYPE_CODE_RANGE
)
9061 type
= TYPE_TARGET_TYPE (type
);
9062 if (type
->code () == TYPE_CODE_ENUM
)
9064 if (val
< 0 || val
>= type
->num_fields ())
9065 error (_("argument to 'VAL out of range"));
9066 val
= TYPE_FIELD_ENUMVAL (type
, val
);
9068 return value_from_longest (type
, val
);
9071 static struct value
*
9072 value_val_atr (struct type
*type
, struct value
*arg
)
9074 if (!discrete_type_p (type
))
9075 error (_("'VAL only defined on discrete types"));
9076 if (!integer_type_p (value_type (arg
)))
9077 error (_("'VAL requires integral argument"));
9079 return val_atr (type
, value_as_long (arg
));
9085 /* True if TYPE appears to be an Ada character type.
9086 [At the moment, this is true only for Character and Wide_Character;
9087 It is a heuristic test that could stand improvement]. */
9090 ada_is_character_type (struct type
*type
)
9094 /* If the type code says it's a character, then assume it really is,
9095 and don't check any further. */
9096 if (type
->code () == TYPE_CODE_CHAR
)
9099 /* Otherwise, assume it's a character type iff it is a discrete type
9100 with a known character type name. */
9101 name
= ada_type_name (type
);
9102 return (name
!= NULL
9103 && (type
->code () == TYPE_CODE_INT
9104 || type
->code () == TYPE_CODE_RANGE
)
9105 && (strcmp (name
, "character") == 0
9106 || strcmp (name
, "wide_character") == 0
9107 || strcmp (name
, "wide_wide_character") == 0
9108 || strcmp (name
, "unsigned char") == 0));
9111 /* True if TYPE appears to be an Ada string type. */
9114 ada_is_string_type (struct type
*type
)
9116 type
= ada_check_typedef (type
);
9118 && type
->code () != TYPE_CODE_PTR
9119 && (ada_is_simple_array_type (type
)
9120 || ada_is_array_descriptor_type (type
))
9121 && ada_array_arity (type
) == 1)
9123 struct type
*elttype
= ada_array_element_type (type
, 1);
9125 return ada_is_character_type (elttype
);
9131 /* The compiler sometimes provides a parallel XVS type for a given
9132 PAD type. Normally, it is safe to follow the PAD type directly,
9133 but older versions of the compiler have a bug that causes the offset
9134 of its "F" field to be wrong. Following that field in that case
9135 would lead to incorrect results, but this can be worked around
9136 by ignoring the PAD type and using the associated XVS type instead.
9138 Set to True if the debugger should trust the contents of PAD types.
9139 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9140 static bool trust_pad_over_xvs
= true;
9142 /* True if TYPE is a struct type introduced by the compiler to force the
9143 alignment of a value. Such types have a single field with a
9144 distinctive name. */
9147 ada_is_aligner_type (struct type
*type
)
9149 type
= ada_check_typedef (type
);
9151 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
9154 return (type
->code () == TYPE_CODE_STRUCT
9155 && type
->num_fields () == 1
9156 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
9159 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9160 the parallel type. */
9163 ada_get_base_type (struct type
*raw_type
)
9165 struct type
*real_type_namer
;
9166 struct type
*raw_real_type
;
9168 if (raw_type
== NULL
|| raw_type
->code () != TYPE_CODE_STRUCT
)
9171 if (ada_is_aligner_type (raw_type
))
9172 /* The encoding specifies that we should always use the aligner type.
9173 So, even if this aligner type has an associated XVS type, we should
9176 According to the compiler gurus, an XVS type parallel to an aligner
9177 type may exist because of a stabs limitation. In stabs, aligner
9178 types are empty because the field has a variable-sized type, and
9179 thus cannot actually be used as an aligner type. As a result,
9180 we need the associated parallel XVS type to decode the type.
9181 Since the policy in the compiler is to not change the internal
9182 representation based on the debugging info format, we sometimes
9183 end up having a redundant XVS type parallel to the aligner type. */
9186 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
9187 if (real_type_namer
== NULL
9188 || real_type_namer
->code () != TYPE_CODE_STRUCT
9189 || real_type_namer
->num_fields () != 1)
9192 if (real_type_namer
->field (0).type ()->code () != TYPE_CODE_REF
)
9194 /* This is an older encoding form where the base type needs to be
9195 looked up by name. We prefer the newer encoding because it is
9197 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
9198 if (raw_real_type
== NULL
)
9201 return raw_real_type
;
9204 /* The field in our XVS type is a reference to the base type. */
9205 return TYPE_TARGET_TYPE (real_type_namer
->field (0).type ());
9208 /* The type of value designated by TYPE, with all aligners removed. */
9211 ada_aligned_type (struct type
*type
)
9213 if (ada_is_aligner_type (type
))
9214 return ada_aligned_type (type
->field (0).type ());
9216 return ada_get_base_type (type
);
9220 /* The address of the aligned value in an object at address VALADDR
9221 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9224 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
9226 if (ada_is_aligner_type (type
))
9227 return ada_aligned_value_addr (type
->field (0).type (),
9229 TYPE_FIELD_BITPOS (type
,
9230 0) / TARGET_CHAR_BIT
);
9237 /* The printed representation of an enumeration literal with encoded
9238 name NAME. The value is good to the next call of ada_enum_name. */
9240 ada_enum_name (const char *name
)
9242 static char *result
;
9243 static size_t result_len
= 0;
9246 /* First, unqualify the enumeration name:
9247 1. Search for the last '.' character. If we find one, then skip
9248 all the preceding characters, the unqualified name starts
9249 right after that dot.
9250 2. Otherwise, we may be debugging on a target where the compiler
9251 translates dots into "__". Search forward for double underscores,
9252 but stop searching when we hit an overloading suffix, which is
9253 of the form "__" followed by digits. */
9255 tmp
= strrchr (name
, '.');
9260 while ((tmp
= strstr (name
, "__")) != NULL
)
9262 if (isdigit (tmp
[2]))
9273 if (name
[1] == 'U' || name
[1] == 'W')
9275 if (sscanf (name
+ 2, "%x", &v
) != 1)
9278 else if (((name
[1] >= '0' && name
[1] <= '9')
9279 || (name
[1] >= 'a' && name
[1] <= 'z'))
9282 GROW_VECT (result
, result_len
, 4);
9283 xsnprintf (result
, result_len
, "'%c'", name
[1]);
9289 GROW_VECT (result
, result_len
, 16);
9290 if (isascii (v
) && isprint (v
))
9291 xsnprintf (result
, result_len
, "'%c'", v
);
9292 else if (name
[1] == 'U')
9293 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9295 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9301 tmp
= strstr (name
, "__");
9303 tmp
= strstr (name
, "$");
9306 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9307 strncpy (result
, name
, tmp
- name
);
9308 result
[tmp
- name
] = '\0';
9316 /* Evaluate the subexpression of EXP starting at *POS as for
9317 evaluate_type, updating *POS to point just past the evaluated
9320 static struct value
*
9321 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9323 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9326 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9329 static struct value
*
9330 unwrap_value (struct value
*val
)
9332 struct type
*type
= ada_check_typedef (value_type (val
));
9334 if (ada_is_aligner_type (type
))
9336 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9337 struct type
*val_type
= ada_check_typedef (value_type (v
));
9339 if (ada_type_name (val_type
) == NULL
)
9340 val_type
->set_name (ada_type_name (type
));
9342 return unwrap_value (v
);
9346 struct type
*raw_real_type
=
9347 ada_check_typedef (ada_get_base_type (type
));
9349 /* If there is no parallel XVS or XVE type, then the value is
9350 already unwrapped. Return it without further modification. */
9351 if ((type
== raw_real_type
)
9352 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9356 coerce_unspec_val_to_type
9357 (val
, ada_to_fixed_type (raw_real_type
, 0,
9358 value_address (val
),
9363 static struct value
*
9364 cast_from_fixed (struct type
*type
, struct value
*arg
)
9366 struct value
*scale
= ada_scaling_factor (value_type (arg
));
9367 arg
= value_cast (value_type (scale
), arg
);
9369 arg
= value_binop (arg
, scale
, BINOP_MUL
);
9370 return value_cast (type
, arg
);
9373 static struct value
*
9374 cast_to_fixed (struct type
*type
, struct value
*arg
)
9376 if (type
== value_type (arg
))
9379 struct value
*scale
= ada_scaling_factor (type
);
9380 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg
)))
9381 arg
= cast_from_fixed (value_type (scale
), arg
);
9383 arg
= value_cast (value_type (scale
), arg
);
9385 arg
= value_binop (arg
, scale
, BINOP_DIV
);
9386 return value_cast (type
, arg
);
9389 /* Given two array types T1 and T2, return nonzero iff both arrays
9390 contain the same number of elements. */
9393 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9395 LONGEST lo1
, hi1
, lo2
, hi2
;
9397 /* Get the array bounds in order to verify that the size of
9398 the two arrays match. */
9399 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9400 || !get_array_bounds (t2
, &lo2
, &hi2
))
9401 error (_("unable to determine array bounds"));
9403 /* To make things easier for size comparison, normalize a bit
9404 the case of empty arrays by making sure that the difference
9405 between upper bound and lower bound is always -1. */
9411 return (hi1
- lo1
== hi2
- lo2
);
9414 /* Assuming that VAL is an array of integrals, and TYPE represents
9415 an array with the same number of elements, but with wider integral
9416 elements, return an array "casted" to TYPE. In practice, this
9417 means that the returned array is built by casting each element
9418 of the original array into TYPE's (wider) element type. */
9420 static struct value
*
9421 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9423 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9428 /* Verify that both val and type are arrays of scalars, and
9429 that the size of val's elements is smaller than the size
9430 of type's element. */
9431 gdb_assert (type
->code () == TYPE_CODE_ARRAY
);
9432 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9433 gdb_assert (value_type (val
)->code () == TYPE_CODE_ARRAY
);
9434 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9435 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9436 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9438 if (!get_array_bounds (type
, &lo
, &hi
))
9439 error (_("unable to determine array bounds"));
9441 res
= allocate_value (type
);
9443 /* Promote each array element. */
9444 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9446 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9448 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9449 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9455 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9456 return the converted value. */
9458 static struct value
*
9459 coerce_for_assign (struct type
*type
, struct value
*val
)
9461 struct type
*type2
= value_type (val
);
9466 type2
= ada_check_typedef (type2
);
9467 type
= ada_check_typedef (type
);
9469 if (type2
->code () == TYPE_CODE_PTR
9470 && type
->code () == TYPE_CODE_ARRAY
)
9472 val
= ada_value_ind (val
);
9473 type2
= value_type (val
);
9476 if (type2
->code () == TYPE_CODE_ARRAY
9477 && type
->code () == TYPE_CODE_ARRAY
)
9479 if (!ada_same_array_size_p (type
, type2
))
9480 error (_("cannot assign arrays of different length"));
9482 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9483 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9484 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9485 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9487 /* Allow implicit promotion of the array elements to
9489 return ada_promote_array_of_integrals (type
, val
);
9492 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9493 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9494 error (_("Incompatible types in assignment"));
9495 deprecated_set_value_type (val
, type
);
9500 static struct value
*
9501 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9504 struct type
*type1
, *type2
;
9507 arg1
= coerce_ref (arg1
);
9508 arg2
= coerce_ref (arg2
);
9509 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9510 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9512 if (type1
->code () != TYPE_CODE_INT
9513 || type2
->code () != TYPE_CODE_INT
)
9514 return value_binop (arg1
, arg2
, op
);
9523 return value_binop (arg1
, arg2
, op
);
9526 v2
= value_as_long (arg2
);
9528 error (_("second operand of %s must not be zero."), op_string (op
));
9530 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
9531 return value_binop (arg1
, arg2
, op
);
9533 v1
= value_as_long (arg1
);
9538 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9539 v
+= v
> 0 ? -1 : 1;
9547 /* Should not reach this point. */
9551 val
= allocate_value (type1
);
9552 store_unsigned_integer (value_contents_raw (val
),
9553 TYPE_LENGTH (value_type (val
)),
9554 type_byte_order (type1
), v
);
9559 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9561 if (ada_is_direct_array_type (value_type (arg1
))
9562 || ada_is_direct_array_type (value_type (arg2
)))
9564 struct type
*arg1_type
, *arg2_type
;
9566 /* Automatically dereference any array reference before
9567 we attempt to perform the comparison. */
9568 arg1
= ada_coerce_ref (arg1
);
9569 arg2
= ada_coerce_ref (arg2
);
9571 arg1
= ada_coerce_to_simple_array (arg1
);
9572 arg2
= ada_coerce_to_simple_array (arg2
);
9574 arg1_type
= ada_check_typedef (value_type (arg1
));
9575 arg2_type
= ada_check_typedef (value_type (arg2
));
9577 if (arg1_type
->code () != TYPE_CODE_ARRAY
9578 || arg2_type
->code () != TYPE_CODE_ARRAY
)
9579 error (_("Attempt to compare array with non-array"));
9580 /* FIXME: The following works only for types whose
9581 representations use all bits (no padding or undefined bits)
9582 and do not have user-defined equality. */
9583 return (TYPE_LENGTH (arg1_type
) == TYPE_LENGTH (arg2_type
)
9584 && memcmp (value_contents (arg1
), value_contents (arg2
),
9585 TYPE_LENGTH (arg1_type
)) == 0);
9587 return value_equal (arg1
, arg2
);
9590 /* Total number of component associations in the aggregate starting at
9591 index PC in EXP. Assumes that index PC is the start of an
9595 num_component_specs (struct expression
*exp
, int pc
)
9599 m
= exp
->elts
[pc
+ 1].longconst
;
9602 for (i
= 0; i
< m
; i
+= 1)
9604 switch (exp
->elts
[pc
].opcode
)
9610 n
+= exp
->elts
[pc
+ 1].longconst
;
9613 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9618 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9619 component of LHS (a simple array or a record), updating *POS past
9620 the expression, assuming that LHS is contained in CONTAINER. Does
9621 not modify the inferior's memory, nor does it modify LHS (unless
9622 LHS == CONTAINER). */
9625 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9626 struct expression
*exp
, int *pos
)
9628 struct value
*mark
= value_mark ();
9630 struct type
*lhs_type
= check_typedef (value_type (lhs
));
9632 if (lhs_type
->code () == TYPE_CODE_ARRAY
)
9634 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9635 struct value
*index_val
= value_from_longest (index_type
, index
);
9637 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9641 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9642 elt
= ada_to_fixed_value (elt
);
9645 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9646 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9648 value_assign_to_component (container
, elt
,
9649 ada_evaluate_subexp (NULL
, exp
, pos
,
9652 value_free_to_mark (mark
);
9655 /* Assuming that LHS represents an lvalue having a record or array
9656 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9657 of that aggregate's value to LHS, advancing *POS past the
9658 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9659 lvalue containing LHS (possibly LHS itself). Does not modify
9660 the inferior's memory, nor does it modify the contents of
9661 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9663 static struct value
*
9664 assign_aggregate (struct value
*container
,
9665 struct value
*lhs
, struct expression
*exp
,
9666 int *pos
, enum noside noside
)
9668 struct type
*lhs_type
;
9669 int n
= exp
->elts
[*pos
+1].longconst
;
9670 LONGEST low_index
, high_index
;
9673 int max_indices
, num_indices
;
9677 if (noside
!= EVAL_NORMAL
)
9679 for (i
= 0; i
< n
; i
+= 1)
9680 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9684 container
= ada_coerce_ref (container
);
9685 if (ada_is_direct_array_type (value_type (container
)))
9686 container
= ada_coerce_to_simple_array (container
);
9687 lhs
= ada_coerce_ref (lhs
);
9688 if (!deprecated_value_modifiable (lhs
))
9689 error (_("Left operand of assignment is not a modifiable lvalue."));
9691 lhs_type
= check_typedef (value_type (lhs
));
9692 if (ada_is_direct_array_type (lhs_type
))
9694 lhs
= ada_coerce_to_simple_array (lhs
);
9695 lhs_type
= check_typedef (value_type (lhs
));
9696 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
9697 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
9699 else if (lhs_type
->code () == TYPE_CODE_STRUCT
)
9702 high_index
= num_visible_fields (lhs_type
) - 1;
9705 error (_("Left-hand side must be array or record."));
9707 num_specs
= num_component_specs (exp
, *pos
- 3);
9708 max_indices
= 4 * num_specs
+ 4;
9709 indices
= XALLOCAVEC (LONGEST
, max_indices
);
9710 indices
[0] = indices
[1] = low_index
- 1;
9711 indices
[2] = indices
[3] = high_index
+ 1;
9714 for (i
= 0; i
< n
; i
+= 1)
9716 switch (exp
->elts
[*pos
].opcode
)
9719 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9720 &num_indices
, max_indices
,
9721 low_index
, high_index
);
9724 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9725 &num_indices
, max_indices
,
9726 low_index
, high_index
);
9730 error (_("Misplaced 'others' clause"));
9731 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9732 num_indices
, low_index
, high_index
);
9735 error (_("Internal error: bad aggregate clause"));
9742 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9743 construct at *POS, updating *POS past the construct, given that
9744 the positions are relative to lower bound LOW, where HIGH is the
9745 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9746 updating *NUM_INDICES as needed. CONTAINER is as for
9747 assign_aggregate. */
9749 aggregate_assign_positional (struct value
*container
,
9750 struct value
*lhs
, struct expression
*exp
,
9751 int *pos
, LONGEST
*indices
, int *num_indices
,
9752 int max_indices
, LONGEST low
, LONGEST high
)
9754 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9756 if (ind
- 1 == high
)
9757 warning (_("Extra components in aggregate ignored."));
9760 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
9762 assign_component (container
, lhs
, ind
, exp
, pos
);
9765 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9768 /* Assign into the components of LHS indexed by the OP_CHOICES
9769 construct at *POS, updating *POS past the construct, given that
9770 the allowable indices are LOW..HIGH. Record the indices assigned
9771 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9772 needed. CONTAINER is as for assign_aggregate. */
9774 aggregate_assign_from_choices (struct value
*container
,
9775 struct value
*lhs
, struct expression
*exp
,
9776 int *pos
, LONGEST
*indices
, int *num_indices
,
9777 int max_indices
, LONGEST low
, LONGEST high
)
9780 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9781 int choice_pos
, expr_pc
;
9782 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9784 choice_pos
= *pos
+= 3;
9786 for (j
= 0; j
< n_choices
; j
+= 1)
9787 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9789 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9791 for (j
= 0; j
< n_choices
; j
+= 1)
9793 LONGEST lower
, upper
;
9794 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9796 if (op
== OP_DISCRETE_RANGE
)
9799 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9801 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9806 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9818 name
= &exp
->elts
[choice_pos
+ 2].string
;
9821 name
= exp
->elts
[choice_pos
+ 2].symbol
->natural_name ();
9824 error (_("Invalid record component association."));
9826 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9828 if (! find_struct_field (name
, value_type (lhs
), 0,
9829 NULL
, NULL
, NULL
, NULL
, &ind
))
9830 error (_("Unknown component name: %s."), name
);
9831 lower
= upper
= ind
;
9834 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9835 error (_("Index in component association out of bounds."));
9837 add_component_interval (lower
, upper
, indices
, num_indices
,
9839 while (lower
<= upper
)
9844 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9850 /* Assign the value of the expression in the OP_OTHERS construct in
9851 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9852 have not been previously assigned. The index intervals already assigned
9853 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9854 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9856 aggregate_assign_others (struct value
*container
,
9857 struct value
*lhs
, struct expression
*exp
,
9858 int *pos
, LONGEST
*indices
, int num_indices
,
9859 LONGEST low
, LONGEST high
)
9862 int expr_pc
= *pos
+ 1;
9864 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9868 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9873 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9876 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9879 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9880 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9881 modifying *SIZE as needed. It is an error if *SIZE exceeds
9882 MAX_SIZE. The resulting intervals do not overlap. */
9884 add_component_interval (LONGEST low
, LONGEST high
,
9885 LONGEST
* indices
, int *size
, int max_size
)
9889 for (i
= 0; i
< *size
; i
+= 2) {
9890 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9894 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
9895 if (high
< indices
[kh
])
9897 if (low
< indices
[i
])
9899 indices
[i
+ 1] = indices
[kh
- 1];
9900 if (high
> indices
[i
+ 1])
9901 indices
[i
+ 1] = high
;
9902 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
9903 *size
-= kh
- i
- 2;
9906 else if (high
< indices
[i
])
9910 if (*size
== max_size
)
9911 error (_("Internal error: miscounted aggregate components."));
9913 for (j
= *size
-1; j
>= i
+2; j
-= 1)
9914 indices
[j
] = indices
[j
- 2];
9916 indices
[i
+ 1] = high
;
9919 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9922 static struct value
*
9923 ada_value_cast (struct type
*type
, struct value
*arg2
)
9925 if (type
== ada_check_typedef (value_type (arg2
)))
9928 if (ada_is_gnat_encoded_fixed_point_type (type
))
9929 return cast_to_fixed (type
, arg2
);
9931 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
9932 return cast_from_fixed (type
, arg2
);
9934 return value_cast (type
, arg2
);
9937 /* Evaluating Ada expressions, and printing their result.
9938 ------------------------------------------------------
9943 We usually evaluate an Ada expression in order to print its value.
9944 We also evaluate an expression in order to print its type, which
9945 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9946 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9947 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9948 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9951 Evaluating expressions is a little more complicated for Ada entities
9952 than it is for entities in languages such as C. The main reason for
9953 this is that Ada provides types whose definition might be dynamic.
9954 One example of such types is variant records. Or another example
9955 would be an array whose bounds can only be known at run time.
9957 The following description is a general guide as to what should be
9958 done (and what should NOT be done) in order to evaluate an expression
9959 involving such types, and when. This does not cover how the semantic
9960 information is encoded by GNAT as this is covered separatly. For the
9961 document used as the reference for the GNAT encoding, see exp_dbug.ads
9962 in the GNAT sources.
9964 Ideally, we should embed each part of this description next to its
9965 associated code. Unfortunately, the amount of code is so vast right
9966 now that it's hard to see whether the code handling a particular
9967 situation might be duplicated or not. One day, when the code is
9968 cleaned up, this guide might become redundant with the comments
9969 inserted in the code, and we might want to remove it.
9971 2. ``Fixing'' an Entity, the Simple Case:
9972 -----------------------------------------
9974 When evaluating Ada expressions, the tricky issue is that they may
9975 reference entities whose type contents and size are not statically
9976 known. Consider for instance a variant record:
9978 type Rec (Empty : Boolean := True) is record
9981 when False => Value : Integer;
9984 Yes : Rec := (Empty => False, Value => 1);
9985 No : Rec := (empty => True);
9987 The size and contents of that record depends on the value of the
9988 descriminant (Rec.Empty). At this point, neither the debugging
9989 information nor the associated type structure in GDB are able to
9990 express such dynamic types. So what the debugger does is to create
9991 "fixed" versions of the type that applies to the specific object.
9992 We also informally refer to this operation as "fixing" an object,
9993 which means creating its associated fixed type.
9995 Example: when printing the value of variable "Yes" above, its fixed
9996 type would look like this:
10003 On the other hand, if we printed the value of "No", its fixed type
10010 Things become a little more complicated when trying to fix an entity
10011 with a dynamic type that directly contains another dynamic type,
10012 such as an array of variant records, for instance. There are
10013 two possible cases: Arrays, and records.
10015 3. ``Fixing'' Arrays:
10016 ---------------------
10018 The type structure in GDB describes an array in terms of its bounds,
10019 and the type of its elements. By design, all elements in the array
10020 have the same type and we cannot represent an array of variant elements
10021 using the current type structure in GDB. When fixing an array,
10022 we cannot fix the array element, as we would potentially need one
10023 fixed type per element of the array. As a result, the best we can do
10024 when fixing an array is to produce an array whose bounds and size
10025 are correct (allowing us to read it from memory), but without having
10026 touched its element type. Fixing each element will be done later,
10027 when (if) necessary.
10029 Arrays are a little simpler to handle than records, because the same
10030 amount of memory is allocated for each element of the array, even if
10031 the amount of space actually used by each element differs from element
10032 to element. Consider for instance the following array of type Rec:
10034 type Rec_Array is array (1 .. 2) of Rec;
10036 The actual amount of memory occupied by each element might be different
10037 from element to element, depending on the value of their discriminant.
10038 But the amount of space reserved for each element in the array remains
10039 fixed regardless. So we simply need to compute that size using
10040 the debugging information available, from which we can then determine
10041 the array size (we multiply the number of elements of the array by
10042 the size of each element).
10044 The simplest case is when we have an array of a constrained element
10045 type. For instance, consider the following type declarations:
10047 type Bounded_String (Max_Size : Integer) is
10049 Buffer : String (1 .. Max_Size);
10051 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10053 In this case, the compiler describes the array as an array of
10054 variable-size elements (identified by its XVS suffix) for which
10055 the size can be read in the parallel XVZ variable.
10057 In the case of an array of an unconstrained element type, the compiler
10058 wraps the array element inside a private PAD type. This type should not
10059 be shown to the user, and must be "unwrap"'ed before printing. Note
10060 that we also use the adjective "aligner" in our code to designate
10061 these wrapper types.
10063 In some cases, the size allocated for each element is statically
10064 known. In that case, the PAD type already has the correct size,
10065 and the array element should remain unfixed.
10067 But there are cases when this size is not statically known.
10068 For instance, assuming that "Five" is an integer variable:
10070 type Dynamic is array (1 .. Five) of Integer;
10071 type Wrapper (Has_Length : Boolean := False) is record
10074 when True => Length : Integer;
10075 when False => null;
10078 type Wrapper_Array is array (1 .. 2) of Wrapper;
10080 Hello : Wrapper_Array := (others => (Has_Length => True,
10081 Data => (others => 17),
10085 The debugging info would describe variable Hello as being an
10086 array of a PAD type. The size of that PAD type is not statically
10087 known, but can be determined using a parallel XVZ variable.
10088 In that case, a copy of the PAD type with the correct size should
10089 be used for the fixed array.
10091 3. ``Fixing'' record type objects:
10092 ----------------------------------
10094 Things are slightly different from arrays in the case of dynamic
10095 record types. In this case, in order to compute the associated
10096 fixed type, we need to determine the size and offset of each of
10097 its components. This, in turn, requires us to compute the fixed
10098 type of each of these components.
10100 Consider for instance the example:
10102 type Bounded_String (Max_Size : Natural) is record
10103 Str : String (1 .. Max_Size);
10106 My_String : Bounded_String (Max_Size => 10);
10108 In that case, the position of field "Length" depends on the size
10109 of field Str, which itself depends on the value of the Max_Size
10110 discriminant. In order to fix the type of variable My_String,
10111 we need to fix the type of field Str. Therefore, fixing a variant
10112 record requires us to fix each of its components.
10114 However, if a component does not have a dynamic size, the component
10115 should not be fixed. In particular, fields that use a PAD type
10116 should not fixed. Here is an example where this might happen
10117 (assuming type Rec above):
10119 type Container (Big : Boolean) is record
10123 when True => Another : Integer;
10124 when False => null;
10127 My_Container : Container := (Big => False,
10128 First => (Empty => True),
10131 In that example, the compiler creates a PAD type for component First,
10132 whose size is constant, and then positions the component After just
10133 right after it. The offset of component After is therefore constant
10136 The debugger computes the position of each field based on an algorithm
10137 that uses, among other things, the actual position and size of the field
10138 preceding it. Let's now imagine that the user is trying to print
10139 the value of My_Container. If the type fixing was recursive, we would
10140 end up computing the offset of field After based on the size of the
10141 fixed version of field First. And since in our example First has
10142 only one actual field, the size of the fixed type is actually smaller
10143 than the amount of space allocated to that field, and thus we would
10144 compute the wrong offset of field After.
10146 To make things more complicated, we need to watch out for dynamic
10147 components of variant records (identified by the ___XVL suffix in
10148 the component name). Even if the target type is a PAD type, the size
10149 of that type might not be statically known. So the PAD type needs
10150 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10151 we might end up with the wrong size for our component. This can be
10152 observed with the following type declarations:
10154 type Octal is new Integer range 0 .. 7;
10155 type Octal_Array is array (Positive range <>) of Octal;
10156 pragma Pack (Octal_Array);
10158 type Octal_Buffer (Size : Positive) is record
10159 Buffer : Octal_Array (1 .. Size);
10163 In that case, Buffer is a PAD type whose size is unset and needs
10164 to be computed by fixing the unwrapped type.
10166 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10167 ----------------------------------------------------------
10169 Lastly, when should the sub-elements of an entity that remained unfixed
10170 thus far, be actually fixed?
10172 The answer is: Only when referencing that element. For instance
10173 when selecting one component of a record, this specific component
10174 should be fixed at that point in time. Or when printing the value
10175 of a record, each component should be fixed before its value gets
10176 printed. Similarly for arrays, the element of the array should be
10177 fixed when printing each element of the array, or when extracting
10178 one element out of that array. On the other hand, fixing should
10179 not be performed on the elements when taking a slice of an array!
10181 Note that one of the side effects of miscomputing the offset and
10182 size of each field is that we end up also miscomputing the size
10183 of the containing type. This can have adverse results when computing
10184 the value of an entity. GDB fetches the value of an entity based
10185 on the size of its type, and thus a wrong size causes GDB to fetch
10186 the wrong amount of memory. In the case where the computed size is
10187 too small, GDB fetches too little data to print the value of our
10188 entity. Results in this case are unpredictable, as we usually read
10189 past the buffer containing the data =:-o. */
10191 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10192 for that subexpression cast to TO_TYPE. Advance *POS over the
10196 ada_evaluate_subexp_for_cast (expression
*exp
, int *pos
,
10197 enum noside noside
, struct type
*to_type
)
10201 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
10202 || exp
->elts
[pc
].opcode
== OP_VAR_VALUE
)
10207 if (exp
->elts
[pc
].opcode
== OP_VAR_MSYM_VALUE
)
10209 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10210 return value_zero (to_type
, not_lval
);
10212 val
= evaluate_var_msym_value (noside
,
10213 exp
->elts
[pc
+ 1].objfile
,
10214 exp
->elts
[pc
+ 2].msymbol
);
10217 val
= evaluate_var_value (noside
,
10218 exp
->elts
[pc
+ 1].block
,
10219 exp
->elts
[pc
+ 2].symbol
);
10221 if (noside
== EVAL_SKIP
)
10222 return eval_skip_value (exp
);
10224 val
= ada_value_cast (to_type
, val
);
10226 /* Follow the Ada language semantics that do not allow taking
10227 an address of the result of a cast (view conversion in Ada). */
10228 if (VALUE_LVAL (val
) == lval_memory
)
10230 if (value_lazy (val
))
10231 value_fetch_lazy (val
);
10232 VALUE_LVAL (val
) = not_lval
;
10237 value
*val
= evaluate_subexp (to_type
, exp
, pos
, noside
);
10238 if (noside
== EVAL_SKIP
)
10239 return eval_skip_value (exp
);
10240 return ada_value_cast (to_type
, val
);
10243 /* Implement the evaluate_exp routine in the exp_descriptor structure
10244 for the Ada language. */
10246 static struct value
*
10247 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
10248 int *pos
, enum noside noside
)
10250 enum exp_opcode op
;
10254 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
10257 struct value
**argvec
;
10261 op
= exp
->elts
[pc
].opcode
;
10267 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10269 if (noside
== EVAL_NORMAL
)
10270 arg1
= unwrap_value (arg1
);
10272 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10273 then we need to perform the conversion manually, because
10274 evaluate_subexp_standard doesn't do it. This conversion is
10275 necessary in Ada because the different kinds of float/fixed
10276 types in Ada have different representations.
10278 Similarly, we need to perform the conversion from OP_LONG
10280 if ((op
== OP_FLOAT
|| op
== OP_LONG
) && expect_type
!= NULL
)
10281 arg1
= ada_value_cast (expect_type
, arg1
);
10287 struct value
*result
;
10290 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10291 /* The result type will have code OP_STRING, bashed there from
10292 OP_ARRAY. Bash it back. */
10293 if (value_type (result
)->code () == TYPE_CODE_STRING
)
10294 value_type (result
)->set_code (TYPE_CODE_ARRAY
);
10300 type
= exp
->elts
[pc
+ 1].type
;
10301 return ada_evaluate_subexp_for_cast (exp
, pos
, noside
, type
);
10305 type
= exp
->elts
[pc
+ 1].type
;
10306 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
10309 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10310 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
10312 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
10313 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10315 return ada_value_assign (arg1
, arg1
);
10317 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10318 except if the lhs of our assignment is a convenience variable.
10319 In the case of assigning to a convenience variable, the lhs
10320 should be exactly the result of the evaluation of the rhs. */
10321 type
= value_type (arg1
);
10322 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10324 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
10325 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10327 if (VALUE_LVAL (arg1
) == lval_internalvar
)
10331 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10332 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
10333 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10335 (_("Fixed-point values must be assigned to fixed-point variables"));
10337 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
10338 return ada_value_assign (arg1
, arg2
);
10341 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10342 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10343 if (noside
== EVAL_SKIP
)
10345 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10346 return (value_from_longest
10347 (value_type (arg1
),
10348 value_as_long (arg1
) + value_as_long (arg2
)));
10349 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10350 return (value_from_longest
10351 (value_type (arg2
),
10352 value_as_long (arg1
) + value_as_long (arg2
)));
10353 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10354 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10355 && value_type (arg1
) != value_type (arg2
))
10356 error (_("Operands of fixed-point addition must have the same type"));
10357 /* Do the addition, and cast the result to the type of the first
10358 argument. We cannot cast the result to a reference type, so if
10359 ARG1 is a reference type, find its underlying type. */
10360 type
= value_type (arg1
);
10361 while (type
->code () == TYPE_CODE_REF
)
10362 type
= TYPE_TARGET_TYPE (type
);
10363 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10364 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10367 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10368 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10369 if (noside
== EVAL_SKIP
)
10371 if (value_type (arg1
)->code () == TYPE_CODE_PTR
)
10372 return (value_from_longest
10373 (value_type (arg1
),
10374 value_as_long (arg1
) - value_as_long (arg2
)));
10375 if (value_type (arg2
)->code () == TYPE_CODE_PTR
)
10376 return (value_from_longest
10377 (value_type (arg2
),
10378 value_as_long (arg1
) - value_as_long (arg2
)));
10379 if ((ada_is_gnat_encoded_fixed_point_type (value_type (arg1
))
10380 || ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10381 && value_type (arg1
) != value_type (arg2
))
10382 error (_("Operands of fixed-point subtraction "
10383 "must have the same type"));
10384 /* Do the substraction, and cast the result to the type of the first
10385 argument. We cannot cast the result to a reference type, so if
10386 ARG1 is a reference type, find its underlying type. */
10387 type
= value_type (arg1
);
10388 while (type
->code () == TYPE_CODE_REF
)
10389 type
= TYPE_TARGET_TYPE (type
);
10390 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10391 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10397 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10398 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10399 if (noside
== EVAL_SKIP
)
10401 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10403 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10404 return value_zero (value_type (arg1
), not_lval
);
10408 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10409 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10410 arg1
= cast_from_fixed (type
, arg1
);
10411 if (ada_is_gnat_encoded_fixed_point_type (value_type (arg2
)))
10412 arg2
= cast_from_fixed (type
, arg2
);
10413 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10414 return ada_value_binop (arg1
, arg2
, op
);
10418 case BINOP_NOTEQUAL
:
10419 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10420 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10421 if (noside
== EVAL_SKIP
)
10423 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10427 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10428 tem
= ada_value_equal (arg1
, arg2
);
10430 if (op
== BINOP_NOTEQUAL
)
10432 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10433 return value_from_longest (type
, (LONGEST
) tem
);
10436 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10437 if (noside
== EVAL_SKIP
)
10439 else if (ada_is_gnat_encoded_fixed_point_type (value_type (arg1
)))
10440 return value_cast (value_type (arg1
), value_neg (arg1
));
10443 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10444 return value_neg (arg1
);
10447 case BINOP_LOGICAL_AND
:
10448 case BINOP_LOGICAL_OR
:
10449 case UNOP_LOGICAL_NOT
:
10454 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10455 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10456 return value_cast (type
, val
);
10459 case BINOP_BITWISE_AND
:
10460 case BINOP_BITWISE_IOR
:
10461 case BINOP_BITWISE_XOR
:
10465 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10467 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10469 return value_cast (value_type (arg1
), val
);
10475 if (noside
== EVAL_SKIP
)
10481 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10482 /* Only encountered when an unresolved symbol occurs in a
10483 context other than a function call, in which case, it is
10485 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10486 exp
->elts
[pc
+ 2].symbol
->print_name ());
10488 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10490 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10491 /* Check to see if this is a tagged type. We also need to handle
10492 the case where the type is a reference to a tagged type, but
10493 we have to be careful to exclude pointers to tagged types.
10494 The latter should be shown as usual (as a pointer), whereas
10495 a reference should mostly be transparent to the user. */
10496 if (ada_is_tagged_type (type
, 0)
10497 || (type
->code () == TYPE_CODE_REF
10498 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10500 /* Tagged types are a little special in the fact that the real
10501 type is dynamic and can only be determined by inspecting the
10502 object's tag. This means that we need to get the object's
10503 value first (EVAL_NORMAL) and then extract the actual object
10506 Note that we cannot skip the final step where we extract
10507 the object type from its tag, because the EVAL_NORMAL phase
10508 results in dynamic components being resolved into fixed ones.
10509 This can cause problems when trying to print the type
10510 description of tagged types whose parent has a dynamic size:
10511 We use the type name of the "_parent" component in order
10512 to print the name of the ancestor type in the type description.
10513 If that component had a dynamic size, the resolution into
10514 a fixed type would result in the loss of that type name,
10515 thus preventing us from printing the name of the ancestor
10516 type in the type description. */
10517 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
10519 if (type
->code () != TYPE_CODE_REF
)
10521 struct type
*actual_type
;
10523 actual_type
= type_from_tag (ada_value_tag (arg1
));
10524 if (actual_type
== NULL
)
10525 /* If, for some reason, we were unable to determine
10526 the actual type from the tag, then use the static
10527 approximation that we just computed as a fallback.
10528 This can happen if the debugging information is
10529 incomplete, for instance. */
10530 actual_type
= type
;
10531 return value_zero (actual_type
, not_lval
);
10535 /* In the case of a ref, ada_coerce_ref takes care
10536 of determining the actual type. But the evaluation
10537 should return a ref as it should be valid to ask
10538 for its address; so rebuild a ref after coerce. */
10539 arg1
= ada_coerce_ref (arg1
);
10540 return value_ref (arg1
, TYPE_CODE_REF
);
10544 /* Records and unions for which GNAT encodings have been
10545 generated need to be statically fixed as well.
10546 Otherwise, non-static fixing produces a type where
10547 all dynamic properties are removed, which prevents "ptype"
10548 from being able to completely describe the type.
10549 For instance, a case statement in a variant record would be
10550 replaced by the relevant components based on the actual
10551 value of the discriminants. */
10552 if ((type
->code () == TYPE_CODE_STRUCT
10553 && dynamic_template_type (type
) != NULL
)
10554 || (type
->code () == TYPE_CODE_UNION
10555 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10558 return value_zero (to_static_fixed_type (type
), not_lval
);
10562 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10563 return ada_to_fixed_value (arg1
);
10568 /* Allocate arg vector, including space for the function to be
10569 called in argvec[0] and a terminating NULL. */
10570 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10571 argvec
= XALLOCAVEC (struct value
*, nargs
+ 2);
10573 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10574 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10575 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10576 exp
->elts
[pc
+ 5].symbol
->print_name ());
10579 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10580 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10583 if (noside
== EVAL_SKIP
)
10587 if (ada_is_constrained_packed_array_type
10588 (desc_base_type (value_type (argvec
[0]))))
10589 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10590 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10591 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10592 /* This is a packed array that has already been fixed, and
10593 therefore already coerced to a simple array. Nothing further
10596 else if (value_type (argvec
[0])->code () == TYPE_CODE_REF
)
10598 /* Make sure we dereference references so that all the code below
10599 feels like it's really handling the referenced value. Wrapping
10600 types (for alignment) may be there, so make sure we strip them as
10602 argvec
[0] = ada_to_fixed_value (coerce_ref (argvec
[0]));
10604 else if (value_type (argvec
[0])->code () == TYPE_CODE_ARRAY
10605 && VALUE_LVAL (argvec
[0]) == lval_memory
)
10606 argvec
[0] = value_addr (argvec
[0]);
10608 type
= ada_check_typedef (value_type (argvec
[0]));
10610 /* Ada allows us to implicitly dereference arrays when subscripting
10611 them. So, if this is an array typedef (encoding use for array
10612 access types encoded as fat pointers), strip it now. */
10613 if (type
->code () == TYPE_CODE_TYPEDEF
)
10614 type
= ada_typedef_target_type (type
);
10616 if (type
->code () == TYPE_CODE_PTR
)
10618 switch (ada_check_typedef (TYPE_TARGET_TYPE (type
))->code ())
10620 case TYPE_CODE_FUNC
:
10621 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10623 case TYPE_CODE_ARRAY
:
10625 case TYPE_CODE_STRUCT
:
10626 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10627 argvec
[0] = ada_value_ind (argvec
[0]);
10628 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10631 error (_("cannot subscript or call something of type `%s'"),
10632 ada_type_name (value_type (argvec
[0])));
10637 switch (type
->code ())
10639 case TYPE_CODE_FUNC
:
10640 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10642 if (TYPE_TARGET_TYPE (type
) == NULL
)
10643 error_call_unknown_return_type (NULL
);
10644 return allocate_value (TYPE_TARGET_TYPE (type
));
10646 return call_function_by_hand (argvec
[0], NULL
,
10647 gdb::make_array_view (argvec
+ 1,
10649 case TYPE_CODE_INTERNAL_FUNCTION
:
10650 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10651 /* We don't know anything about what the internal
10652 function might return, but we have to return
10654 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10657 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10658 argvec
[0], nargs
, argvec
+ 1);
10660 case TYPE_CODE_STRUCT
:
10664 arity
= ada_array_arity (type
);
10665 type
= ada_array_element_type (type
, nargs
);
10667 error (_("cannot subscript or call a record"));
10668 if (arity
!= nargs
)
10669 error (_("wrong number of subscripts; expecting %d"), arity
);
10670 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10671 return value_zero (ada_aligned_type (type
), lval_memory
);
10673 unwrap_value (ada_value_subscript
10674 (argvec
[0], nargs
, argvec
+ 1));
10676 case TYPE_CODE_ARRAY
:
10677 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10679 type
= ada_array_element_type (type
, nargs
);
10681 error (_("element type of array unknown"));
10683 return value_zero (ada_aligned_type (type
), lval_memory
);
10686 unwrap_value (ada_value_subscript
10687 (ada_coerce_to_simple_array (argvec
[0]),
10688 nargs
, argvec
+ 1));
10689 case TYPE_CODE_PTR
: /* Pointer to array */
10690 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10692 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10693 type
= ada_array_element_type (type
, nargs
);
10695 error (_("element type of array unknown"));
10697 return value_zero (ada_aligned_type (type
), lval_memory
);
10700 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10701 nargs
, argvec
+ 1));
10704 error (_("Attempt to index or call something other than an "
10705 "array or function"));
10710 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10711 struct value
*low_bound_val
=
10712 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10713 struct value
*high_bound_val
=
10714 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10716 LONGEST high_bound
;
10718 low_bound_val
= coerce_ref (low_bound_val
);
10719 high_bound_val
= coerce_ref (high_bound_val
);
10720 low_bound
= value_as_long (low_bound_val
);
10721 high_bound
= value_as_long (high_bound_val
);
10723 if (noside
== EVAL_SKIP
)
10726 /* If this is a reference to an aligner type, then remove all
10728 if (value_type (array
)->code () == TYPE_CODE_REF
10729 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10730 TYPE_TARGET_TYPE (value_type (array
)) =
10731 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10733 if (ada_is_constrained_packed_array_type (value_type (array
)))
10734 error (_("cannot slice a packed array"));
10736 /* If this is a reference to an array or an array lvalue,
10737 convert to a pointer. */
10738 if (value_type (array
)->code () == TYPE_CODE_REF
10739 || (value_type (array
)->code () == TYPE_CODE_ARRAY
10740 && VALUE_LVAL (array
) == lval_memory
))
10741 array
= value_addr (array
);
10743 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10744 && ada_is_array_descriptor_type (ada_check_typedef
10745 (value_type (array
))))
10746 return empty_array (ada_type_of_array (array
, 0), low_bound
,
10749 array
= ada_coerce_to_simple_array_ptr (array
);
10751 /* If we have more than one level of pointer indirection,
10752 dereference the value until we get only one level. */
10753 while (value_type (array
)->code () == TYPE_CODE_PTR
10754 && (TYPE_TARGET_TYPE (value_type (array
))->code ()
10756 array
= value_ind (array
);
10758 /* Make sure we really do have an array type before going further,
10759 to avoid a SEGV when trying to get the index type or the target
10760 type later down the road if the debug info generated by
10761 the compiler is incorrect or incomplete. */
10762 if (!ada_is_simple_array_type (value_type (array
)))
10763 error (_("cannot take slice of non-array"));
10765 if (ada_check_typedef (value_type (array
))->code ()
10768 struct type
*type0
= ada_check_typedef (value_type (array
));
10770 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10771 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
, high_bound
);
10774 struct type
*arr_type0
=
10775 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10777 return ada_value_slice_from_ptr (array
, arr_type0
,
10778 longest_to_int (low_bound
),
10779 longest_to_int (high_bound
));
10782 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10784 else if (high_bound
< low_bound
)
10785 return empty_array (value_type (array
), low_bound
, high_bound
);
10787 return ada_value_slice (array
, longest_to_int (low_bound
),
10788 longest_to_int (high_bound
));
10791 case UNOP_IN_RANGE
:
10793 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10794 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10796 if (noside
== EVAL_SKIP
)
10799 switch (type
->code ())
10802 lim_warning (_("Membership test incompletely implemented; "
10803 "always returns true"));
10804 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10805 return value_from_longest (type
, (LONGEST
) 1);
10807 case TYPE_CODE_RANGE
:
10808 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
10809 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
10810 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10811 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10812 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10814 value_from_longest (type
,
10815 (value_less (arg1
, arg3
)
10816 || value_equal (arg1
, arg3
))
10817 && (value_less (arg2
, arg1
)
10818 || value_equal (arg2
, arg1
)));
10821 case BINOP_IN_BOUNDS
:
10823 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10824 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10826 if (noside
== EVAL_SKIP
)
10829 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10831 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10832 return value_zero (type
, not_lval
);
10835 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10837 type
= ada_index_type (value_type (arg2
), tem
, "range");
10839 type
= value_type (arg1
);
10841 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10842 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10844 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10845 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10846 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10848 value_from_longest (type
,
10849 (value_less (arg1
, arg3
)
10850 || value_equal (arg1
, arg3
))
10851 && (value_less (arg2
, arg1
)
10852 || value_equal (arg2
, arg1
)));
10854 case TERNOP_IN_RANGE
:
10855 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10856 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10857 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10859 if (noside
== EVAL_SKIP
)
10862 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10863 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10864 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10866 value_from_longest (type
,
10867 (value_less (arg1
, arg3
)
10868 || value_equal (arg1
, arg3
))
10869 && (value_less (arg2
, arg1
)
10870 || value_equal (arg2
, arg1
)));
10874 case OP_ATR_LENGTH
:
10876 struct type
*type_arg
;
10878 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10880 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10882 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10886 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10890 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10891 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10892 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10895 if (noside
== EVAL_SKIP
)
10897 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10899 if (type_arg
== NULL
)
10900 type_arg
= value_type (arg1
);
10902 if (ada_is_constrained_packed_array_type (type_arg
))
10903 type_arg
= decode_constrained_packed_array_type (type_arg
);
10905 if (!discrete_type_p (type_arg
))
10909 default: /* Should never happen. */
10910 error (_("unexpected attribute encountered"));
10913 type_arg
= ada_index_type (type_arg
, tem
,
10914 ada_attribute_name (op
));
10916 case OP_ATR_LENGTH
:
10917 type_arg
= builtin_type (exp
->gdbarch
)->builtin_int
;
10922 return value_zero (type_arg
, not_lval
);
10924 else if (type_arg
== NULL
)
10926 arg1
= ada_coerce_ref (arg1
);
10928 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10929 arg1
= ada_coerce_to_simple_array (arg1
);
10931 if (op
== OP_ATR_LENGTH
)
10932 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10935 type
= ada_index_type (value_type (arg1
), tem
,
10936 ada_attribute_name (op
));
10938 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10943 default: /* Should never happen. */
10944 error (_("unexpected attribute encountered"));
10946 return value_from_longest
10947 (type
, ada_array_bound (arg1
, tem
, 0));
10949 return value_from_longest
10950 (type
, ada_array_bound (arg1
, tem
, 1));
10951 case OP_ATR_LENGTH
:
10952 return value_from_longest
10953 (type
, ada_array_length (arg1
, tem
));
10956 else if (discrete_type_p (type_arg
))
10958 struct type
*range_type
;
10959 const char *name
= ada_type_name (type_arg
);
10962 if (name
!= NULL
&& type_arg
->code () != TYPE_CODE_ENUM
)
10963 range_type
= to_fixed_range_type (type_arg
, NULL
);
10964 if (range_type
== NULL
)
10965 range_type
= type_arg
;
10969 error (_("unexpected attribute encountered"));
10971 return value_from_longest
10972 (range_type
, ada_discrete_type_low_bound (range_type
));
10974 return value_from_longest
10975 (range_type
, ada_discrete_type_high_bound (range_type
));
10976 case OP_ATR_LENGTH
:
10977 error (_("the 'length attribute applies only to array types"));
10980 else if (type_arg
->code () == TYPE_CODE_FLT
)
10981 error (_("unimplemented type attribute"));
10986 if (ada_is_constrained_packed_array_type (type_arg
))
10987 type_arg
= decode_constrained_packed_array_type (type_arg
);
10989 if (op
== OP_ATR_LENGTH
)
10990 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10993 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10995 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11001 error (_("unexpected attribute encountered"));
11003 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
11004 return value_from_longest (type
, low
);
11006 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
11007 return value_from_longest (type
, high
);
11008 case OP_ATR_LENGTH
:
11009 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
11010 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
11011 return value_from_longest (type
, high
- low
+ 1);
11017 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11018 if (noside
== EVAL_SKIP
)
11021 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11022 return value_zero (ada_tag_type (arg1
), not_lval
);
11024 return ada_value_tag (arg1
);
11028 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11029 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11030 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11031 if (noside
== EVAL_SKIP
)
11033 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11034 return value_zero (value_type (arg1
), not_lval
);
11037 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11038 return value_binop (arg1
, arg2
,
11039 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
11042 case OP_ATR_MODULUS
:
11044 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
11046 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11047 if (noside
== EVAL_SKIP
)
11050 if (!ada_is_modular_type (type_arg
))
11051 error (_("'modulus must be applied to modular type"));
11053 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
11054 ada_modulus (type_arg
));
11059 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11060 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11061 if (noside
== EVAL_SKIP
)
11063 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
11064 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11065 return value_zero (type
, not_lval
);
11067 return value_pos_atr (type
, arg1
);
11070 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11071 type
= value_type (arg1
);
11073 /* If the argument is a reference, then dereference its type, since
11074 the user is really asking for the size of the actual object,
11075 not the size of the pointer. */
11076 if (type
->code () == TYPE_CODE_REF
)
11077 type
= TYPE_TARGET_TYPE (type
);
11079 if (noside
== EVAL_SKIP
)
11081 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11082 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
11084 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
11085 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
11088 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
11089 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11090 type
= exp
->elts
[pc
+ 2].type
;
11091 if (noside
== EVAL_SKIP
)
11093 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11094 return value_zero (type
, not_lval
);
11096 return value_val_atr (type
, arg1
);
11099 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11100 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11101 if (noside
== EVAL_SKIP
)
11103 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11104 return value_zero (value_type (arg1
), not_lval
);
11107 /* For integer exponentiation operations,
11108 only promote the first argument. */
11109 if (is_integral_type (value_type (arg2
)))
11110 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11112 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
11114 return value_binop (arg1
, arg2
, op
);
11118 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11119 if (noside
== EVAL_SKIP
)
11125 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11126 if (noside
== EVAL_SKIP
)
11128 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
11129 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
11130 return value_neg (arg1
);
11135 preeval_pos
= *pos
;
11136 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11137 if (noside
== EVAL_SKIP
)
11139 type
= ada_check_typedef (value_type (arg1
));
11140 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11142 if (ada_is_array_descriptor_type (type
))
11143 /* GDB allows dereferencing GNAT array descriptors. */
11145 struct type
*arrType
= ada_type_of_array (arg1
, 0);
11147 if (arrType
== NULL
)
11148 error (_("Attempt to dereference null array pointer."));
11149 return value_at_lazy (arrType
, 0);
11151 else if (type
->code () == TYPE_CODE_PTR
11152 || type
->code () == TYPE_CODE_REF
11153 /* In C you can dereference an array to get the 1st elt. */
11154 || type
->code () == TYPE_CODE_ARRAY
)
11156 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11157 only be determined by inspecting the object's tag.
11158 This means that we need to evaluate completely the
11159 expression in order to get its type. */
11161 if ((type
->code () == TYPE_CODE_REF
11162 || type
->code () == TYPE_CODE_PTR
)
11163 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
11165 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11167 type
= value_type (ada_value_ind (arg1
));
11171 type
= to_static_fixed_type
11173 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
11175 ada_ensure_varsize_limit (type
);
11176 return value_zero (type
, lval_memory
);
11178 else if (type
->code () == TYPE_CODE_INT
)
11180 /* GDB allows dereferencing an int. */
11181 if (expect_type
== NULL
)
11182 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
11187 to_static_fixed_type (ada_aligned_type (expect_type
));
11188 return value_zero (expect_type
, lval_memory
);
11192 error (_("Attempt to take contents of a non-pointer value."));
11194 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
11195 type
= ada_check_typedef (value_type (arg1
));
11197 if (type
->code () == TYPE_CODE_INT
)
11198 /* GDB allows dereferencing an int. If we were given
11199 the expect_type, then use that as the target type.
11200 Otherwise, assume that the target type is an int. */
11202 if (expect_type
!= NULL
)
11203 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
11206 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
11207 (CORE_ADDR
) value_as_address (arg1
));
11210 if (ada_is_array_descriptor_type (type
))
11211 /* GDB allows dereferencing GNAT array descriptors. */
11212 return ada_coerce_to_simple_array (arg1
);
11214 return ada_value_ind (arg1
);
11216 case STRUCTOP_STRUCT
:
11217 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11218 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
11219 preeval_pos
= *pos
;
11220 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
11221 if (noside
== EVAL_SKIP
)
11223 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11225 struct type
*type1
= value_type (arg1
);
11227 if (ada_is_tagged_type (type1
, 1))
11229 type
= ada_lookup_struct_elt_type (type1
,
11230 &exp
->elts
[pc
+ 2].string
,
11233 /* If the field is not found, check if it exists in the
11234 extension of this object's type. This means that we
11235 need to evaluate completely the expression. */
11239 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
11241 arg1
= ada_value_struct_elt (arg1
,
11242 &exp
->elts
[pc
+ 2].string
,
11244 arg1
= unwrap_value (arg1
);
11245 type
= value_type (ada_to_fixed_value (arg1
));
11250 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
11253 return value_zero (ada_aligned_type (type
), lval_memory
);
11257 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
11258 arg1
= unwrap_value (arg1
);
11259 return ada_to_fixed_value (arg1
);
11263 /* The value is not supposed to be used. This is here to make it
11264 easier to accommodate expressions that contain types. */
11266 if (noside
== EVAL_SKIP
)
11268 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
11269 return allocate_value (exp
->elts
[pc
+ 1].type
);
11271 error (_("Attempt to use a type name as an expression"));
11276 case OP_DISCRETE_RANGE
:
11277 case OP_POSITIONAL
:
11279 if (noside
== EVAL_NORMAL
)
11283 error (_("Undefined name, ambiguous name, or renaming used in "
11284 "component association: %s."), &exp
->elts
[pc
+2].string
);
11286 error (_("Aggregates only allowed on the right of an assignment"));
11288 internal_error (__FILE__
, __LINE__
,
11289 _("aggregate apparently mangled"));
11292 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11294 for (tem
= 0; tem
< nargs
; tem
+= 1)
11295 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
11300 return eval_skip_value (exp
);
11306 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11307 type name that encodes the 'small and 'delta information.
11308 Otherwise, return NULL. */
11310 static const char *
11311 gnat_encoded_fixed_type_info (struct type
*type
)
11313 const char *name
= ada_type_name (type
);
11314 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: type
->code ();
11316 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
11318 const char *tail
= strstr (name
, "___XF_");
11325 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
11326 return gnat_encoded_fixed_type_info (TYPE_TARGET_TYPE (type
));
11331 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11334 ada_is_gnat_encoded_fixed_point_type (struct type
*type
)
11336 return gnat_encoded_fixed_type_info (type
) != NULL
;
11339 /* Return non-zero iff TYPE represents a System.Address type. */
11342 ada_is_system_address_type (struct type
*type
)
11344 return (type
->name () && strcmp (type
->name (), "system__address") == 0);
11347 /* Assuming that TYPE is the representation of an Ada fixed-point
11348 type, return the target floating-point type to be used to represent
11349 of this type during internal computation. */
11351 static struct type
*
11352 ada_scaling_type (struct type
*type
)
11354 return builtin_type (get_type_arch (type
))->builtin_long_double
;
11357 /* Assuming that TYPE is the representation of an Ada fixed-point
11358 type, return its delta, or NULL if the type is malformed and the
11359 delta cannot be determined. */
11362 gnat_encoded_fixed_point_delta (struct type
*type
)
11364 const char *encoding
= gnat_encoded_fixed_type_info (type
);
11365 struct type
*scale_type
= ada_scaling_type (type
);
11367 long long num
, den
;
11369 if (sscanf (encoding
, "_%lld_%lld", &num
, &den
) < 2)
11372 return value_binop (value_from_longest (scale_type
, num
),
11373 value_from_longest (scale_type
, den
), BINOP_DIV
);
11376 /* Assuming that ada_is_gnat_encoded_fixed_point_type (TYPE), return
11377 the scaling factor ('SMALL value) associated with the type. */
11380 ada_scaling_factor (struct type
*type
)
11382 const char *encoding
= gnat_encoded_fixed_type_info (type
);
11383 struct type
*scale_type
= ada_scaling_type (type
);
11385 long long num0
, den0
, num1
, den1
;
11388 n
= sscanf (encoding
, "_%lld_%lld_%lld_%lld",
11389 &num0
, &den0
, &num1
, &den1
);
11392 return value_from_longest (scale_type
, 1);
11394 return value_binop (value_from_longest (scale_type
, num1
),
11395 value_from_longest (scale_type
, den1
), BINOP_DIV
);
11397 return value_binop (value_from_longest (scale_type
, num0
),
11398 value_from_longest (scale_type
, den0
), BINOP_DIV
);
11405 /* Scan STR beginning at position K for a discriminant name, and
11406 return the value of that discriminant field of DVAL in *PX. If
11407 PNEW_K is not null, put the position of the character beyond the
11408 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11409 not alter *PX and *PNEW_K if unsuccessful. */
11412 scan_discrim_bound (const char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11415 static char *bound_buffer
= NULL
;
11416 static size_t bound_buffer_len
= 0;
11417 const char *pstart
, *pend
, *bound
;
11418 struct value
*bound_val
;
11420 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11424 pend
= strstr (pstart
, "__");
11428 k
+= strlen (bound
);
11432 int len
= pend
- pstart
;
11434 /* Strip __ and beyond. */
11435 GROW_VECT (bound_buffer
, bound_buffer_len
, len
+ 1);
11436 strncpy (bound_buffer
, pstart
, len
);
11437 bound_buffer
[len
] = '\0';
11439 bound
= bound_buffer
;
11443 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11444 if (bound_val
== NULL
)
11447 *px
= value_as_long (bound_val
);
11448 if (pnew_k
!= NULL
)
11453 /* Value of variable named NAME in the current environment. If
11454 no such variable found, then if ERR_MSG is null, returns 0, and
11455 otherwise causes an error with message ERR_MSG. */
11457 static struct value
*
11458 get_var_value (const char *name
, const char *err_msg
)
11460 lookup_name_info
lookup_name (name
, symbol_name_match_type::FULL
);
11462 std::vector
<struct block_symbol
> syms
;
11463 int nsyms
= ada_lookup_symbol_list_worker (lookup_name
,
11464 get_selected_block (0),
11465 VAR_DOMAIN
, &syms
, 1);
11469 if (err_msg
== NULL
)
11472 error (("%s"), err_msg
);
11475 return value_of_variable (syms
[0].symbol
, syms
[0].block
);
11478 /* Value of integer variable named NAME in the current environment.
11479 If no such variable is found, returns false. Otherwise, sets VALUE
11480 to the variable's value and returns true. */
11483 get_int_var_value (const char *name
, LONGEST
&value
)
11485 struct value
*var_val
= get_var_value (name
, 0);
11490 value
= value_as_long (var_val
);
11495 /* Return a range type whose base type is that of the range type named
11496 NAME in the current environment, and whose bounds are calculated
11497 from NAME according to the GNAT range encoding conventions.
11498 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11499 corresponding range type from debug information; fall back to using it
11500 if symbol lookup fails. If a new type must be created, allocate it
11501 like ORIG_TYPE was. The bounds information, in general, is encoded
11502 in NAME, the base type given in the named range type. */
11504 static struct type
*
11505 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11508 struct type
*base_type
;
11509 const char *subtype_info
;
11511 gdb_assert (raw_type
!= NULL
);
11512 gdb_assert (raw_type
->name () != NULL
);
11514 if (raw_type
->code () == TYPE_CODE_RANGE
)
11515 base_type
= TYPE_TARGET_TYPE (raw_type
);
11517 base_type
= raw_type
;
11519 name
= raw_type
->name ();
11520 subtype_info
= strstr (name
, "___XD");
11521 if (subtype_info
== NULL
)
11523 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11524 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11526 if (L
< INT_MIN
|| U
> INT_MAX
)
11529 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11534 static char *name_buf
= NULL
;
11535 static size_t name_len
= 0;
11536 int prefix_len
= subtype_info
- name
;
11539 const char *bounds_str
;
11542 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11543 strncpy (name_buf
, name
, prefix_len
);
11544 name_buf
[prefix_len
] = '\0';
11547 bounds_str
= strchr (subtype_info
, '_');
11550 if (*subtype_info
== 'L')
11552 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11553 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11555 if (bounds_str
[n
] == '_')
11557 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11563 strcpy (name_buf
+ prefix_len
, "___L");
11564 if (!get_int_var_value (name_buf
, L
))
11566 lim_warning (_("Unknown lower bound, using 1."));
11571 if (*subtype_info
== 'U')
11573 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11574 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11579 strcpy (name_buf
+ prefix_len
, "___U");
11580 if (!get_int_var_value (name_buf
, U
))
11582 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11587 type
= create_static_range_type (alloc_type_copy (raw_type
),
11589 /* create_static_range_type alters the resulting type's length
11590 to match the size of the base_type, which is not what we want.
11591 Set it back to the original range type's length. */
11592 TYPE_LENGTH (type
) = TYPE_LENGTH (raw_type
);
11593 type
->set_name (name
);
11598 /* True iff NAME is the name of a range type. */
11601 ada_is_range_type_name (const char *name
)
11603 return (name
!= NULL
&& strstr (name
, "___XD"));
11607 /* Modular types */
11609 /* True iff TYPE is an Ada modular type. */
11612 ada_is_modular_type (struct type
*type
)
11614 struct type
*subranged_type
= get_base_type (type
);
11616 return (subranged_type
!= NULL
&& type
->code () == TYPE_CODE_RANGE
11617 && subranged_type
->code () == TYPE_CODE_INT
11618 && TYPE_UNSIGNED (subranged_type
));
11621 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11624 ada_modulus (struct type
*type
)
11626 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
11630 /* Ada exception catchpoint support:
11631 ---------------------------------
11633 We support 3 kinds of exception catchpoints:
11634 . catchpoints on Ada exceptions
11635 . catchpoints on unhandled Ada exceptions
11636 . catchpoints on failed assertions
11638 Exceptions raised during failed assertions, or unhandled exceptions
11639 could perfectly be caught with the general catchpoint on Ada exceptions.
11640 However, we can easily differentiate these two special cases, and having
11641 the option to distinguish these two cases from the rest can be useful
11642 to zero-in on certain situations.
11644 Exception catchpoints are a specialized form of breakpoint,
11645 since they rely on inserting breakpoints inside known routines
11646 of the GNAT runtime. The implementation therefore uses a standard
11647 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11650 Support in the runtime for exception catchpoints have been changed
11651 a few times already, and these changes affect the implementation
11652 of these catchpoints. In order to be able to support several
11653 variants of the runtime, we use a sniffer that will determine
11654 the runtime variant used by the program being debugged. */
11656 /* Ada's standard exceptions.
11658 The Ada 83 standard also defined Numeric_Error. But there so many
11659 situations where it was unclear from the Ada 83 Reference Manual
11660 (RM) whether Constraint_Error or Numeric_Error should be raised,
11661 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11662 Interpretation saying that anytime the RM says that Numeric_Error
11663 should be raised, the implementation may raise Constraint_Error.
11664 Ada 95 went one step further and pretty much removed Numeric_Error
11665 from the list of standard exceptions (it made it a renaming of
11666 Constraint_Error, to help preserve compatibility when compiling
11667 an Ada83 compiler). As such, we do not include Numeric_Error from
11668 this list of standard exceptions. */
11670 static const char *standard_exc
[] = {
11671 "constraint_error",
11677 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11679 /* A structure that describes how to support exception catchpoints
11680 for a given executable. */
11682 struct exception_support_info
11684 /* The name of the symbol to break on in order to insert
11685 a catchpoint on exceptions. */
11686 const char *catch_exception_sym
;
11688 /* The name of the symbol to break on in order to insert
11689 a catchpoint on unhandled exceptions. */
11690 const char *catch_exception_unhandled_sym
;
11692 /* The name of the symbol to break on in order to insert
11693 a catchpoint on failed assertions. */
11694 const char *catch_assert_sym
;
11696 /* The name of the symbol to break on in order to insert
11697 a catchpoint on exception handling. */
11698 const char *catch_handlers_sym
;
11700 /* Assuming that the inferior just triggered an unhandled exception
11701 catchpoint, this function is responsible for returning the address
11702 in inferior memory where the name of that exception is stored.
11703 Return zero if the address could not be computed. */
11704 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11707 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11708 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11710 /* The following exception support info structure describes how to
11711 implement exception catchpoints with the latest version of the
11712 Ada runtime (as of 2019-08-??). */
11714 static const struct exception_support_info default_exception_support_info
=
11716 "__gnat_debug_raise_exception", /* catch_exception_sym */
11717 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11718 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11719 "__gnat_begin_handler_v1", /* catch_handlers_sym */
11720 ada_unhandled_exception_name_addr
11723 /* The following exception support info structure describes how to
11724 implement exception catchpoints with an earlier version of the
11725 Ada runtime (as of 2007-03-06) using v0 of the EH ABI. */
11727 static const struct exception_support_info exception_support_info_v0
=
11729 "__gnat_debug_raise_exception", /* catch_exception_sym */
11730 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11731 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11732 "__gnat_begin_handler", /* catch_handlers_sym */
11733 ada_unhandled_exception_name_addr
11736 /* The following exception support info structure describes how to
11737 implement exception catchpoints with a slightly older version
11738 of the Ada runtime. */
11740 static const struct exception_support_info exception_support_info_fallback
=
11742 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11743 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11744 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11745 "__gnat_begin_handler", /* catch_handlers_sym */
11746 ada_unhandled_exception_name_addr_from_raise
11749 /* Return nonzero if we can detect the exception support routines
11750 described in EINFO.
11752 This function errors out if an abnormal situation is detected
11753 (for instance, if we find the exception support routines, but
11754 that support is found to be incomplete). */
11757 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11759 struct symbol
*sym
;
11761 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11762 that should be compiled with debugging information. As a result, we
11763 expect to find that symbol in the symtabs. */
11765 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11768 /* Perhaps we did not find our symbol because the Ada runtime was
11769 compiled without debugging info, or simply stripped of it.
11770 It happens on some GNU/Linux distributions for instance, where
11771 users have to install a separate debug package in order to get
11772 the runtime's debugging info. In that situation, let the user
11773 know why we cannot insert an Ada exception catchpoint.
11775 Note: Just for the purpose of inserting our Ada exception
11776 catchpoint, we could rely purely on the associated minimal symbol.
11777 But we would be operating in degraded mode anyway, since we are
11778 still lacking the debugging info needed later on to extract
11779 the name of the exception being raised (this name is printed in
11780 the catchpoint message, and is also used when trying to catch
11781 a specific exception). We do not handle this case for now. */
11782 struct bound_minimal_symbol msym
11783 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11785 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11786 error (_("Your Ada runtime appears to be missing some debugging "
11787 "information.\nCannot insert Ada exception catchpoint "
11788 "in this configuration."));
11793 /* Make sure that the symbol we found corresponds to a function. */
11795 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11797 error (_("Symbol \"%s\" is not a function (class = %d)"),
11798 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11802 sym
= standard_lookup (einfo
->catch_handlers_sym
, NULL
, VAR_DOMAIN
);
11805 struct bound_minimal_symbol msym
11806 = lookup_minimal_symbol (einfo
->catch_handlers_sym
, NULL
, NULL
);
11808 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11809 error (_("Your Ada runtime appears to be missing some debugging "
11810 "information.\nCannot insert Ada exception catchpoint "
11811 "in this configuration."));
11816 /* Make sure that the symbol we found corresponds to a function. */
11818 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11820 error (_("Symbol \"%s\" is not a function (class = %d)"),
11821 sym
->linkage_name (), SYMBOL_CLASS (sym
));
11828 /* Inspect the Ada runtime and determine which exception info structure
11829 should be used to provide support for exception catchpoints.
11831 This function will always set the per-inferior exception_info,
11832 or raise an error. */
11835 ada_exception_support_info_sniffer (void)
11837 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11839 /* If the exception info is already known, then no need to recompute it. */
11840 if (data
->exception_info
!= NULL
)
11843 /* Check the latest (default) exception support info. */
11844 if (ada_has_this_exception_support (&default_exception_support_info
))
11846 data
->exception_info
= &default_exception_support_info
;
11850 /* Try the v0 exception suport info. */
11851 if (ada_has_this_exception_support (&exception_support_info_v0
))
11853 data
->exception_info
= &exception_support_info_v0
;
11857 /* Try our fallback exception suport info. */
11858 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11860 data
->exception_info
= &exception_support_info_fallback
;
11864 /* Sometimes, it is normal for us to not be able to find the routine
11865 we are looking for. This happens when the program is linked with
11866 the shared version of the GNAT runtime, and the program has not been
11867 started yet. Inform the user of these two possible causes if
11870 if (ada_update_initial_language (language_unknown
) != language_ada
)
11871 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11873 /* If the symbol does not exist, then check that the program is
11874 already started, to make sure that shared libraries have been
11875 loaded. If it is not started, this may mean that the symbol is
11876 in a shared library. */
11878 if (inferior_ptid
.pid () == 0)
11879 error (_("Unable to insert catchpoint. Try to start the program first."));
11881 /* At this point, we know that we are debugging an Ada program and
11882 that the inferior has been started, but we still are not able to
11883 find the run-time symbols. That can mean that we are in
11884 configurable run time mode, or that a-except as been optimized
11885 out by the linker... In any case, at this point it is not worth
11886 supporting this feature. */
11888 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11891 /* True iff FRAME is very likely to be that of a function that is
11892 part of the runtime system. This is all very heuristic, but is
11893 intended to be used as advice as to what frames are uninteresting
11897 is_known_support_routine (struct frame_info
*frame
)
11899 enum language func_lang
;
11901 const char *fullname
;
11903 /* If this code does not have any debugging information (no symtab),
11904 This cannot be any user code. */
11906 symtab_and_line sal
= find_frame_sal (frame
);
11907 if (sal
.symtab
== NULL
)
11910 /* If there is a symtab, but the associated source file cannot be
11911 located, then assume this is not user code: Selecting a frame
11912 for which we cannot display the code would not be very helpful
11913 for the user. This should also take care of case such as VxWorks
11914 where the kernel has some debugging info provided for a few units. */
11916 fullname
= symtab_to_fullname (sal
.symtab
);
11917 if (access (fullname
, R_OK
) != 0)
11920 /* Check the unit filename against the Ada runtime file naming.
11921 We also check the name of the objfile against the name of some
11922 known system libraries that sometimes come with debugging info
11925 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11927 re_comp (known_runtime_file_name_patterns
[i
]);
11928 if (re_exec (lbasename (sal
.symtab
->filename
)))
11930 if (SYMTAB_OBJFILE (sal
.symtab
) != NULL
11931 && re_exec (objfile_name (SYMTAB_OBJFILE (sal
.symtab
))))
11935 /* Check whether the function is a GNAT-generated entity. */
11937 gdb::unique_xmalloc_ptr
<char> func_name
11938 = find_frame_funname (frame
, &func_lang
, NULL
);
11939 if (func_name
== NULL
)
11942 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11944 re_comp (known_auxiliary_function_name_patterns
[i
]);
11945 if (re_exec (func_name
.get ()))
11952 /* Find the first frame that contains debugging information and that is not
11953 part of the Ada run-time, starting from FI and moving upward. */
11956 ada_find_printable_frame (struct frame_info
*fi
)
11958 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11960 if (!is_known_support_routine (fi
))
11969 /* Assuming that the inferior just triggered an unhandled exception
11970 catchpoint, return the address in inferior memory where the name
11971 of the exception is stored.
11973 Return zero if the address could not be computed. */
11976 ada_unhandled_exception_name_addr (void)
11978 return parse_and_eval_address ("e.full_name");
11981 /* Same as ada_unhandled_exception_name_addr, except that this function
11982 should be used when the inferior uses an older version of the runtime,
11983 where the exception name needs to be extracted from a specific frame
11984 several frames up in the callstack. */
11987 ada_unhandled_exception_name_addr_from_raise (void)
11990 struct frame_info
*fi
;
11991 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11993 /* To determine the name of this exception, we need to select
11994 the frame corresponding to RAISE_SYM_NAME. This frame is
11995 at least 3 levels up, so we simply skip the first 3 frames
11996 without checking the name of their associated function. */
11997 fi
= get_current_frame ();
11998 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
12000 fi
= get_prev_frame (fi
);
12004 enum language func_lang
;
12006 gdb::unique_xmalloc_ptr
<char> func_name
12007 = find_frame_funname (fi
, &func_lang
, NULL
);
12008 if (func_name
!= NULL
)
12010 if (strcmp (func_name
.get (),
12011 data
->exception_info
->catch_exception_sym
) == 0)
12012 break; /* We found the frame we were looking for... */
12014 fi
= get_prev_frame (fi
);
12021 return parse_and_eval_address ("id.full_name");
12024 /* Assuming the inferior just triggered an Ada exception catchpoint
12025 (of any type), return the address in inferior memory where the name
12026 of the exception is stored, if applicable.
12028 Assumes the selected frame is the current frame.
12030 Return zero if the address could not be computed, or if not relevant. */
12033 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
12034 struct breakpoint
*b
)
12036 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12040 case ada_catch_exception
:
12041 return (parse_and_eval_address ("e.full_name"));
12044 case ada_catch_exception_unhandled
:
12045 return data
->exception_info
->unhandled_exception_name_addr ();
12048 case ada_catch_handlers
:
12049 return 0; /* The runtimes does not provide access to the exception
12053 case ada_catch_assert
:
12054 return 0; /* Exception name is not relevant in this case. */
12058 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12062 return 0; /* Should never be reached. */
12065 /* Assuming the inferior is stopped at an exception catchpoint,
12066 return the message which was associated to the exception, if
12067 available. Return NULL if the message could not be retrieved.
12069 Note: The exception message can be associated to an exception
12070 either through the use of the Raise_Exception function, or
12071 more simply (Ada 2005 and later), via:
12073 raise Exception_Name with "exception message";
12077 static gdb::unique_xmalloc_ptr
<char>
12078 ada_exception_message_1 (void)
12080 struct value
*e_msg_val
;
12083 /* For runtimes that support this feature, the exception message
12084 is passed as an unbounded string argument called "message". */
12085 e_msg_val
= parse_and_eval ("message");
12086 if (e_msg_val
== NULL
)
12087 return NULL
; /* Exception message not supported. */
12089 e_msg_val
= ada_coerce_to_simple_array (e_msg_val
);
12090 gdb_assert (e_msg_val
!= NULL
);
12091 e_msg_len
= TYPE_LENGTH (value_type (e_msg_val
));
12093 /* If the message string is empty, then treat it as if there was
12094 no exception message. */
12095 if (e_msg_len
<= 0)
12098 return target_read_string (value_address (e_msg_val
), INT_MAX
);
12101 /* Same as ada_exception_message_1, except that all exceptions are
12102 contained here (returning NULL instead). */
12104 static gdb::unique_xmalloc_ptr
<char>
12105 ada_exception_message (void)
12107 gdb::unique_xmalloc_ptr
<char> e_msg
;
12111 e_msg
= ada_exception_message_1 ();
12113 catch (const gdb_exception_error
&e
)
12115 e_msg
.reset (nullptr);
12121 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12122 any error that ada_exception_name_addr_1 might cause to be thrown.
12123 When an error is intercepted, a warning with the error message is printed,
12124 and zero is returned. */
12127 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
12128 struct breakpoint
*b
)
12130 CORE_ADDR result
= 0;
12134 result
= ada_exception_name_addr_1 (ex
, b
);
12137 catch (const gdb_exception_error
&e
)
12139 warning (_("failed to get exception name: %s"), e
.what ());
12146 static std::string ada_exception_catchpoint_cond_string
12147 (const char *excep_string
,
12148 enum ada_exception_catchpoint_kind ex
);
12150 /* Ada catchpoints.
12152 In the case of catchpoints on Ada exceptions, the catchpoint will
12153 stop the target on every exception the program throws. When a user
12154 specifies the name of a specific exception, we translate this
12155 request into a condition expression (in text form), and then parse
12156 it into an expression stored in each of the catchpoint's locations.
12157 We then use this condition to check whether the exception that was
12158 raised is the one the user is interested in. If not, then the
12159 target is resumed again. We store the name of the requested
12160 exception, in order to be able to re-set the condition expression
12161 when symbols change. */
12163 /* An instance of this type is used to represent an Ada catchpoint
12164 breakpoint location. */
12166 class ada_catchpoint_location
: public bp_location
12169 ada_catchpoint_location (breakpoint
*owner
)
12170 : bp_location (owner
, bp_loc_software_breakpoint
)
12173 /* The condition that checks whether the exception that was raised
12174 is the specific exception the user specified on catchpoint
12176 expression_up excep_cond_expr
;
12179 /* An instance of this type is used to represent an Ada catchpoint. */
12181 struct ada_catchpoint
: public breakpoint
12183 explicit ada_catchpoint (enum ada_exception_catchpoint_kind kind
)
12188 /* The name of the specific exception the user specified. */
12189 std::string excep_string
;
12191 /* What kind of catchpoint this is. */
12192 enum ada_exception_catchpoint_kind m_kind
;
12195 /* Parse the exception condition string in the context of each of the
12196 catchpoint's locations, and store them for later evaluation. */
12199 create_excep_cond_exprs (struct ada_catchpoint
*c
,
12200 enum ada_exception_catchpoint_kind ex
)
12202 struct bp_location
*bl
;
12204 /* Nothing to do if there's no specific exception to catch. */
12205 if (c
->excep_string
.empty ())
12208 /* Same if there are no locations... */
12209 if (c
->loc
== NULL
)
12212 /* Compute the condition expression in text form, from the specific
12213 expection we want to catch. */
12214 std::string cond_string
12215 = ada_exception_catchpoint_cond_string (c
->excep_string
.c_str (), ex
);
12217 /* Iterate over all the catchpoint's locations, and parse an
12218 expression for each. */
12219 for (bl
= c
->loc
; bl
!= NULL
; bl
= bl
->next
)
12221 struct ada_catchpoint_location
*ada_loc
12222 = (struct ada_catchpoint_location
*) bl
;
12225 if (!bl
->shlib_disabled
)
12229 s
= cond_string
.c_str ();
12232 exp
= parse_exp_1 (&s
, bl
->address
,
12233 block_for_pc (bl
->address
),
12236 catch (const gdb_exception_error
&e
)
12238 warning (_("failed to reevaluate internal exception condition "
12239 "for catchpoint %d: %s"),
12240 c
->number
, e
.what ());
12244 ada_loc
->excep_cond_expr
= std::move (exp
);
12248 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12249 structure for all exception catchpoint kinds. */
12251 static struct bp_location
*
12252 allocate_location_exception (struct breakpoint
*self
)
12254 return new ada_catchpoint_location (self
);
12257 /* Implement the RE_SET method in the breakpoint_ops structure for all
12258 exception catchpoint kinds. */
12261 re_set_exception (struct breakpoint
*b
)
12263 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12265 /* Call the base class's method. This updates the catchpoint's
12267 bkpt_breakpoint_ops
.re_set (b
);
12269 /* Reparse the exception conditional expressions. One for each
12271 create_excep_cond_exprs (c
, c
->m_kind
);
12274 /* Returns true if we should stop for this breakpoint hit. If the
12275 user specified a specific exception, we only want to cause a stop
12276 if the program thrown that exception. */
12279 should_stop_exception (const struct bp_location
*bl
)
12281 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
12282 const struct ada_catchpoint_location
*ada_loc
12283 = (const struct ada_catchpoint_location
*) bl
;
12286 struct internalvar
*var
= lookup_internalvar ("_ada_exception");
12287 if (c
->m_kind
== ada_catch_assert
)
12288 clear_internalvar (var
);
12295 if (c
->m_kind
== ada_catch_handlers
)
12296 expr
= ("GNAT_GCC_exception_Access(gcc_exception)"
12297 ".all.occurrence.id");
12301 struct value
*exc
= parse_and_eval (expr
);
12302 set_internalvar (var
, exc
);
12304 catch (const gdb_exception_error
&ex
)
12306 clear_internalvar (var
);
12310 /* With no specific exception, should always stop. */
12311 if (c
->excep_string
.empty ())
12314 if (ada_loc
->excep_cond_expr
== NULL
)
12316 /* We will have a NULL expression if back when we were creating
12317 the expressions, this location's had failed to parse. */
12324 struct value
*mark
;
12326 mark
= value_mark ();
12327 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
.get ()));
12328 value_free_to_mark (mark
);
12330 catch (const gdb_exception
&ex
)
12332 exception_fprintf (gdb_stderr
, ex
,
12333 _("Error in testing exception condition:\n"));
12339 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12340 for all exception catchpoint kinds. */
12343 check_status_exception (bpstat bs
)
12345 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
12348 /* Implement the PRINT_IT method in the breakpoint_ops structure
12349 for all exception catchpoint kinds. */
12351 static enum print_stop_action
12352 print_it_exception (bpstat bs
)
12354 struct ui_out
*uiout
= current_uiout
;
12355 struct breakpoint
*b
= bs
->breakpoint_at
;
12357 annotate_catchpoint (b
->number
);
12359 if (uiout
->is_mi_like_p ())
12361 uiout
->field_string ("reason",
12362 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
12363 uiout
->field_string ("disp", bpdisp_text (b
->disposition
));
12366 uiout
->text (b
->disposition
== disp_del
12367 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12368 uiout
->field_signed ("bkptno", b
->number
);
12369 uiout
->text (", ");
12371 /* ada_exception_name_addr relies on the selected frame being the
12372 current frame. Need to do this here because this function may be
12373 called more than once when printing a stop, and below, we'll
12374 select the first frame past the Ada run-time (see
12375 ada_find_printable_frame). */
12376 select_frame (get_current_frame ());
12378 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12381 case ada_catch_exception
:
12382 case ada_catch_exception_unhandled
:
12383 case ada_catch_handlers
:
12385 const CORE_ADDR addr
= ada_exception_name_addr (c
->m_kind
, b
);
12386 char exception_name
[256];
12390 read_memory (addr
, (gdb_byte
*) exception_name
,
12391 sizeof (exception_name
) - 1);
12392 exception_name
[sizeof (exception_name
) - 1] = '\0';
12396 /* For some reason, we were unable to read the exception
12397 name. This could happen if the Runtime was compiled
12398 without debugging info, for instance. In that case,
12399 just replace the exception name by the generic string
12400 "exception" - it will read as "an exception" in the
12401 notification we are about to print. */
12402 memcpy (exception_name
, "exception", sizeof ("exception"));
12404 /* In the case of unhandled exception breakpoints, we print
12405 the exception name as "unhandled EXCEPTION_NAME", to make
12406 it clearer to the user which kind of catchpoint just got
12407 hit. We used ui_out_text to make sure that this extra
12408 info does not pollute the exception name in the MI case. */
12409 if (c
->m_kind
== ada_catch_exception_unhandled
)
12410 uiout
->text ("unhandled ");
12411 uiout
->field_string ("exception-name", exception_name
);
12414 case ada_catch_assert
:
12415 /* In this case, the name of the exception is not really
12416 important. Just print "failed assertion" to make it clearer
12417 that his program just hit an assertion-failure catchpoint.
12418 We used ui_out_text because this info does not belong in
12420 uiout
->text ("failed assertion");
12424 gdb::unique_xmalloc_ptr
<char> exception_message
= ada_exception_message ();
12425 if (exception_message
!= NULL
)
12427 uiout
->text (" (");
12428 uiout
->field_string ("exception-message", exception_message
.get ());
12432 uiout
->text (" at ");
12433 ada_find_printable_frame (get_current_frame ());
12435 return PRINT_SRC_AND_LOC
;
12438 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12439 for all exception catchpoint kinds. */
12442 print_one_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12444 struct ui_out
*uiout
= current_uiout
;
12445 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12446 struct value_print_options opts
;
12448 get_user_print_options (&opts
);
12450 if (opts
.addressprint
)
12451 uiout
->field_skip ("addr");
12453 annotate_field (5);
12456 case ada_catch_exception
:
12457 if (!c
->excep_string
.empty ())
12459 std::string msg
= string_printf (_("`%s' Ada exception"),
12460 c
->excep_string
.c_str ());
12462 uiout
->field_string ("what", msg
);
12465 uiout
->field_string ("what", "all Ada exceptions");
12469 case ada_catch_exception_unhandled
:
12470 uiout
->field_string ("what", "unhandled Ada exceptions");
12473 case ada_catch_handlers
:
12474 if (!c
->excep_string
.empty ())
12476 uiout
->field_fmt ("what",
12477 _("`%s' Ada exception handlers"),
12478 c
->excep_string
.c_str ());
12481 uiout
->field_string ("what", "all Ada exceptions handlers");
12484 case ada_catch_assert
:
12485 uiout
->field_string ("what", "failed Ada assertions");
12489 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12494 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12495 for all exception catchpoint kinds. */
12498 print_mention_exception (struct breakpoint
*b
)
12500 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12501 struct ui_out
*uiout
= current_uiout
;
12503 uiout
->text (b
->disposition
== disp_del
? _("Temporary catchpoint ")
12504 : _("Catchpoint "));
12505 uiout
->field_signed ("bkptno", b
->number
);
12506 uiout
->text (": ");
12510 case ada_catch_exception
:
12511 if (!c
->excep_string
.empty ())
12513 std::string info
= string_printf (_("`%s' Ada exception"),
12514 c
->excep_string
.c_str ());
12515 uiout
->text (info
.c_str ());
12518 uiout
->text (_("all Ada exceptions"));
12521 case ada_catch_exception_unhandled
:
12522 uiout
->text (_("unhandled Ada exceptions"));
12525 case ada_catch_handlers
:
12526 if (!c
->excep_string
.empty ())
12529 = string_printf (_("`%s' Ada exception handlers"),
12530 c
->excep_string
.c_str ());
12531 uiout
->text (info
.c_str ());
12534 uiout
->text (_("all Ada exceptions handlers"));
12537 case ada_catch_assert
:
12538 uiout
->text (_("failed Ada assertions"));
12542 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12547 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12548 for all exception catchpoint kinds. */
12551 print_recreate_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12553 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12557 case ada_catch_exception
:
12558 fprintf_filtered (fp
, "catch exception");
12559 if (!c
->excep_string
.empty ())
12560 fprintf_filtered (fp
, " %s", c
->excep_string
.c_str ());
12563 case ada_catch_exception_unhandled
:
12564 fprintf_filtered (fp
, "catch exception unhandled");
12567 case ada_catch_handlers
:
12568 fprintf_filtered (fp
, "catch handlers");
12571 case ada_catch_assert
:
12572 fprintf_filtered (fp
, "catch assert");
12576 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12578 print_recreate_thread (b
, fp
);
12581 /* Virtual tables for various breakpoint types. */
12582 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12583 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12584 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12585 static struct breakpoint_ops catch_handlers_breakpoint_ops
;
12587 /* See ada-lang.h. */
12590 is_ada_exception_catchpoint (breakpoint
*bp
)
12592 return (bp
->ops
== &catch_exception_breakpoint_ops
12593 || bp
->ops
== &catch_exception_unhandled_breakpoint_ops
12594 || bp
->ops
== &catch_assert_breakpoint_ops
12595 || bp
->ops
== &catch_handlers_breakpoint_ops
);
12598 /* Split the arguments specified in a "catch exception" command.
12599 Set EX to the appropriate catchpoint type.
12600 Set EXCEP_STRING to the name of the specific exception if
12601 specified by the user.
12602 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
12603 "catch handlers" command. False otherwise.
12604 If a condition is found at the end of the arguments, the condition
12605 expression is stored in COND_STRING (memory must be deallocated
12606 after use). Otherwise COND_STRING is set to NULL. */
12609 catch_ada_exception_command_split (const char *args
,
12610 bool is_catch_handlers_cmd
,
12611 enum ada_exception_catchpoint_kind
*ex
,
12612 std::string
*excep_string
,
12613 std::string
*cond_string
)
12615 std::string exception_name
;
12617 exception_name
= extract_arg (&args
);
12618 if (exception_name
== "if")
12620 /* This is not an exception name; this is the start of a condition
12621 expression for a catchpoint on all exceptions. So, "un-get"
12622 this token, and set exception_name to NULL. */
12623 exception_name
.clear ();
12627 /* Check to see if we have a condition. */
12629 args
= skip_spaces (args
);
12630 if (startswith (args
, "if")
12631 && (isspace (args
[2]) || args
[2] == '\0'))
12634 args
= skip_spaces (args
);
12636 if (args
[0] == '\0')
12637 error (_("Condition missing after `if' keyword"));
12638 *cond_string
= args
;
12640 args
+= strlen (args
);
12643 /* Check that we do not have any more arguments. Anything else
12646 if (args
[0] != '\0')
12647 error (_("Junk at end of expression"));
12649 if (is_catch_handlers_cmd
)
12651 /* Catch handling of exceptions. */
12652 *ex
= ada_catch_handlers
;
12653 *excep_string
= exception_name
;
12655 else if (exception_name
.empty ())
12657 /* Catch all exceptions. */
12658 *ex
= ada_catch_exception
;
12659 excep_string
->clear ();
12661 else if (exception_name
== "unhandled")
12663 /* Catch unhandled exceptions. */
12664 *ex
= ada_catch_exception_unhandled
;
12665 excep_string
->clear ();
12669 /* Catch a specific exception. */
12670 *ex
= ada_catch_exception
;
12671 *excep_string
= exception_name
;
12675 /* Return the name of the symbol on which we should break in order to
12676 implement a catchpoint of the EX kind. */
12678 static const char *
12679 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12681 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12683 gdb_assert (data
->exception_info
!= NULL
);
12687 case ada_catch_exception
:
12688 return (data
->exception_info
->catch_exception_sym
);
12690 case ada_catch_exception_unhandled
:
12691 return (data
->exception_info
->catch_exception_unhandled_sym
);
12693 case ada_catch_assert
:
12694 return (data
->exception_info
->catch_assert_sym
);
12696 case ada_catch_handlers
:
12697 return (data
->exception_info
->catch_handlers_sym
);
12700 internal_error (__FILE__
, __LINE__
,
12701 _("unexpected catchpoint kind (%d)"), ex
);
12705 /* Return the breakpoint ops "virtual table" used for catchpoints
12708 static const struct breakpoint_ops
*
12709 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12713 case ada_catch_exception
:
12714 return (&catch_exception_breakpoint_ops
);
12716 case ada_catch_exception_unhandled
:
12717 return (&catch_exception_unhandled_breakpoint_ops
);
12719 case ada_catch_assert
:
12720 return (&catch_assert_breakpoint_ops
);
12722 case ada_catch_handlers
:
12723 return (&catch_handlers_breakpoint_ops
);
12726 internal_error (__FILE__
, __LINE__
,
12727 _("unexpected catchpoint kind (%d)"), ex
);
12731 /* Return the condition that will be used to match the current exception
12732 being raised with the exception that the user wants to catch. This
12733 assumes that this condition is used when the inferior just triggered
12734 an exception catchpoint.
12735 EX: the type of catchpoints used for catching Ada exceptions. */
12738 ada_exception_catchpoint_cond_string (const char *excep_string
,
12739 enum ada_exception_catchpoint_kind ex
)
12742 bool is_standard_exc
= false;
12743 std::string result
;
12745 if (ex
== ada_catch_handlers
)
12747 /* For exception handlers catchpoints, the condition string does
12748 not use the same parameter as for the other exceptions. */
12749 result
= ("long_integer (GNAT_GCC_exception_Access"
12750 "(gcc_exception).all.occurrence.id)");
12753 result
= "long_integer (e)";
12755 /* The standard exceptions are a special case. They are defined in
12756 runtime units that have been compiled without debugging info; if
12757 EXCEP_STRING is the not-fully-qualified name of a standard
12758 exception (e.g. "constraint_error") then, during the evaluation
12759 of the condition expression, the symbol lookup on this name would
12760 *not* return this standard exception. The catchpoint condition
12761 may then be set only on user-defined exceptions which have the
12762 same not-fully-qualified name (e.g. my_package.constraint_error).
12764 To avoid this unexcepted behavior, these standard exceptions are
12765 systematically prefixed by "standard". This means that "catch
12766 exception constraint_error" is rewritten into "catch exception
12767 standard.constraint_error".
12769 If an exception named constraint_error is defined in another package of
12770 the inferior program, then the only way to specify this exception as a
12771 breakpoint condition is to use its fully-qualified named:
12772 e.g. my_package.constraint_error. */
12774 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12776 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12778 is_standard_exc
= true;
12785 if (is_standard_exc
)
12786 string_appendf (result
, "long_integer (&standard.%s)", excep_string
);
12788 string_appendf (result
, "long_integer (&%s)", excep_string
);
12793 /* Return the symtab_and_line that should be used to insert an exception
12794 catchpoint of the TYPE kind.
12796 ADDR_STRING returns the name of the function where the real
12797 breakpoint that implements the catchpoints is set, depending on the
12798 type of catchpoint we need to create. */
12800 static struct symtab_and_line
12801 ada_exception_sal (enum ada_exception_catchpoint_kind ex
,
12802 std::string
*addr_string
, const struct breakpoint_ops
**ops
)
12804 const char *sym_name
;
12805 struct symbol
*sym
;
12807 /* First, find out which exception support info to use. */
12808 ada_exception_support_info_sniffer ();
12810 /* Then lookup the function on which we will break in order to catch
12811 the Ada exceptions requested by the user. */
12812 sym_name
= ada_exception_sym_name (ex
);
12813 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12816 error (_("Catchpoint symbol not found: %s"), sym_name
);
12818 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
12819 error (_("Unable to insert catchpoint. %s is not a function."), sym_name
);
12821 /* Set ADDR_STRING. */
12822 *addr_string
= sym_name
;
12825 *ops
= ada_exception_breakpoint_ops (ex
);
12827 return find_function_start_sal (sym
, 1);
12830 /* Create an Ada exception catchpoint.
12832 EX_KIND is the kind of exception catchpoint to be created.
12834 If EXCEPT_STRING is empty, this catchpoint is expected to trigger
12835 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12836 of the exception to which this catchpoint applies.
12838 COND_STRING, if not empty, is the catchpoint condition.
12840 TEMPFLAG, if nonzero, means that the underlying breakpoint
12841 should be temporary.
12843 FROM_TTY is the usual argument passed to all commands implementations. */
12846 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12847 enum ada_exception_catchpoint_kind ex_kind
,
12848 const std::string
&excep_string
,
12849 const std::string
&cond_string
,
12854 std::string addr_string
;
12855 const struct breakpoint_ops
*ops
= NULL
;
12856 struct symtab_and_line sal
= ada_exception_sal (ex_kind
, &addr_string
, &ops
);
12858 std::unique_ptr
<ada_catchpoint
> c (new ada_catchpoint (ex_kind
));
12859 init_ada_exception_breakpoint (c
.get (), gdbarch
, sal
, addr_string
.c_str (),
12860 ops
, tempflag
, disabled
, from_tty
);
12861 c
->excep_string
= excep_string
;
12862 create_excep_cond_exprs (c
.get (), ex_kind
);
12863 if (!cond_string
.empty ())
12864 set_breakpoint_condition (c
.get (), cond_string
.c_str (), from_tty
);
12865 install_breakpoint (0, std::move (c
), 1);
12868 /* Implement the "catch exception" command. */
12871 catch_ada_exception_command (const char *arg_entry
, int from_tty
,
12872 struct cmd_list_element
*command
)
12874 const char *arg
= arg_entry
;
12875 struct gdbarch
*gdbarch
= get_current_arch ();
12877 enum ada_exception_catchpoint_kind ex_kind
;
12878 std::string excep_string
;
12879 std::string cond_string
;
12881 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12885 catch_ada_exception_command_split (arg
, false, &ex_kind
, &excep_string
,
12887 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12888 excep_string
, cond_string
,
12889 tempflag
, 1 /* enabled */,
12893 /* Implement the "catch handlers" command. */
12896 catch_ada_handlers_command (const char *arg_entry
, int from_tty
,
12897 struct cmd_list_element
*command
)
12899 const char *arg
= arg_entry
;
12900 struct gdbarch
*gdbarch
= get_current_arch ();
12902 enum ada_exception_catchpoint_kind ex_kind
;
12903 std::string excep_string
;
12904 std::string cond_string
;
12906 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12910 catch_ada_exception_command_split (arg
, true, &ex_kind
, &excep_string
,
12912 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12913 excep_string
, cond_string
,
12914 tempflag
, 1 /* enabled */,
12918 /* Completion function for the Ada "catch" commands. */
12921 catch_ada_completer (struct cmd_list_element
*cmd
, completion_tracker
&tracker
,
12922 const char *text
, const char *word
)
12924 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (NULL
);
12926 for (const ada_exc_info
&info
: exceptions
)
12928 if (startswith (info
.name
, word
))
12929 tracker
.add_completion (make_unique_xstrdup (info
.name
));
12933 /* Split the arguments specified in a "catch assert" command.
12935 ARGS contains the command's arguments (or the empty string if
12936 no arguments were passed).
12938 If ARGS contains a condition, set COND_STRING to that condition
12939 (the memory needs to be deallocated after use). */
12942 catch_ada_assert_command_split (const char *args
, std::string
&cond_string
)
12944 args
= skip_spaces (args
);
12946 /* Check whether a condition was provided. */
12947 if (startswith (args
, "if")
12948 && (isspace (args
[2]) || args
[2] == '\0'))
12951 args
= skip_spaces (args
);
12952 if (args
[0] == '\0')
12953 error (_("condition missing after `if' keyword"));
12954 cond_string
.assign (args
);
12957 /* Otherwise, there should be no other argument at the end of
12959 else if (args
[0] != '\0')
12960 error (_("Junk at end of arguments."));
12963 /* Implement the "catch assert" command. */
12966 catch_assert_command (const char *arg_entry
, int from_tty
,
12967 struct cmd_list_element
*command
)
12969 const char *arg
= arg_entry
;
12970 struct gdbarch
*gdbarch
= get_current_arch ();
12972 std::string cond_string
;
12974 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12978 catch_ada_assert_command_split (arg
, cond_string
);
12979 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12981 tempflag
, 1 /* enabled */,
12985 /* Return non-zero if the symbol SYM is an Ada exception object. */
12988 ada_is_exception_sym (struct symbol
*sym
)
12990 const char *type_name
= SYMBOL_TYPE (sym
)->name ();
12992 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12993 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12994 && SYMBOL_CLASS (sym
) != LOC_CONST
12995 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12996 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12999 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13000 Ada exception object. This matches all exceptions except the ones
13001 defined by the Ada language. */
13004 ada_is_non_standard_exception_sym (struct symbol
*sym
)
13008 if (!ada_is_exception_sym (sym
))
13011 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
13012 if (strcmp (sym
->linkage_name (), standard_exc
[i
]) == 0)
13013 return 0; /* A standard exception. */
13015 /* Numeric_Error is also a standard exception, so exclude it.
13016 See the STANDARD_EXC description for more details as to why
13017 this exception is not listed in that array. */
13018 if (strcmp (sym
->linkage_name (), "numeric_error") == 0)
13024 /* A helper function for std::sort, comparing two struct ada_exc_info
13027 The comparison is determined first by exception name, and then
13028 by exception address. */
13031 ada_exc_info::operator< (const ada_exc_info
&other
) const
13035 result
= strcmp (name
, other
.name
);
13038 if (result
== 0 && addr
< other
.addr
)
13044 ada_exc_info::operator== (const ada_exc_info
&other
) const
13046 return addr
== other
.addr
&& strcmp (name
, other
.name
) == 0;
13049 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13050 routine, but keeping the first SKIP elements untouched.
13052 All duplicates are also removed. */
13055 sort_remove_dups_ada_exceptions_list (std::vector
<ada_exc_info
> *exceptions
,
13058 std::sort (exceptions
->begin () + skip
, exceptions
->end ());
13059 exceptions
->erase (std::unique (exceptions
->begin () + skip
, exceptions
->end ()),
13060 exceptions
->end ());
13063 /* Add all exceptions defined by the Ada standard whose name match
13064 a regular expression.
13066 If PREG is not NULL, then this regexp_t object is used to
13067 perform the symbol name matching. Otherwise, no name-based
13068 filtering is performed.
13070 EXCEPTIONS is a vector of exceptions to which matching exceptions
13074 ada_add_standard_exceptions (compiled_regex
*preg
,
13075 std::vector
<ada_exc_info
> *exceptions
)
13079 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
13082 || preg
->exec (standard_exc
[i
], 0, NULL
, 0) == 0)
13084 struct bound_minimal_symbol msymbol
13085 = ada_lookup_simple_minsym (standard_exc
[i
]);
13087 if (msymbol
.minsym
!= NULL
)
13089 struct ada_exc_info info
13090 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
13092 exceptions
->push_back (info
);
13098 /* Add all Ada exceptions defined locally and accessible from the given
13101 If PREG is not NULL, then this regexp_t object is used to
13102 perform the symbol name matching. Otherwise, no name-based
13103 filtering is performed.
13105 EXCEPTIONS is a vector of exceptions to which matching exceptions
13109 ada_add_exceptions_from_frame (compiled_regex
*preg
,
13110 struct frame_info
*frame
,
13111 std::vector
<ada_exc_info
> *exceptions
)
13113 const struct block
*block
= get_frame_block (frame
, 0);
13117 struct block_iterator iter
;
13118 struct symbol
*sym
;
13120 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
13122 switch (SYMBOL_CLASS (sym
))
13129 if (ada_is_exception_sym (sym
))
13131 struct ada_exc_info info
= {sym
->print_name (),
13132 SYMBOL_VALUE_ADDRESS (sym
)};
13134 exceptions
->push_back (info
);
13138 if (BLOCK_FUNCTION (block
) != NULL
)
13140 block
= BLOCK_SUPERBLOCK (block
);
13144 /* Return true if NAME matches PREG or if PREG is NULL. */
13147 name_matches_regex (const char *name
, compiled_regex
*preg
)
13149 return (preg
== NULL
13150 || preg
->exec (ada_decode (name
).c_str (), 0, NULL
, 0) == 0);
13153 /* Add all exceptions defined globally whose name name match
13154 a regular expression, excluding standard exceptions.
13156 The reason we exclude standard exceptions is that they need
13157 to be handled separately: Standard exceptions are defined inside
13158 a runtime unit which is normally not compiled with debugging info,
13159 and thus usually do not show up in our symbol search. However,
13160 if the unit was in fact built with debugging info, we need to
13161 exclude them because they would duplicate the entry we found
13162 during the special loop that specifically searches for those
13163 standard exceptions.
13165 If PREG is not NULL, then this regexp_t object is used to
13166 perform the symbol name matching. Otherwise, no name-based
13167 filtering is performed.
13169 EXCEPTIONS is a vector of exceptions to which matching exceptions
13173 ada_add_global_exceptions (compiled_regex
*preg
,
13174 std::vector
<ada_exc_info
> *exceptions
)
13176 /* In Ada, the symbol "search name" is a linkage name, whereas the
13177 regular expression used to do the matching refers to the natural
13178 name. So match against the decoded name. */
13179 expand_symtabs_matching (NULL
,
13180 lookup_name_info::match_any (),
13181 [&] (const char *search_name
)
13183 std::string decoded
= ada_decode (search_name
);
13184 return name_matches_regex (decoded
.c_str (), preg
);
13189 for (objfile
*objfile
: current_program_space
->objfiles ())
13191 for (compunit_symtab
*s
: objfile
->compunits ())
13193 const struct blockvector
*bv
= COMPUNIT_BLOCKVECTOR (s
);
13196 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
13198 const struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
13199 struct block_iterator iter
;
13200 struct symbol
*sym
;
13202 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
13203 if (ada_is_non_standard_exception_sym (sym
)
13204 && name_matches_regex (sym
->natural_name (), preg
))
13206 struct ada_exc_info info
13207 = {sym
->print_name (), SYMBOL_VALUE_ADDRESS (sym
)};
13209 exceptions
->push_back (info
);
13216 /* Implements ada_exceptions_list with the regular expression passed
13217 as a regex_t, rather than a string.
13219 If not NULL, PREG is used to filter out exceptions whose names
13220 do not match. Otherwise, all exceptions are listed. */
13222 static std::vector
<ada_exc_info
>
13223 ada_exceptions_list_1 (compiled_regex
*preg
)
13225 std::vector
<ada_exc_info
> result
;
13228 /* First, list the known standard exceptions. These exceptions
13229 need to be handled separately, as they are usually defined in
13230 runtime units that have been compiled without debugging info. */
13232 ada_add_standard_exceptions (preg
, &result
);
13234 /* Next, find all exceptions whose scope is local and accessible
13235 from the currently selected frame. */
13237 if (has_stack_frames ())
13239 prev_len
= result
.size ();
13240 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
13242 if (result
.size () > prev_len
)
13243 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13246 /* Add all exceptions whose scope is global. */
13248 prev_len
= result
.size ();
13249 ada_add_global_exceptions (preg
, &result
);
13250 if (result
.size () > prev_len
)
13251 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
13256 /* Return a vector of ada_exc_info.
13258 If REGEXP is NULL, all exceptions are included in the result.
13259 Otherwise, it should contain a valid regular expression,
13260 and only the exceptions whose names match that regular expression
13261 are included in the result.
13263 The exceptions are sorted in the following order:
13264 - Standard exceptions (defined by the Ada language), in
13265 alphabetical order;
13266 - Exceptions only visible from the current frame, in
13267 alphabetical order;
13268 - Exceptions whose scope is global, in alphabetical order. */
13270 std::vector
<ada_exc_info
>
13271 ada_exceptions_list (const char *regexp
)
13273 if (regexp
== NULL
)
13274 return ada_exceptions_list_1 (NULL
);
13276 compiled_regex
reg (regexp
, REG_NOSUB
, _("invalid regular expression"));
13277 return ada_exceptions_list_1 (®
);
13280 /* Implement the "info exceptions" command. */
13283 info_exceptions_command (const char *regexp
, int from_tty
)
13285 struct gdbarch
*gdbarch
= get_current_arch ();
13287 std::vector
<ada_exc_info
> exceptions
= ada_exceptions_list (regexp
);
13289 if (regexp
!= NULL
)
13291 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
13293 printf_filtered (_("All defined Ada exceptions:\n"));
13295 for (const ada_exc_info
&info
: exceptions
)
13296 printf_filtered ("%s: %s\n", info
.name
, paddress (gdbarch
, info
.addr
));
13300 /* Information about operators given special treatment in functions
13302 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13304 #define ADA_OPERATORS \
13305 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13306 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13307 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13308 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13309 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13310 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13311 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13312 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13313 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13314 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13315 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13316 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13317 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13318 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13319 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13320 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13321 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13322 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13323 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13326 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13329 switch (exp
->elts
[pc
- 1].opcode
)
13332 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13335 #define OP_DEFN(op, len, args, binop) \
13336 case op: *oplenp = len; *argsp = args; break;
13342 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13347 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13352 /* Implementation of the exp_descriptor method operator_check. */
13355 ada_operator_check (struct expression
*exp
, int pos
,
13356 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13359 const union exp_element
*const elts
= exp
->elts
;
13360 struct type
*type
= NULL
;
13362 switch (elts
[pos
].opcode
)
13364 case UNOP_IN_RANGE
:
13366 type
= elts
[pos
+ 1].type
;
13370 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13373 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13375 if (type
&& TYPE_OBJFILE (type
)
13376 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13382 static const char *
13383 ada_op_name (enum exp_opcode opcode
)
13388 return op_name_standard (opcode
);
13390 #define OP_DEFN(op, len, args, binop) case op: return #op;
13395 return "OP_AGGREGATE";
13397 return "OP_CHOICES";
13403 /* As for operator_length, but assumes PC is pointing at the first
13404 element of the operator, and gives meaningful results only for the
13405 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13408 ada_forward_operator_length (struct expression
*exp
, int pc
,
13409 int *oplenp
, int *argsp
)
13411 switch (exp
->elts
[pc
].opcode
)
13414 *oplenp
= *argsp
= 0;
13417 #define OP_DEFN(op, len, args, binop) \
13418 case op: *oplenp = len; *argsp = args; break;
13424 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13429 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13435 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13437 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13445 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13447 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13452 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13456 /* Ada attributes ('Foo). */
13459 case OP_ATR_LENGTH
:
13463 case OP_ATR_MODULUS
:
13470 case UNOP_IN_RANGE
:
13472 /* XXX: gdb_sprint_host_address, type_sprint */
13473 fprintf_filtered (stream
, _("Type @"));
13474 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13475 fprintf_filtered (stream
, " (");
13476 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13477 fprintf_filtered (stream
, ")");
13479 case BINOP_IN_BOUNDS
:
13480 fprintf_filtered (stream
, " (%d)",
13481 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13483 case TERNOP_IN_RANGE
:
13488 case OP_DISCRETE_RANGE
:
13489 case OP_POSITIONAL
:
13496 char *name
= &exp
->elts
[elt
+ 2].string
;
13497 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13499 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13504 return dump_subexp_body_standard (exp
, stream
, elt
);
13508 for (i
= 0; i
< nargs
; i
+= 1)
13509 elt
= dump_subexp (exp
, stream
, elt
);
13514 /* The Ada extension of print_subexp (q.v.). */
13517 ada_print_subexp (struct expression
*exp
, int *pos
,
13518 struct ui_file
*stream
, enum precedence prec
)
13520 int oplen
, nargs
, i
;
13522 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13524 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13531 print_subexp_standard (exp
, pos
, stream
, prec
);
13535 fputs_filtered (exp
->elts
[pc
+ 2].symbol
->natural_name (), stream
);
13538 case BINOP_IN_BOUNDS
:
13539 /* XXX: sprint_subexp */
13540 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13541 fputs_filtered (" in ", stream
);
13542 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13543 fputs_filtered ("'range", stream
);
13544 if (exp
->elts
[pc
+ 1].longconst
> 1)
13545 fprintf_filtered (stream
, "(%ld)",
13546 (long) exp
->elts
[pc
+ 1].longconst
);
13549 case TERNOP_IN_RANGE
:
13550 if (prec
>= PREC_EQUAL
)
13551 fputs_filtered ("(", stream
);
13552 /* XXX: sprint_subexp */
13553 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13554 fputs_filtered (" in ", stream
);
13555 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13556 fputs_filtered (" .. ", stream
);
13557 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13558 if (prec
>= PREC_EQUAL
)
13559 fputs_filtered (")", stream
);
13564 case OP_ATR_LENGTH
:
13568 case OP_ATR_MODULUS
:
13573 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13575 if (exp
->elts
[*pos
+ 1].type
->code () != TYPE_CODE_VOID
)
13576 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13577 &type_print_raw_options
);
13581 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13582 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13587 for (tem
= 1; tem
< nargs
; tem
+= 1)
13589 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13590 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13592 fputs_filtered (")", stream
);
13597 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13598 fputs_filtered ("'(", stream
);
13599 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13600 fputs_filtered (")", stream
);
13603 case UNOP_IN_RANGE
:
13604 /* XXX: sprint_subexp */
13605 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13606 fputs_filtered (" in ", stream
);
13607 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13608 &type_print_raw_options
);
13611 case OP_DISCRETE_RANGE
:
13612 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13613 fputs_filtered ("..", stream
);
13614 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13618 fputs_filtered ("others => ", stream
);
13619 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13623 for (i
= 0; i
< nargs
-1; i
+= 1)
13626 fputs_filtered ("|", stream
);
13627 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13629 fputs_filtered (" => ", stream
);
13630 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13633 case OP_POSITIONAL
:
13634 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13638 fputs_filtered ("(", stream
);
13639 for (i
= 0; i
< nargs
; i
+= 1)
13642 fputs_filtered (", ", stream
);
13643 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13645 fputs_filtered (")", stream
);
13650 /* Table mapping opcodes into strings for printing operators
13651 and precedences of the operators. */
13653 static const struct op_print ada_op_print_tab
[] = {
13654 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13655 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13656 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13657 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13658 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13659 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13660 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13661 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13662 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13663 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13664 {">", BINOP_GTR
, PREC_ORDER
, 0},
13665 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13666 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13667 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13668 {"+", BINOP_ADD
, PREC_ADD
, 0},
13669 {"-", BINOP_SUB
, PREC_ADD
, 0},
13670 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13671 {"*", BINOP_MUL
, PREC_MUL
, 0},
13672 {"/", BINOP_DIV
, PREC_MUL
, 0},
13673 {"rem", BINOP_REM
, PREC_MUL
, 0},
13674 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13675 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13676 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13677 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13678 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13679 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13680 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13681 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13682 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13683 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13684 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13685 {NULL
, OP_NULL
, PREC_SUFFIX
, 0}
13688 enum ada_primitive_types
{
13689 ada_primitive_type_int
,
13690 ada_primitive_type_long
,
13691 ada_primitive_type_short
,
13692 ada_primitive_type_char
,
13693 ada_primitive_type_float
,
13694 ada_primitive_type_double
,
13695 ada_primitive_type_void
,
13696 ada_primitive_type_long_long
,
13697 ada_primitive_type_long_double
,
13698 ada_primitive_type_natural
,
13699 ada_primitive_type_positive
,
13700 ada_primitive_type_system_address
,
13701 ada_primitive_type_storage_offset
,
13702 nr_ada_primitive_types
13706 /* Language vector */
13708 /* Not really used, but needed in the ada_language_defn. */
13711 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
13713 ada_emit_char (c
, type
, stream
, quoter
, 1);
13717 parse (struct parser_state
*ps
)
13719 warnings_issued
= 0;
13720 return ada_parse (ps
);
13723 static const struct exp_descriptor ada_exp_descriptor
= {
13725 ada_operator_length
,
13726 ada_operator_check
,
13728 ada_dump_subexp_body
,
13729 ada_evaluate_subexp
13732 /* symbol_name_matcher_ftype adapter for wild_match. */
13735 do_wild_match (const char *symbol_search_name
,
13736 const lookup_name_info
&lookup_name
,
13737 completion_match_result
*comp_match_res
)
13739 return wild_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13742 /* symbol_name_matcher_ftype adapter for full_match. */
13745 do_full_match (const char *symbol_search_name
,
13746 const lookup_name_info
&lookup_name
,
13747 completion_match_result
*comp_match_res
)
13749 return full_match (symbol_search_name
, ada_lookup_name (lookup_name
));
13752 /* symbol_name_matcher_ftype for exact (verbatim) matches. */
13755 do_exact_match (const char *symbol_search_name
,
13756 const lookup_name_info
&lookup_name
,
13757 completion_match_result
*comp_match_res
)
13759 return strcmp (symbol_search_name
, ada_lookup_name (lookup_name
)) == 0;
13762 /* Build the Ada lookup name for LOOKUP_NAME. */
13764 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info
&lookup_name
)
13766 gdb::string_view user_name
= lookup_name
.name ();
13768 if (user_name
[0] == '<')
13770 if (user_name
.back () == '>')
13772 = user_name
.substr (1, user_name
.size () - 2).to_string ();
13775 = user_name
.substr (1, user_name
.size () - 1).to_string ();
13776 m_encoded_p
= true;
13777 m_verbatim_p
= true;
13778 m_wild_match_p
= false;
13779 m_standard_p
= false;
13783 m_verbatim_p
= false;
13785 m_encoded_p
= user_name
.find ("__") != gdb::string_view::npos
;
13789 const char *folded
= ada_fold_name (user_name
);
13790 const char *encoded
= ada_encode_1 (folded
, false);
13791 if (encoded
!= NULL
)
13792 m_encoded_name
= encoded
;
13794 m_encoded_name
= user_name
.to_string ();
13797 m_encoded_name
= user_name
.to_string ();
13799 /* Handle the 'package Standard' special case. See description
13800 of m_standard_p. */
13801 if (startswith (m_encoded_name
.c_str (), "standard__"))
13803 m_encoded_name
= m_encoded_name
.substr (sizeof ("standard__") - 1);
13804 m_standard_p
= true;
13807 m_standard_p
= false;
13809 /* If the name contains a ".", then the user is entering a fully
13810 qualified entity name, and the match must not be done in wild
13811 mode. Similarly, if the user wants to complete what looks
13812 like an encoded name, the match must not be done in wild
13813 mode. Also, in the standard__ special case always do
13814 non-wild matching. */
13816 = (lookup_name
.match_type () != symbol_name_match_type::FULL
13819 && user_name
.find ('.') == std::string::npos
);
13823 /* symbol_name_matcher_ftype method for Ada. This only handles
13824 completion mode. */
13827 ada_symbol_name_matches (const char *symbol_search_name
,
13828 const lookup_name_info
&lookup_name
,
13829 completion_match_result
*comp_match_res
)
13831 return lookup_name
.ada ().matches (symbol_search_name
,
13832 lookup_name
.match_type (),
13836 /* A name matcher that matches the symbol name exactly, with
13840 literal_symbol_name_matcher (const char *symbol_search_name
,
13841 const lookup_name_info
&lookup_name
,
13842 completion_match_result
*comp_match_res
)
13844 gdb::string_view name_view
= lookup_name
.name ();
13846 if (lookup_name
.completion_mode ()
13847 ? (strncmp (symbol_search_name
, name_view
.data (),
13848 name_view
.size ()) == 0)
13849 : symbol_search_name
== name_view
)
13851 if (comp_match_res
!= NULL
)
13852 comp_match_res
->set_match (symbol_search_name
);
13859 /* Implement the "get_symbol_name_matcher" language_defn method for
13862 static symbol_name_matcher_ftype
*
13863 ada_get_symbol_name_matcher (const lookup_name_info
&lookup_name
)
13865 if (lookup_name
.match_type () == symbol_name_match_type::SEARCH_NAME
)
13866 return literal_symbol_name_matcher
;
13868 if (lookup_name
.completion_mode ())
13869 return ada_symbol_name_matches
;
13872 if (lookup_name
.ada ().wild_match_p ())
13873 return do_wild_match
;
13874 else if (lookup_name
.ada ().verbatim_p ())
13875 return do_exact_match
;
13877 return do_full_match
;
13881 static const char *ada_extensions
[] =
13883 ".adb", ".ads", ".a", ".ada", ".dg", NULL
13886 /* Constant data that describes the Ada language. */
13888 extern const struct language_data ada_language_data
=
13890 "ada", /* Language name */
13894 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
13895 that's not quite what this means. */
13897 macro_expansion_no
,
13899 &ada_exp_descriptor
,
13902 ada_printchar
, /* Print a character constant */
13903 ada_printstr
, /* Function to print string constant */
13904 emit_char
, /* Function to print single char (not used) */
13905 ada_print_typedef
, /* Print a typedef using appropriate syntax */
13906 ada_value_print_inner
, /* la_value_print_inner */
13907 ada_value_print
, /* Print a top-level value */
13908 NULL
, /* name_of_this */
13909 true, /* la_store_sym_names_in_linkage_form_p */
13910 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
13911 ada_op_print_tab
, /* expression operators for printing */
13912 0, /* c-style arrays */
13913 1, /* String lower bound */
13914 ada_collect_symbol_completion_matches
,
13915 ada_watch_location_expression
,
13917 ada_is_string_type
,
13918 "(...)" /* la_struct_too_deep_ellipsis */
13921 /* Class representing the Ada language. */
13923 class ada_language
: public language_defn
13927 : language_defn (language_ada
, ada_language_data
)
13930 /* Print an array element index using the Ada syntax. */
13932 void print_array_index (struct type
*index_type
,
13934 struct ui_file
*stream
,
13935 const value_print_options
*options
) const override
13937 struct value
*index_value
= val_atr (index_type
, index
);
13939 LA_VALUE_PRINT (index_value
, stream
, options
);
13940 fprintf_filtered (stream
, " => ");
13943 /* Implement the "read_var_value" language_defn method for Ada. */
13945 struct value
*read_var_value (struct symbol
*var
,
13946 const struct block
*var_block
,
13947 struct frame_info
*frame
) const override
13949 /* The only case where default_read_var_value is not sufficient
13950 is when VAR is a renaming... */
13951 if (frame
!= nullptr)
13953 const struct block
*frame_block
= get_frame_block (frame
, NULL
);
13954 if (frame_block
!= nullptr && ada_is_renaming_symbol (var
))
13955 return ada_read_renaming_var_value (var
, frame_block
);
13958 /* This is a typical case where we expect the default_read_var_value
13959 function to work. */
13960 return language_defn::read_var_value (var
, var_block
, frame
);
13963 /* See language.h. */
13964 void language_arch_info (struct gdbarch
*gdbarch
,
13965 struct language_arch_info
*lai
) const override
13967 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13969 lai
->primitive_type_vector
13970 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
13973 lai
->primitive_type_vector
[ada_primitive_type_int
]
13974 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13976 lai
->primitive_type_vector
[ada_primitive_type_long
]
13977 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13978 0, "long_integer");
13979 lai
->primitive_type_vector
[ada_primitive_type_short
]
13980 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13981 0, "short_integer");
13982 lai
->string_char_type
13983 = lai
->primitive_type_vector
[ada_primitive_type_char
]
13984 = arch_character_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
13985 lai
->primitive_type_vector
[ada_primitive_type_float
]
13986 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13987 "float", gdbarch_float_format (gdbarch
));
13988 lai
->primitive_type_vector
[ada_primitive_type_double
]
13989 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13990 "long_float", gdbarch_double_format (gdbarch
));
13991 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
13992 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13993 0, "long_long_integer");
13994 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
13995 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
13996 "long_long_float", gdbarch_long_double_format (gdbarch
));
13997 lai
->primitive_type_vector
[ada_primitive_type_natural
]
13998 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
14000 lai
->primitive_type_vector
[ada_primitive_type_positive
]
14001 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
14003 lai
->primitive_type_vector
[ada_primitive_type_void
]
14004 = builtin
->builtin_void
;
14006 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
14007 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
,
14009 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
14010 ->set_name ("system__address");
14012 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14013 type. This is a signed integral type whose size is the same as
14014 the size of addresses. */
14016 unsigned int addr_length
= TYPE_LENGTH
14017 (lai
->primitive_type_vector
[ada_primitive_type_system_address
]);
14019 lai
->primitive_type_vector
[ada_primitive_type_storage_offset
]
14020 = arch_integer_type (gdbarch
, addr_length
* HOST_CHAR_BIT
, 0,
14024 lai
->bool_type_symbol
= NULL
;
14025 lai
->bool_type_default
= builtin
->builtin_bool
;
14028 /* See language.h. */
14030 bool iterate_over_symbols
14031 (const struct block
*block
, const lookup_name_info
&name
,
14032 domain_enum domain
,
14033 gdb::function_view
<symbol_found_callback_ftype
> callback
) const override
14035 std::vector
<struct block_symbol
> results
;
14037 ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
14038 for (block_symbol
&sym
: results
)
14040 if (!callback (&sym
))
14047 /* See language.h. */
14048 bool sniff_from_mangled_name (const char *mangled
,
14049 char **out
) const override
14051 std::string demangled
= ada_decode (mangled
);
14055 if (demangled
!= mangled
&& demangled
[0] != '<')
14057 /* Set the gsymbol language to Ada, but still return 0.
14058 Two reasons for that:
14060 1. For Ada, we prefer computing the symbol's decoded name
14061 on the fly rather than pre-compute it, in order to save
14062 memory (Ada projects are typically very large).
14064 2. There are some areas in the definition of the GNAT
14065 encoding where, with a bit of bad luck, we might be able
14066 to decode a non-Ada symbol, generating an incorrect
14067 demangled name (Eg: names ending with "TB" for instance
14068 are identified as task bodies and so stripped from
14069 the decoded name returned).
14071 Returning true, here, but not setting *DEMANGLED, helps us get
14072 a little bit of the best of both worlds. Because we're last,
14073 we should not affect any of the other languages that were
14074 able to demangle the symbol before us; we get to correctly
14075 tag Ada symbols as such; and even if we incorrectly tagged a
14076 non-Ada symbol, which should be rare, any routing through the
14077 Ada language should be transparent (Ada tries to behave much
14078 like C/C++ with non-Ada symbols). */
14085 /* See language.h. */
14087 char *demangle (const char *mangled
, int options
) const override
14089 return ada_la_decode (mangled
, options
);
14092 /* See language.h. */
14094 void print_type (struct type
*type
, const char *varstring
,
14095 struct ui_file
*stream
, int show
, int level
,
14096 const struct type_print_options
*flags
) const override
14098 ada_print_type (type
, varstring
, stream
, show
, level
, flags
);
14101 /* See language.h. */
14103 const char *word_break_characters (void) const override
14105 return ada_completer_word_break_characters
;
14109 /* See language.h. */
14111 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
14112 (const lookup_name_info
&lookup_name
) const override
14114 return ada_get_symbol_name_matcher (lookup_name
);
14118 /* Single instance of the Ada language class. */
14120 static ada_language ada_language_defn
;
14122 /* Command-list for the "set/show ada" prefix command. */
14123 static struct cmd_list_element
*set_ada_list
;
14124 static struct cmd_list_element
*show_ada_list
;
14127 initialize_ada_catchpoint_ops (void)
14129 struct breakpoint_ops
*ops
;
14131 initialize_breakpoint_ops ();
14133 ops
= &catch_exception_breakpoint_ops
;
14134 *ops
= bkpt_breakpoint_ops
;
14135 ops
->allocate_location
= allocate_location_exception
;
14136 ops
->re_set
= re_set_exception
;
14137 ops
->check_status
= check_status_exception
;
14138 ops
->print_it
= print_it_exception
;
14139 ops
->print_one
= print_one_exception
;
14140 ops
->print_mention
= print_mention_exception
;
14141 ops
->print_recreate
= print_recreate_exception
;
14143 ops
= &catch_exception_unhandled_breakpoint_ops
;
14144 *ops
= bkpt_breakpoint_ops
;
14145 ops
->allocate_location
= allocate_location_exception
;
14146 ops
->re_set
= re_set_exception
;
14147 ops
->check_status
= check_status_exception
;
14148 ops
->print_it
= print_it_exception
;
14149 ops
->print_one
= print_one_exception
;
14150 ops
->print_mention
= print_mention_exception
;
14151 ops
->print_recreate
= print_recreate_exception
;
14153 ops
= &catch_assert_breakpoint_ops
;
14154 *ops
= bkpt_breakpoint_ops
;
14155 ops
->allocate_location
= allocate_location_exception
;
14156 ops
->re_set
= re_set_exception
;
14157 ops
->check_status
= check_status_exception
;
14158 ops
->print_it
= print_it_exception
;
14159 ops
->print_one
= print_one_exception
;
14160 ops
->print_mention
= print_mention_exception
;
14161 ops
->print_recreate
= print_recreate_exception
;
14163 ops
= &catch_handlers_breakpoint_ops
;
14164 *ops
= bkpt_breakpoint_ops
;
14165 ops
->allocate_location
= allocate_location_exception
;
14166 ops
->re_set
= re_set_exception
;
14167 ops
->check_status
= check_status_exception
;
14168 ops
->print_it
= print_it_exception
;
14169 ops
->print_one
= print_one_exception
;
14170 ops
->print_mention
= print_mention_exception
;
14171 ops
->print_recreate
= print_recreate_exception
;
14174 /* This module's 'new_objfile' observer. */
14177 ada_new_objfile_observer (struct objfile
*objfile
)
14179 ada_clear_symbol_cache ();
14182 /* This module's 'free_objfile' observer. */
14185 ada_free_objfile_observer (struct objfile
*objfile
)
14187 ada_clear_symbol_cache ();
14190 void _initialize_ada_language ();
14192 _initialize_ada_language ()
14194 initialize_ada_catchpoint_ops ();
14196 add_basic_prefix_cmd ("ada", no_class
,
14197 _("Prefix command for changing Ada-specific settings."),
14198 &set_ada_list
, "set ada ", 0, &setlist
);
14200 add_show_prefix_cmd ("ada", no_class
,
14201 _("Generic command for showing Ada-specific settings."),
14202 &show_ada_list
, "show ada ", 0, &showlist
);
14204 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
14205 &trust_pad_over_xvs
, _("\
14206 Enable or disable an optimization trusting PAD types over XVS types."), _("\
14207 Show whether an optimization trusting PAD types over XVS types is activated."),
14209 This is related to the encoding used by the GNAT compiler. The debugger\n\
14210 should normally trust the contents of PAD types, but certain older versions\n\
14211 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14212 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14213 work around this bug. It is always safe to turn this option \"off\", but\n\
14214 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14215 this option to \"off\" unless necessary."),
14216 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14218 add_setshow_boolean_cmd ("print-signatures", class_vars
,
14219 &print_signatures
, _("\
14220 Enable or disable the output of formal and return types for functions in the \
14221 overloads selection menu."), _("\
14222 Show whether the output of formal and return types for functions in the \
14223 overloads selection menu is activated."),
14224 NULL
, NULL
, NULL
, &set_ada_list
, &show_ada_list
);
14226 add_catch_command ("exception", _("\
14227 Catch Ada exceptions, when raised.\n\
14228 Usage: catch exception [ARG] [if CONDITION]\n\
14229 Without any argument, stop when any Ada exception is raised.\n\
14230 If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\
14231 being raised does not have a handler (and will therefore lead to the task's\n\
14233 Otherwise, the catchpoint only stops when the name of the exception being\n\
14234 raised is the same as ARG.\n\
14235 CONDITION is a boolean expression that is evaluated to see whether the\n\
14236 exception should cause a stop."),
14237 catch_ada_exception_command
,
14238 catch_ada_completer
,
14242 add_catch_command ("handlers", _("\
14243 Catch Ada exceptions, when handled.\n\
14244 Usage: catch handlers [ARG] [if CONDITION]\n\
14245 Without any argument, stop when any Ada exception is handled.\n\
14246 With an argument, catch only exceptions with the given name.\n\
14247 CONDITION is a boolean expression that is evaluated to see whether the\n\
14248 exception should cause a stop."),
14249 catch_ada_handlers_command
,
14250 catch_ada_completer
,
14253 add_catch_command ("assert", _("\
14254 Catch failed Ada assertions, when raised.\n\
14255 Usage: catch assert [if CONDITION]\n\
14256 CONDITION is a boolean expression that is evaluated to see whether the\n\
14257 exception should cause a stop."),
14258 catch_assert_command
,
14263 varsize_limit
= 65536;
14264 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
14265 &varsize_limit
, _("\
14266 Set the maximum number of bytes allowed in a variable-size object."), _("\
14267 Show the maximum number of bytes allowed in a variable-size object."), _("\
14268 Attempts to access an object whose size is not a compile-time constant\n\
14269 and exceeds this limit will cause an error."),
14270 NULL
, NULL
, &setlist
, &showlist
);
14272 add_info ("exceptions", info_exceptions_command
,
14274 List all Ada exception names.\n\
14275 Usage: info exceptions [REGEXP]\n\
14276 If a regular expression is passed as an argument, only those matching\n\
14277 the regular expression are listed."));
14279 add_basic_prefix_cmd ("ada", class_maintenance
,
14280 _("Set Ada maintenance-related variables."),
14281 &maint_set_ada_cmdlist
, "maintenance set ada ",
14282 0/*allow-unknown*/, &maintenance_set_cmdlist
);
14284 add_show_prefix_cmd ("ada", class_maintenance
,
14285 _("Show Ada maintenance-related variables."),
14286 &maint_show_ada_cmdlist
, "maintenance show ada ",
14287 0/*allow-unknown*/, &maintenance_show_cmdlist
);
14289 add_setshow_boolean_cmd
14290 ("ignore-descriptive-types", class_maintenance
,
14291 &ada_ignore_descriptive_types_p
,
14292 _("Set whether descriptive types generated by GNAT should be ignored."),
14293 _("Show whether descriptive types generated by GNAT should be ignored."),
14295 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14296 DWARF attribute."),
14297 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
14299 decoded_names_store
= htab_create_alloc (256, htab_hash_string
, streq_hash
,
14300 NULL
, xcalloc
, xfree
);
14302 /* The ada-lang observers. */
14303 gdb::observers::new_objfile
.attach (ada_new_objfile_observer
);
14304 gdb::observers::free_objfile
.attach (ada_free_objfile_observer
);
14305 gdb::observers::inferior_exit
.attach (ada_inferior_exit
);