1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2018 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
24 #include "gdb_regex.h"
29 #include "expression.h"
30 #include "parser-defs.h"
37 #include "breakpoint.h"
40 #include "gdb_obstack.h"
42 #include "completer.h"
47 #include "dictionary.h"
55 #include "typeprint.h"
56 #include "namespace.h"
60 #include "mi/mi-common.h"
61 #include "arch-utils.h"
62 #include "cli/cli-utils.h"
63 #include "common/function-view.h"
64 #include "common/byte-vector.h"
67 /* Define whether or not the C operator '/' truncates towards zero for
68 differently signed operands (truncation direction is undefined in C).
69 Copied from valarith.c. */
71 #ifndef TRUNCATION_TOWARDS_ZERO
72 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
75 static struct type *desc_base_type (struct type *);
77 static struct type *desc_bounds_type (struct type *);
79 static struct value *desc_bounds (struct value *);
81 static int fat_pntr_bounds_bitpos (struct type *);
83 static int fat_pntr_bounds_bitsize (struct type *);
85 static struct type *desc_data_target_type (struct type *);
87 static struct value *desc_data (struct value *);
89 static int fat_pntr_data_bitpos (struct type *);
91 static int fat_pntr_data_bitsize (struct type *);
93 static struct value *desc_one_bound (struct value *, int, int);
95 static int desc_bound_bitpos (struct type *, int, int);
97 static int desc_bound_bitsize (struct type *, int, int);
99 static struct type *desc_index_type (struct type *, int);
101 static int desc_arity (struct type *);
103 static int ada_type_match (struct type *, struct type *, int);
105 static int ada_args_match (struct symbol *, struct value **, int);
107 static struct value *make_array_descriptor (struct type *, struct value *);
109 static void ada_add_block_symbols (struct obstack *,
110 const struct block *,
111 const lookup_name_info &lookup_name,
112 domain_enum, struct objfile *);
114 static void ada_add_all_symbols (struct obstack *, const struct block *,
115 const lookup_name_info &lookup_name,
116 domain_enum, int, int *);
118 static int is_nonfunction (struct block_symbol *, int);
120 static void add_defn_to_vec (struct obstack *, struct symbol *,
121 const struct block *);
123 static int num_defns_collected (struct obstack *);
125 static struct block_symbol *defns_collected (struct obstack *, int);
127 static struct value *resolve_subexp (expression_up *, int *, int,
130 static void replace_operator_with_call (expression_up *, int, int, int,
131 struct symbol *, const struct block *);
133 static int possible_user_operator_p (enum exp_opcode, struct value **);
135 static const char *ada_op_name (enum exp_opcode);
137 static const char *ada_decoded_op_name (enum exp_opcode);
139 static int numeric_type_p (struct type *);
141 static int integer_type_p (struct type *);
143 static int scalar_type_p (struct type *);
145 static int discrete_type_p (struct type *);
147 static enum ada_renaming_category parse_old_style_renaming (struct type *,
152 static struct symbol *find_old_style_renaming_symbol (const char *,
153 const struct block *);
155 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
158 static struct value *evaluate_subexp_type (struct expression *, int *);
160 static struct type *ada_find_parallel_type_with_name (struct type *,
163 static int is_dynamic_field (struct type *, int);
165 static struct type *to_fixed_variant_branch_type (struct type *,
167 CORE_ADDR, struct value *);
169 static struct type *to_fixed_array_type (struct type *, struct value *, int);
171 static struct type *to_fixed_range_type (struct type *, struct value *);
173 static struct type *to_static_fixed_type (struct type *);
174 static struct type *static_unwrap_type (struct type *type);
176 static struct value *unwrap_value (struct value *);
178 static struct type *constrained_packed_array_type (struct type *, long *);
180 static struct type *decode_constrained_packed_array_type (struct type *);
182 static long decode_packed_array_bitsize (struct type *);
184 static struct value *decode_constrained_packed_array (struct value *);
186 static int ada_is_packed_array_type (struct type *);
188 static int ada_is_unconstrained_packed_array_type (struct type *);
190 static struct value *value_subscript_packed (struct value *, int,
193 static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
195 static struct value *coerce_unspec_val_to_type (struct value *,
198 static int lesseq_defined_than (struct symbol *, struct symbol *);
200 static int equiv_types (struct type *, struct type *);
202 static int is_name_suffix (const char *);
204 static int advance_wild_match (const char **, const char *, int);
206 static bool wild_match (const char *name, const char *patn);
208 static struct value *ada_coerce_ref (struct value *);
210 static LONGEST pos_atr (struct value *);
212 static struct value *value_pos_atr (struct type *, struct value *);
214 static struct value *value_val_atr (struct type *, struct value *);
216 static struct symbol *standard_lookup (const char *, const struct block *,
219 static struct value *ada_search_struct_field (const char *, struct value *, int,
222 static struct value *ada_value_primitive_field (struct value *, int, int,
225 static int find_struct_field (const char *, struct type *, int,
226 struct type **, int *, int *, int *, int *);
228 static int ada_resolve_function (struct block_symbol *, int,
229 struct value **, int, const char *,
232 static int ada_is_direct_array_type (struct type *);
234 static void ada_language_arch_info (struct gdbarch *,
235 struct language_arch_info *);
237 static struct value *ada_index_struct_field (int, struct value *, int,
240 static struct value *assign_aggregate (struct value *, struct value *,
244 static void aggregate_assign_from_choices (struct value *, struct value *,
246 int *, LONGEST *, int *,
247 int, LONGEST, LONGEST);
249 static void aggregate_assign_positional (struct value *, struct value *,
251 int *, LONGEST *, int *, int,
255 static void aggregate_assign_others (struct value *, struct value *,
257 int *, LONGEST *, int, LONGEST, LONGEST);
260 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
263 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
266 static void ada_forward_operator_length (struct expression *, int, int *,
269 static struct type *ada_find_any_type (const char *name);
271 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
272 (const lookup_name_info &lookup_name);
276 /* The result of a symbol lookup to be stored in our symbol cache. */
280 /* The name used to perform the lookup. */
282 /* The namespace used during the lookup. */
284 /* The symbol returned by the lookup, or NULL if no matching symbol
287 /* The block where the symbol was found, or NULL if no matching
289 const struct block *block;
290 /* A pointer to the next entry with the same hash. */
291 struct cache_entry *next;
294 /* The Ada symbol cache, used to store the result of Ada-mode symbol
295 lookups in the course of executing the user's commands.
297 The cache is implemented using a simple, fixed-sized hash.
298 The size is fixed on the grounds that there are not likely to be
299 all that many symbols looked up during any given session, regardless
300 of the size of the symbol table. If we decide to go to a resizable
301 table, let's just use the stuff from libiberty instead. */
303 #define HASH_SIZE 1009
305 struct ada_symbol_cache
307 /* An obstack used to store the entries in our cache. */
308 struct obstack cache_space;
310 /* The root of the hash table used to implement our symbol cache. */
311 struct cache_entry *root[HASH_SIZE];
314 static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
316 /* Maximum-sized dynamic type. */
317 static unsigned int varsize_limit;
319 static const char ada_completer_word_break_characters[] =
321 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
323 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
326 /* The name of the symbol to use to get the name of the main subprogram. */
327 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
328 = "__gnat_ada_main_program_name";
330 /* Limit on the number of warnings to raise per expression evaluation. */
331 static int warning_limit = 2;
333 /* Number of warning messages issued; reset to 0 by cleanups after
334 expression evaluation. */
335 static int warnings_issued = 0;
337 static const char *known_runtime_file_name_patterns[] = {
338 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
341 static const char *known_auxiliary_function_name_patterns[] = {
342 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
345 /* Maintenance-related settings for this module. */
347 static struct cmd_list_element *maint_set_ada_cmdlist;
348 static struct cmd_list_element *maint_show_ada_cmdlist;
350 /* Implement the "maintenance set ada" (prefix) command. */
353 maint_set_ada_cmd (const char *args, int from_tty)
355 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
359 /* Implement the "maintenance show ada" (prefix) command. */
362 maint_show_ada_cmd (const char *args, int from_tty)
364 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
367 /* The "maintenance ada set/show ignore-descriptive-type" value. */
369 static int ada_ignore_descriptive_types_p = 0;
371 /* Inferior-specific data. */
373 /* Per-inferior data for this module. */
375 struct ada_inferior_data
377 /* The ada__tags__type_specific_data type, which is used when decoding
378 tagged types. With older versions of GNAT, this type was directly
379 accessible through a component ("tsd") in the object tag. But this
380 is no longer the case, so we cache it for each inferior. */
381 struct type *tsd_type;
383 /* The exception_support_info data. This data is used to determine
384 how to implement support for Ada exception catchpoints in a given
386 const struct exception_support_info *exception_info;
389 /* Our key to this module's inferior data. */
390 static const struct inferior_data *ada_inferior_data;
392 /* A cleanup routine for our inferior data. */
394 ada_inferior_data_cleanup (struct inferior *inf, void *arg)
396 struct ada_inferior_data *data;
398 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
403 /* Return our inferior data for the given inferior (INF).
405 This function always returns a valid pointer to an allocated
406 ada_inferior_data structure. If INF's inferior data has not
407 been previously set, this functions creates a new one with all
408 fields set to zero, sets INF's inferior to it, and then returns
409 a pointer to that newly allocated ada_inferior_data. */
411 static struct ada_inferior_data *
412 get_ada_inferior_data (struct inferior *inf)
414 struct ada_inferior_data *data;
416 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
419 data = XCNEW (struct ada_inferior_data);
420 set_inferior_data (inf, ada_inferior_data, data);
426 /* Perform all necessary cleanups regarding our module's inferior data
427 that is required after the inferior INF just exited. */
430 ada_inferior_exit (struct inferior *inf)
432 ada_inferior_data_cleanup (inf, NULL);
433 set_inferior_data (inf, ada_inferior_data, NULL);
437 /* program-space-specific data. */
439 /* This module's per-program-space data. */
440 struct ada_pspace_data
442 /* The Ada symbol cache. */
443 struct ada_symbol_cache *sym_cache;
446 /* Key to our per-program-space data. */
447 static const struct program_space_data *ada_pspace_data_handle;
449 /* Return this module's data for the given program space (PSPACE).
450 If not is found, add a zero'ed one now.
452 This function always returns a valid object. */
454 static struct ada_pspace_data *
455 get_ada_pspace_data (struct program_space *pspace)
457 struct ada_pspace_data *data;
459 data = ((struct ada_pspace_data *)
460 program_space_data (pspace, ada_pspace_data_handle));
463 data = XCNEW (struct ada_pspace_data);
464 set_program_space_data (pspace, ada_pspace_data_handle, data);
470 /* The cleanup callback for this module's per-program-space data. */
473 ada_pspace_data_cleanup (struct program_space *pspace, void *data)
475 struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data;
477 if (pspace_data->sym_cache != NULL)
478 ada_free_symbol_cache (pspace_data->sym_cache);
484 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
485 all typedef layers have been peeled. Otherwise, return TYPE.
487 Normally, we really expect a typedef type to only have 1 typedef layer.
488 In other words, we really expect the target type of a typedef type to be
489 a non-typedef type. This is particularly true for Ada units, because
490 the language does not have a typedef vs not-typedef distinction.
491 In that respect, the Ada compiler has been trying to eliminate as many
492 typedef definitions in the debugging information, since they generally
493 do not bring any extra information (we still use typedef under certain
494 circumstances related mostly to the GNAT encoding).
496 Unfortunately, we have seen situations where the debugging information
497 generated by the compiler leads to such multiple typedef layers. For
498 instance, consider the following example with stabs:
500 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
501 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
503 This is an error in the debugging information which causes type
504 pck__float_array___XUP to be defined twice, and the second time,
505 it is defined as a typedef of a typedef.
507 This is on the fringe of legality as far as debugging information is
508 concerned, and certainly unexpected. But it is easy to handle these
509 situations correctly, so we can afford to be lenient in this case. */
512 ada_typedef_target_type (struct type *type)
514 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
515 type = TYPE_TARGET_TYPE (type);
519 /* Given DECODED_NAME a string holding a symbol name in its
520 decoded form (ie using the Ada dotted notation), returns
521 its unqualified name. */
524 ada_unqualified_name (const char *decoded_name)
528 /* If the decoded name starts with '<', it means that the encoded
529 name does not follow standard naming conventions, and thus that
530 it is not your typical Ada symbol name. Trying to unqualify it
531 is therefore pointless and possibly erroneous. */
532 if (decoded_name[0] == '<')
535 result = strrchr (decoded_name, '.');
537 result++; /* Skip the dot... */
539 result = decoded_name;
544 /* Return a string starting with '<', followed by STR, and '>'.
545 The result is good until the next call. */
548 add_angle_brackets (const char *str)
550 static char *result = NULL;
553 result = xstrprintf ("<%s>", str);
558 ada_get_gdb_completer_word_break_characters (void)
560 return ada_completer_word_break_characters;
563 /* Print an array element index using the Ada syntax. */
566 ada_print_array_index (struct value *index_value, struct ui_file *stream,
567 const struct value_print_options *options)
569 LA_VALUE_PRINT (index_value, stream, options);
570 fprintf_filtered (stream, " => ");
573 /* Assuming VECT points to an array of *SIZE objects of size
574 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
575 updating *SIZE as necessary and returning the (new) array. */
578 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
580 if (*size < min_size)
583 if (*size < min_size)
585 vect = xrealloc (vect, *size * element_size);
590 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
591 suffix of FIELD_NAME beginning "___". */
594 field_name_match (const char *field_name, const char *target)
596 int len = strlen (target);
599 (strncmp (field_name, target, len) == 0
600 && (field_name[len] == '\0'
601 || (startswith (field_name + len, "___")
602 && strcmp (field_name + strlen (field_name) - 6,
607 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
608 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
609 and return its index. This function also handles fields whose name
610 have ___ suffixes because the compiler sometimes alters their name
611 by adding such a suffix to represent fields with certain constraints.
612 If the field could not be found, return a negative number if
613 MAYBE_MISSING is set. Otherwise raise an error. */
616 ada_get_field_index (const struct type *type, const char *field_name,
620 struct type *struct_type = check_typedef ((struct type *) type);
622 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
623 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
627 error (_("Unable to find field %s in struct %s. Aborting"),
628 field_name, TYPE_NAME (struct_type));
633 /* The length of the prefix of NAME prior to any "___" suffix. */
636 ada_name_prefix_len (const char *name)
642 const char *p = strstr (name, "___");
645 return strlen (name);
651 /* Return non-zero if SUFFIX is a suffix of STR.
652 Return zero if STR is null. */
655 is_suffix (const char *str, const char *suffix)
662 len2 = strlen (suffix);
663 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
666 /* The contents of value VAL, treated as a value of type TYPE. The
667 result is an lval in memory if VAL is. */
669 static struct value *
670 coerce_unspec_val_to_type (struct value *val, struct type *type)
672 type = ada_check_typedef (type);
673 if (value_type (val) == type)
677 struct value *result;
679 /* Make sure that the object size is not unreasonable before
680 trying to allocate some memory for it. */
681 ada_ensure_varsize_limit (type);
684 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
685 result = allocate_value_lazy (type);
688 result = allocate_value (type);
689 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
691 set_value_component_location (result, val);
692 set_value_bitsize (result, value_bitsize (val));
693 set_value_bitpos (result, value_bitpos (val));
694 set_value_address (result, value_address (val));
699 static const gdb_byte *
700 cond_offset_host (const gdb_byte *valaddr, long offset)
705 return valaddr + offset;
709 cond_offset_target (CORE_ADDR address, long offset)
714 return address + offset;
717 /* Issue a warning (as for the definition of warning in utils.c, but
718 with exactly one argument rather than ...), unless the limit on the
719 number of warnings has passed during the evaluation of the current
722 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
723 provided by "complaint". */
724 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
727 lim_warning (const char *format, ...)
731 va_start (args, format);
732 warnings_issued += 1;
733 if (warnings_issued <= warning_limit)
734 vwarning (format, args);
739 /* Issue an error if the size of an object of type T is unreasonable,
740 i.e. if it would be a bad idea to allocate a value of this type in
744 ada_ensure_varsize_limit (const struct type *type)
746 if (TYPE_LENGTH (type) > varsize_limit)
747 error (_("object size is larger than varsize-limit"));
750 /* Maximum value of a SIZE-byte signed integer type. */
752 max_of_size (int size)
754 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
756 return top_bit | (top_bit - 1);
759 /* Minimum value of a SIZE-byte signed integer type. */
761 min_of_size (int size)
763 return -max_of_size (size) - 1;
766 /* Maximum value of a SIZE-byte unsigned integer type. */
768 umax_of_size (int size)
770 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
772 return top_bit | (top_bit - 1);
775 /* Maximum value of integral type T, as a signed quantity. */
777 max_of_type (struct type *t)
779 if (TYPE_UNSIGNED (t))
780 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
782 return max_of_size (TYPE_LENGTH (t));
785 /* Minimum value of integral type T, as a signed quantity. */
787 min_of_type (struct type *t)
789 if (TYPE_UNSIGNED (t))
792 return min_of_size (TYPE_LENGTH (t));
795 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
797 ada_discrete_type_high_bound (struct type *type)
799 type = resolve_dynamic_type (type, NULL, 0);
800 switch (TYPE_CODE (type))
802 case TYPE_CODE_RANGE:
803 return TYPE_HIGH_BOUND (type);
805 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
810 return max_of_type (type);
812 error (_("Unexpected type in ada_discrete_type_high_bound."));
816 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
818 ada_discrete_type_low_bound (struct type *type)
820 type = resolve_dynamic_type (type, NULL, 0);
821 switch (TYPE_CODE (type))
823 case TYPE_CODE_RANGE:
824 return TYPE_LOW_BOUND (type);
826 return TYPE_FIELD_ENUMVAL (type, 0);
831 return min_of_type (type);
833 error (_("Unexpected type in ada_discrete_type_low_bound."));
837 /* The identity on non-range types. For range types, the underlying
838 non-range scalar type. */
841 get_base_type (struct type *type)
843 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
845 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
847 type = TYPE_TARGET_TYPE (type);
852 /* Return a decoded version of the given VALUE. This means returning
853 a value whose type is obtained by applying all the GNAT-specific
854 encondings, making the resulting type a static but standard description
855 of the initial type. */
858 ada_get_decoded_value (struct value *value)
860 struct type *type = ada_check_typedef (value_type (value));
862 if (ada_is_array_descriptor_type (type)
863 || (ada_is_constrained_packed_array_type (type)
864 && TYPE_CODE (type) != TYPE_CODE_PTR))
866 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
867 value = ada_coerce_to_simple_array_ptr (value);
869 value = ada_coerce_to_simple_array (value);
872 value = ada_to_fixed_value (value);
877 /* Same as ada_get_decoded_value, but with the given TYPE.
878 Because there is no associated actual value for this type,
879 the resulting type might be a best-effort approximation in
880 the case of dynamic types. */
883 ada_get_decoded_type (struct type *type)
885 type = to_static_fixed_type (type);
886 if (ada_is_constrained_packed_array_type (type))
887 type = ada_coerce_to_simple_array_type (type);
893 /* Language Selection */
895 /* If the main program is in Ada, return language_ada, otherwise return LANG
896 (the main program is in Ada iif the adainit symbol is found). */
899 ada_update_initial_language (enum language lang)
901 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
902 (struct objfile *) NULL).minsym != NULL)
908 /* If the main procedure is written in Ada, then return its name.
909 The result is good until the next call. Return NULL if the main
910 procedure doesn't appear to be in Ada. */
915 struct bound_minimal_symbol msym;
916 static char *main_program_name = NULL;
918 /* For Ada, the name of the main procedure is stored in a specific
919 string constant, generated by the binder. Look for that symbol,
920 extract its address, and then read that string. If we didn't find
921 that string, then most probably the main procedure is not written
923 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
925 if (msym.minsym != NULL)
927 CORE_ADDR main_program_name_addr;
930 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
931 if (main_program_name_addr == 0)
932 error (_("Invalid address for Ada main program name."));
934 xfree (main_program_name);
935 target_read_string (main_program_name_addr, &main_program_name,
940 return main_program_name;
943 /* The main procedure doesn't seem to be in Ada. */
949 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
952 const struct ada_opname_map ada_opname_table[] = {
953 {"Oadd", "\"+\"", BINOP_ADD},
954 {"Osubtract", "\"-\"", BINOP_SUB},
955 {"Omultiply", "\"*\"", BINOP_MUL},
956 {"Odivide", "\"/\"", BINOP_DIV},
957 {"Omod", "\"mod\"", BINOP_MOD},
958 {"Orem", "\"rem\"", BINOP_REM},
959 {"Oexpon", "\"**\"", BINOP_EXP},
960 {"Olt", "\"<\"", BINOP_LESS},
961 {"Ole", "\"<=\"", BINOP_LEQ},
962 {"Ogt", "\">\"", BINOP_GTR},
963 {"Oge", "\">=\"", BINOP_GEQ},
964 {"Oeq", "\"=\"", BINOP_EQUAL},
965 {"One", "\"/=\"", BINOP_NOTEQUAL},
966 {"Oand", "\"and\"", BINOP_BITWISE_AND},
967 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
968 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
969 {"Oconcat", "\"&\"", BINOP_CONCAT},
970 {"Oabs", "\"abs\"", UNOP_ABS},
971 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
972 {"Oadd", "\"+\"", UNOP_PLUS},
973 {"Osubtract", "\"-\"", UNOP_NEG},
977 /* The "encoded" form of DECODED, according to GNAT conventions. The
978 result is valid until the next call to ada_encode. If
979 THROW_ERRORS, throw an error if invalid operator name is found.
980 Otherwise, return NULL in that case. */
983 ada_encode_1 (const char *decoded, bool throw_errors)
985 static char *encoding_buffer = NULL;
986 static size_t encoding_buffer_size = 0;
993 GROW_VECT (encoding_buffer, encoding_buffer_size,
994 2 * strlen (decoded) + 10);
997 for (p = decoded; *p != '\0'; p += 1)
1001 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
1006 const struct ada_opname_map *mapping;
1008 for (mapping = ada_opname_table;
1009 mapping->encoded != NULL
1010 && !startswith (p, mapping->decoded); mapping += 1)
1012 if (mapping->encoded == NULL)
1015 error (_("invalid Ada operator name: %s"), p);
1019 strcpy (encoding_buffer + k, mapping->encoded);
1020 k += strlen (mapping->encoded);
1025 encoding_buffer[k] = *p;
1030 encoding_buffer[k] = '\0';
1031 return encoding_buffer;
1034 /* The "encoded" form of DECODED, according to GNAT conventions.
1035 The result is valid until the next call to ada_encode. */
1038 ada_encode (const char *decoded)
1040 return ada_encode_1 (decoded, true);
1043 /* Return NAME folded to lower case, or, if surrounded by single
1044 quotes, unfolded, but with the quotes stripped away. Result good
1048 ada_fold_name (const char *name)
1050 static char *fold_buffer = NULL;
1051 static size_t fold_buffer_size = 0;
1053 int len = strlen (name);
1054 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
1056 if (name[0] == '\'')
1058 strncpy (fold_buffer, name + 1, len - 2);
1059 fold_buffer[len - 2] = '\000';
1065 for (i = 0; i <= len; i += 1)
1066 fold_buffer[i] = tolower (name[i]);
1072 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1075 is_lower_alphanum (const char c)
1077 return (isdigit (c) || (isalpha (c) && islower (c)));
1080 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1081 This function saves in LEN the length of that same symbol name but
1082 without either of these suffixes:
1088 These are suffixes introduced by the compiler for entities such as
1089 nested subprogram for instance, in order to avoid name clashes.
1090 They do not serve any purpose for the debugger. */
1093 ada_remove_trailing_digits (const char *encoded, int *len)
1095 if (*len > 1 && isdigit (encoded[*len - 1]))
1099 while (i > 0 && isdigit (encoded[i]))
1101 if (i >= 0 && encoded[i] == '.')
1103 else if (i >= 0 && encoded[i] == '$')
1105 else if (i >= 2 && startswith (encoded + i - 2, "___"))
1107 else if (i >= 1 && startswith (encoded + i - 1, "__"))
1112 /* Remove the suffix introduced by the compiler for protected object
1116 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1118 /* Remove trailing N. */
1120 /* Protected entry subprograms are broken into two
1121 separate subprograms: The first one is unprotected, and has
1122 a 'N' suffix; the second is the protected version, and has
1123 the 'P' suffix. The second calls the first one after handling
1124 the protection. Since the P subprograms are internally generated,
1125 we leave these names undecoded, giving the user a clue that this
1126 entity is internal. */
1129 && encoded[*len - 1] == 'N'
1130 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1134 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1137 ada_remove_Xbn_suffix (const char *encoded, int *len)
1141 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1144 if (encoded[i] != 'X')
1150 if (isalnum (encoded[i-1]))
1154 /* If ENCODED follows the GNAT entity encoding conventions, then return
1155 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1156 replaced by ENCODED.
1158 The resulting string is valid until the next call of ada_decode.
1159 If the string is unchanged by decoding, the original string pointer
1163 ada_decode (const char *encoded)
1170 static char *decoding_buffer = NULL;
1171 static size_t decoding_buffer_size = 0;
1173 /* The name of the Ada main procedure starts with "_ada_".
1174 This prefix is not part of the decoded name, so skip this part
1175 if we see this prefix. */
1176 if (startswith (encoded, "_ada_"))
1179 /* If the name starts with '_', then it is not a properly encoded
1180 name, so do not attempt to decode it. Similarly, if the name
1181 starts with '<', the name should not be decoded. */
1182 if (encoded[0] == '_' || encoded[0] == '<')
1185 len0 = strlen (encoded);
1187 ada_remove_trailing_digits (encoded, &len0);
1188 ada_remove_po_subprogram_suffix (encoded, &len0);
1190 /* Remove the ___X.* suffix if present. Do not forget to verify that
1191 the suffix is located before the current "end" of ENCODED. We want
1192 to avoid re-matching parts of ENCODED that have previously been
1193 marked as discarded (by decrementing LEN0). */
1194 p = strstr (encoded, "___");
1195 if (p != NULL && p - encoded < len0 - 3)
1203 /* Remove any trailing TKB suffix. It tells us that this symbol
1204 is for the body of a task, but that information does not actually
1205 appear in the decoded name. */
1207 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1210 /* Remove any trailing TB suffix. The TB suffix is slightly different
1211 from the TKB suffix because it is used for non-anonymous task
1214 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1217 /* Remove trailing "B" suffixes. */
1218 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1220 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1223 /* Make decoded big enough for possible expansion by operator name. */
1225 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1226 decoded = decoding_buffer;
1228 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1230 if (len0 > 1 && isdigit (encoded[len0 - 1]))
1233 while ((i >= 0 && isdigit (encoded[i]))
1234 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1236 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1238 else if (encoded[i] == '$')
1242 /* The first few characters that are not alphabetic are not part
1243 of any encoding we use, so we can copy them over verbatim. */
1245 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1246 decoded[j] = encoded[i];
1251 /* Is this a symbol function? */
1252 if (at_start_name && encoded[i] == 'O')
1256 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1258 int op_len = strlen (ada_opname_table[k].encoded);
1259 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1261 && !isalnum (encoded[i + op_len]))
1263 strcpy (decoded + j, ada_opname_table[k].decoded);
1266 j += strlen (ada_opname_table[k].decoded);
1270 if (ada_opname_table[k].encoded != NULL)
1275 /* Replace "TK__" with "__", which will eventually be translated
1276 into "." (just below). */
1278 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1281 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1282 be translated into "." (just below). These are internal names
1283 generated for anonymous blocks inside which our symbol is nested. */
1285 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1286 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1287 && isdigit (encoded [i+4]))
1291 while (k < len0 && isdigit (encoded[k]))
1292 k++; /* Skip any extra digit. */
1294 /* Double-check that the "__B_{DIGITS}+" sequence we found
1295 is indeed followed by "__". */
1296 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1300 /* Remove _E{DIGITS}+[sb] */
1302 /* Just as for protected object subprograms, there are 2 categories
1303 of subprograms created by the compiler for each entry. The first
1304 one implements the actual entry code, and has a suffix following
1305 the convention above; the second one implements the barrier and
1306 uses the same convention as above, except that the 'E' is replaced
1309 Just as above, we do not decode the name of barrier functions
1310 to give the user a clue that the code he is debugging has been
1311 internally generated. */
1313 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1314 && isdigit (encoded[i+2]))
1318 while (k < len0 && isdigit (encoded[k]))
1322 && (encoded[k] == 'b' || encoded[k] == 's'))
1325 /* Just as an extra precaution, make sure that if this
1326 suffix is followed by anything else, it is a '_'.
1327 Otherwise, we matched this sequence by accident. */
1329 || (k < len0 && encoded[k] == '_'))
1334 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1335 the GNAT front-end in protected object subprograms. */
1338 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1340 /* Backtrack a bit up until we reach either the begining of
1341 the encoded name, or "__". Make sure that we only find
1342 digits or lowercase characters. */
1343 const char *ptr = encoded + i - 1;
1345 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1348 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1352 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1354 /* This is a X[bn]* sequence not separated from the previous
1355 part of the name with a non-alpha-numeric character (in other
1356 words, immediately following an alpha-numeric character), then
1357 verify that it is placed at the end of the encoded name. If
1358 not, then the encoding is not valid and we should abort the
1359 decoding. Otherwise, just skip it, it is used in body-nested
1363 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1367 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1369 /* Replace '__' by '.'. */
1377 /* It's a character part of the decoded name, so just copy it
1379 decoded[j] = encoded[i];
1384 decoded[j] = '\000';
1386 /* Decoded names should never contain any uppercase character.
1387 Double-check this, and abort the decoding if we find one. */
1389 for (i = 0; decoded[i] != '\0'; i += 1)
1390 if (isupper (decoded[i]) || decoded[i] == ' ')
1393 if (strcmp (decoded, encoded) == 0)
1399 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1400 decoded = decoding_buffer;
1401 if (encoded[0] == '<')
1402 strcpy (decoded, encoded);
1404 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
1409 /* Table for keeping permanent unique copies of decoded names. Once
1410 allocated, names in this table are never released. While this is a
1411 storage leak, it should not be significant unless there are massive
1412 changes in the set of decoded names in successive versions of a
1413 symbol table loaded during a single session. */
1414 static struct htab *decoded_names_store;
1416 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1417 in the language-specific part of GSYMBOL, if it has not been
1418 previously computed. Tries to save the decoded name in the same
1419 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1420 in any case, the decoded symbol has a lifetime at least that of
1422 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1423 const, but nevertheless modified to a semantically equivalent form
1424 when a decoded name is cached in it. */
1427 ada_decode_symbol (const struct general_symbol_info *arg)
1429 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1430 const char **resultp =
1431 &gsymbol->language_specific.demangled_name;
1433 if (!gsymbol->ada_mangled)
1435 const char *decoded = ada_decode (gsymbol->name);
1436 struct obstack *obstack = gsymbol->language_specific.obstack;
1438 gsymbol->ada_mangled = 1;
1440 if (obstack != NULL)
1442 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
1445 /* Sometimes, we can't find a corresponding objfile, in
1446 which case, we put the result on the heap. Since we only
1447 decode when needed, we hope this usually does not cause a
1448 significant memory leak (FIXME). */
1450 char **slot = (char **) htab_find_slot (decoded_names_store,
1454 *slot = xstrdup (decoded);
1463 ada_la_decode (const char *encoded, int options)
1465 return xstrdup (ada_decode (encoded));
1468 /* Implement la_sniff_from_mangled_name for Ada. */
1471 ada_sniff_from_mangled_name (const char *mangled, char **out)
1473 const char *demangled = ada_decode (mangled);
1477 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1479 /* Set the gsymbol language to Ada, but still return 0.
1480 Two reasons for that:
1482 1. For Ada, we prefer computing the symbol's decoded name
1483 on the fly rather than pre-compute it, in order to save
1484 memory (Ada projects are typically very large).
1486 2. There are some areas in the definition of the GNAT
1487 encoding where, with a bit of bad luck, we might be able
1488 to decode a non-Ada symbol, generating an incorrect
1489 demangled name (Eg: names ending with "TB" for instance
1490 are identified as task bodies and so stripped from
1491 the decoded name returned).
1493 Returning 1, here, but not setting *DEMANGLED, helps us get a
1494 little bit of the best of both worlds. Because we're last,
1495 we should not affect any of the other languages that were
1496 able to demangle the symbol before us; we get to correctly
1497 tag Ada symbols as such; and even if we incorrectly tagged a
1498 non-Ada symbol, which should be rare, any routing through the
1499 Ada language should be transparent (Ada tries to behave much
1500 like C/C++ with non-Ada symbols). */
1511 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1512 generated by the GNAT compiler to describe the index type used
1513 for each dimension of an array, check whether it follows the latest
1514 known encoding. If not, fix it up to conform to the latest encoding.
1515 Otherwise, do nothing. This function also does nothing if
1516 INDEX_DESC_TYPE is NULL.
1518 The GNAT encoding used to describle the array index type evolved a bit.
1519 Initially, the information would be provided through the name of each
1520 field of the structure type only, while the type of these fields was
1521 described as unspecified and irrelevant. The debugger was then expected
1522 to perform a global type lookup using the name of that field in order
1523 to get access to the full index type description. Because these global
1524 lookups can be very expensive, the encoding was later enhanced to make
1525 the global lookup unnecessary by defining the field type as being
1526 the full index type description.
1528 The purpose of this routine is to allow us to support older versions
1529 of the compiler by detecting the use of the older encoding, and by
1530 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1531 we essentially replace each field's meaningless type by the associated
1535 ada_fixup_array_indexes_type (struct type *index_desc_type)
1539 if (index_desc_type == NULL)
1541 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1543 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1544 to check one field only, no need to check them all). If not, return
1547 If our INDEX_DESC_TYPE was generated using the older encoding,
1548 the field type should be a meaningless integer type whose name
1549 is not equal to the field name. */
1550 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1551 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1552 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1555 /* Fixup each field of INDEX_DESC_TYPE. */
1556 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1558 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1559 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1562 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1566 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1568 static const char *bound_name[] = {
1569 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1570 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1573 /* Maximum number of array dimensions we are prepared to handle. */
1575 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1578 /* The desc_* routines return primitive portions of array descriptors
1581 /* The descriptor or array type, if any, indicated by TYPE; removes
1582 level of indirection, if needed. */
1584 static struct type *
1585 desc_base_type (struct type *type)
1589 type = ada_check_typedef (type);
1590 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1591 type = ada_typedef_target_type (type);
1594 && (TYPE_CODE (type) == TYPE_CODE_PTR
1595 || TYPE_CODE (type) == TYPE_CODE_REF))
1596 return ada_check_typedef (TYPE_TARGET_TYPE (type));
1601 /* True iff TYPE indicates a "thin" array pointer type. */
1604 is_thin_pntr (struct type *type)
1607 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1608 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1611 /* The descriptor type for thin pointer type TYPE. */
1613 static struct type *
1614 thin_descriptor_type (struct type *type)
1616 struct type *base_type = desc_base_type (type);
1618 if (base_type == NULL)
1620 if (is_suffix (ada_type_name (base_type), "___XVE"))
1624 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1626 if (alt_type == NULL)
1633 /* A pointer to the array data for thin-pointer value VAL. */
1635 static struct value *
1636 thin_data_pntr (struct value *val)
1638 struct type *type = ada_check_typedef (value_type (val));
1639 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1641 data_type = lookup_pointer_type (data_type);
1643 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1644 return value_cast (data_type, value_copy (val));
1646 return value_from_longest (data_type, value_address (val));
1649 /* True iff TYPE indicates a "thick" array pointer type. */
1652 is_thick_pntr (struct type *type)
1654 type = desc_base_type (type);
1655 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1656 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1659 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1660 pointer to one, the type of its bounds data; otherwise, NULL. */
1662 static struct type *
1663 desc_bounds_type (struct type *type)
1667 type = desc_base_type (type);
1671 else if (is_thin_pntr (type))
1673 type = thin_descriptor_type (type);
1676 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1678 return ada_check_typedef (r);
1680 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1682 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1684 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1689 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1690 one, a pointer to its bounds data. Otherwise NULL. */
1692 static struct value *
1693 desc_bounds (struct value *arr)
1695 struct type *type = ada_check_typedef (value_type (arr));
1697 if (is_thin_pntr (type))
1699 struct type *bounds_type =
1700 desc_bounds_type (thin_descriptor_type (type));
1703 if (bounds_type == NULL)
1704 error (_("Bad GNAT array descriptor"));
1706 /* NOTE: The following calculation is not really kosher, but
1707 since desc_type is an XVE-encoded type (and shouldn't be),
1708 the correct calculation is a real pain. FIXME (and fix GCC). */
1709 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1710 addr = value_as_long (arr);
1712 addr = value_address (arr);
1715 value_from_longest (lookup_pointer_type (bounds_type),
1716 addr - TYPE_LENGTH (bounds_type));
1719 else if (is_thick_pntr (type))
1721 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1722 _("Bad GNAT array descriptor"));
1723 struct type *p_bounds_type = value_type (p_bounds);
1726 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1728 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1730 if (TYPE_STUB (target_type))
1731 p_bounds = value_cast (lookup_pointer_type
1732 (ada_check_typedef (target_type)),
1736 error (_("Bad GNAT array descriptor"));
1744 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1745 position of the field containing the address of the bounds data. */
1748 fat_pntr_bounds_bitpos (struct type *type)
1750 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1753 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1754 size of the field containing the address of the bounds data. */
1757 fat_pntr_bounds_bitsize (struct type *type)
1759 type = desc_base_type (type);
1761 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1762 return TYPE_FIELD_BITSIZE (type, 1);
1764 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1767 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1768 pointer to one, the type of its array data (a array-with-no-bounds type);
1769 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1772 static struct type *
1773 desc_data_target_type (struct type *type)
1775 type = desc_base_type (type);
1777 /* NOTE: The following is bogus; see comment in desc_bounds. */
1778 if (is_thin_pntr (type))
1779 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
1780 else if (is_thick_pntr (type))
1782 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1785 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
1786 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1792 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1795 static struct value *
1796 desc_data (struct value *arr)
1798 struct type *type = value_type (arr);
1800 if (is_thin_pntr (type))
1801 return thin_data_pntr (arr);
1802 else if (is_thick_pntr (type))
1803 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1804 _("Bad GNAT array descriptor"));
1810 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1811 position of the field containing the address of the data. */
1814 fat_pntr_data_bitpos (struct type *type)
1816 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1819 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1820 size of the field containing the address of the data. */
1823 fat_pntr_data_bitsize (struct type *type)
1825 type = desc_base_type (type);
1827 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1828 return TYPE_FIELD_BITSIZE (type, 0);
1830 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1833 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1834 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1835 bound, if WHICH is 1. The first bound is I=1. */
1837 static struct value *
1838 desc_one_bound (struct value *bounds, int i, int which)
1840 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1841 _("Bad GNAT array descriptor bounds"));
1844 /* If BOUNDS is an array-bounds structure type, return the bit position
1845 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1846 bound, if WHICH is 1. The first bound is I=1. */
1849 desc_bound_bitpos (struct type *type, int i, int which)
1851 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1854 /* If BOUNDS is an array-bounds structure type, return the bit field size
1855 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1856 bound, if WHICH is 1. The first bound is I=1. */
1859 desc_bound_bitsize (struct type *type, int i, int which)
1861 type = desc_base_type (type);
1863 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1864 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1866 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1869 /* If TYPE is the type of an array-bounds structure, the type of its
1870 Ith bound (numbering from 1). Otherwise, NULL. */
1872 static struct type *
1873 desc_index_type (struct type *type, int i)
1875 type = desc_base_type (type);
1877 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1878 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1883 /* The number of index positions in the array-bounds type TYPE.
1884 Return 0 if TYPE is NULL. */
1887 desc_arity (struct type *type)
1889 type = desc_base_type (type);
1892 return TYPE_NFIELDS (type) / 2;
1896 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1897 an array descriptor type (representing an unconstrained array
1901 ada_is_direct_array_type (struct type *type)
1905 type = ada_check_typedef (type);
1906 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1907 || ada_is_array_descriptor_type (type));
1910 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1914 ada_is_array_type (struct type *type)
1917 && (TYPE_CODE (type) == TYPE_CODE_PTR
1918 || TYPE_CODE (type) == TYPE_CODE_REF))
1919 type = TYPE_TARGET_TYPE (type);
1920 return ada_is_direct_array_type (type);
1923 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1926 ada_is_simple_array_type (struct type *type)
1930 type = ada_check_typedef (type);
1931 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1932 || (TYPE_CODE (type) == TYPE_CODE_PTR
1933 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1934 == TYPE_CODE_ARRAY));
1937 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1940 ada_is_array_descriptor_type (struct type *type)
1942 struct type *data_type = desc_data_target_type (type);
1946 type = ada_check_typedef (type);
1947 return (data_type != NULL
1948 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1949 && desc_arity (desc_bounds_type (type)) > 0);
1952 /* Non-zero iff type is a partially mal-formed GNAT array
1953 descriptor. FIXME: This is to compensate for some problems with
1954 debugging output from GNAT. Re-examine periodically to see if it
1958 ada_is_bogus_array_descriptor (struct type *type)
1962 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1963 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1964 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1965 && !ada_is_array_descriptor_type (type);
1969 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1970 (fat pointer) returns the type of the array data described---specifically,
1971 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1972 in from the descriptor; otherwise, they are left unspecified. If
1973 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1974 returns NULL. The result is simply the type of ARR if ARR is not
1977 ada_type_of_array (struct value *arr, int bounds)
1979 if (ada_is_constrained_packed_array_type (value_type (arr)))
1980 return decode_constrained_packed_array_type (value_type (arr));
1982 if (!ada_is_array_descriptor_type (value_type (arr)))
1983 return value_type (arr);
1987 struct type *array_type =
1988 ada_check_typedef (desc_data_target_type (value_type (arr)));
1990 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1991 TYPE_FIELD_BITSIZE (array_type, 0) =
1992 decode_packed_array_bitsize (value_type (arr));
1998 struct type *elt_type;
2000 struct value *descriptor;
2002 elt_type = ada_array_element_type (value_type (arr), -1);
2003 arity = ada_array_arity (value_type (arr));
2005 if (elt_type == NULL || arity == 0)
2006 return ada_check_typedef (value_type (arr));
2008 descriptor = desc_bounds (arr);
2009 if (value_as_long (descriptor) == 0)
2013 struct type *range_type = alloc_type_copy (value_type (arr));
2014 struct type *array_type = alloc_type_copy (value_type (arr));
2015 struct value *low = desc_one_bound (descriptor, arity, 0);
2016 struct value *high = desc_one_bound (descriptor, arity, 1);
2019 create_static_range_type (range_type, value_type (low),
2020 longest_to_int (value_as_long (low)),
2021 longest_to_int (value_as_long (high)));
2022 elt_type = create_array_type (array_type, elt_type, range_type);
2024 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2026 /* We need to store the element packed bitsize, as well as
2027 recompute the array size, because it was previously
2028 computed based on the unpacked element size. */
2029 LONGEST lo = value_as_long (low);
2030 LONGEST hi = value_as_long (high);
2032 TYPE_FIELD_BITSIZE (elt_type, 0) =
2033 decode_packed_array_bitsize (value_type (arr));
2034 /* If the array has no element, then the size is already
2035 zero, and does not need to be recomputed. */
2039 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2041 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2046 return lookup_pointer_type (elt_type);
2050 /* If ARR does not represent an array, returns ARR unchanged.
2051 Otherwise, returns either a standard GDB array with bounds set
2052 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2053 GDB array. Returns NULL if ARR is a null fat pointer. */
2056 ada_coerce_to_simple_array_ptr (struct value *arr)
2058 if (ada_is_array_descriptor_type (value_type (arr)))
2060 struct type *arrType = ada_type_of_array (arr, 1);
2062 if (arrType == NULL)
2064 return value_cast (arrType, value_copy (desc_data (arr)));
2066 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2067 return decode_constrained_packed_array (arr);
2072 /* If ARR does not represent an array, returns ARR unchanged.
2073 Otherwise, returns a standard GDB array describing ARR (which may
2074 be ARR itself if it already is in the proper form). */
2077 ada_coerce_to_simple_array (struct value *arr)
2079 if (ada_is_array_descriptor_type (value_type (arr)))
2081 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2084 error (_("Bounds unavailable for null array pointer."));
2085 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
2086 return value_ind (arrVal);
2088 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2089 return decode_constrained_packed_array (arr);
2094 /* If TYPE represents a GNAT array type, return it translated to an
2095 ordinary GDB array type (possibly with BITSIZE fields indicating
2096 packing). For other types, is the identity. */
2099 ada_coerce_to_simple_array_type (struct type *type)
2101 if (ada_is_constrained_packed_array_type (type))
2102 return decode_constrained_packed_array_type (type);
2104 if (ada_is_array_descriptor_type (type))
2105 return ada_check_typedef (desc_data_target_type (type));
2110 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2113 ada_is_packed_array_type (struct type *type)
2117 type = desc_base_type (type);
2118 type = ada_check_typedef (type);
2120 ada_type_name (type) != NULL
2121 && strstr (ada_type_name (type), "___XP") != NULL;
2124 /* Non-zero iff TYPE represents a standard GNAT constrained
2125 packed-array type. */
2128 ada_is_constrained_packed_array_type (struct type *type)
2130 return ada_is_packed_array_type (type)
2131 && !ada_is_array_descriptor_type (type);
2134 /* Non-zero iff TYPE represents an array descriptor for a
2135 unconstrained packed-array type. */
2138 ada_is_unconstrained_packed_array_type (struct type *type)
2140 return ada_is_packed_array_type (type)
2141 && ada_is_array_descriptor_type (type);
2144 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2145 return the size of its elements in bits. */
2148 decode_packed_array_bitsize (struct type *type)
2150 const char *raw_name;
2154 /* Access to arrays implemented as fat pointers are encoded as a typedef
2155 of the fat pointer type. We need the name of the fat pointer type
2156 to do the decoding, so strip the typedef layer. */
2157 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2158 type = ada_typedef_target_type (type);
2160 raw_name = ada_type_name (ada_check_typedef (type));
2162 raw_name = ada_type_name (desc_base_type (type));
2167 tail = strstr (raw_name, "___XP");
2168 gdb_assert (tail != NULL);
2170 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2173 (_("could not understand bit size information on packed array"));
2180 /* Given that TYPE is a standard GDB array type with all bounds filled
2181 in, and that the element size of its ultimate scalar constituents
2182 (that is, either its elements, or, if it is an array of arrays, its
2183 elements' elements, etc.) is *ELT_BITS, return an identical type,
2184 but with the bit sizes of its elements (and those of any
2185 constituent arrays) recorded in the BITSIZE components of its
2186 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2189 Note that, for arrays whose index type has an XA encoding where
2190 a bound references a record discriminant, getting that discriminant,
2191 and therefore the actual value of that bound, is not possible
2192 because none of the given parameters gives us access to the record.
2193 This function assumes that it is OK in the context where it is being
2194 used to return an array whose bounds are still dynamic and where
2195 the length is arbitrary. */
2197 static struct type *
2198 constrained_packed_array_type (struct type *type, long *elt_bits)
2200 struct type *new_elt_type;
2201 struct type *new_type;
2202 struct type *index_type_desc;
2203 struct type *index_type;
2204 LONGEST low_bound, high_bound;
2206 type = ada_check_typedef (type);
2207 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2210 index_type_desc = ada_find_parallel_type (type, "___XA");
2211 if (index_type_desc)
2212 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2215 index_type = TYPE_INDEX_TYPE (type);
2217 new_type = alloc_type_copy (type);
2219 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2221 create_array_type (new_type, new_elt_type, index_type);
2222 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2223 TYPE_NAME (new_type) = ada_type_name (type);
2225 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2226 && is_dynamic_type (check_typedef (index_type)))
2227 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
2228 low_bound = high_bound = 0;
2229 if (high_bound < low_bound)
2230 *elt_bits = TYPE_LENGTH (new_type) = 0;
2233 *elt_bits *= (high_bound - low_bound + 1);
2234 TYPE_LENGTH (new_type) =
2235 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2238 TYPE_FIXED_INSTANCE (new_type) = 1;
2242 /* The array type encoded by TYPE, where
2243 ada_is_constrained_packed_array_type (TYPE). */
2245 static struct type *
2246 decode_constrained_packed_array_type (struct type *type)
2248 const char *raw_name = ada_type_name (ada_check_typedef (type));
2251 struct type *shadow_type;
2255 raw_name = ada_type_name (desc_base_type (type));
2260 name = (char *) alloca (strlen (raw_name) + 1);
2261 tail = strstr (raw_name, "___XP");
2262 type = desc_base_type (type);
2264 memcpy (name, raw_name, tail - raw_name);
2265 name[tail - raw_name] = '\000';
2267 shadow_type = ada_find_parallel_type_with_name (type, name);
2269 if (shadow_type == NULL)
2271 lim_warning (_("could not find bounds information on packed array"));
2274 shadow_type = check_typedef (shadow_type);
2276 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2278 lim_warning (_("could not understand bounds "
2279 "information on packed array"));
2283 bits = decode_packed_array_bitsize (type);
2284 return constrained_packed_array_type (shadow_type, &bits);
2287 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2288 array, returns a simple array that denotes that array. Its type is a
2289 standard GDB array type except that the BITSIZEs of the array
2290 target types are set to the number of bits in each element, and the
2291 type length is set appropriately. */
2293 static struct value *
2294 decode_constrained_packed_array (struct value *arr)
2298 /* If our value is a pointer, then dereference it. Likewise if
2299 the value is a reference. Make sure that this operation does not
2300 cause the target type to be fixed, as this would indirectly cause
2301 this array to be decoded. The rest of the routine assumes that
2302 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2303 and "value_ind" routines to perform the dereferencing, as opposed
2304 to using "ada_coerce_ref" or "ada_value_ind". */
2305 arr = coerce_ref (arr);
2306 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
2307 arr = value_ind (arr);
2309 type = decode_constrained_packed_array_type (value_type (arr));
2312 error (_("can't unpack array"));
2316 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
2317 && ada_is_modular_type (value_type (arr)))
2319 /* This is a (right-justified) modular type representing a packed
2320 array with no wrapper. In order to interpret the value through
2321 the (left-justified) packed array type we just built, we must
2322 first left-justify it. */
2323 int bit_size, bit_pos;
2326 mod = ada_modulus (value_type (arr)) - 1;
2333 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2334 arr = ada_value_primitive_packed_val (arr, NULL,
2335 bit_pos / HOST_CHAR_BIT,
2336 bit_pos % HOST_CHAR_BIT,
2341 return coerce_unspec_val_to_type (arr, type);
2345 /* The value of the element of packed array ARR at the ARITY indices
2346 given in IND. ARR must be a simple array. */
2348 static struct value *
2349 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2352 int bits, elt_off, bit_off;
2353 long elt_total_bit_offset;
2354 struct type *elt_type;
2358 elt_total_bit_offset = 0;
2359 elt_type = ada_check_typedef (value_type (arr));
2360 for (i = 0; i < arity; i += 1)
2362 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
2363 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2365 (_("attempt to do packed indexing of "
2366 "something other than a packed array"));
2369 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2370 LONGEST lowerbound, upperbound;
2373 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2375 lim_warning (_("don't know bounds of array"));
2376 lowerbound = upperbound = 0;
2379 idx = pos_atr (ind[i]);
2380 if (idx < lowerbound || idx > upperbound)
2381 lim_warning (_("packed array index %ld out of bounds"),
2383 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2384 elt_total_bit_offset += (idx - lowerbound) * bits;
2385 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2388 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2389 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2391 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2396 /* Non-zero iff TYPE includes negative integer values. */
2399 has_negatives (struct type *type)
2401 switch (TYPE_CODE (type))
2406 return !TYPE_UNSIGNED (type);
2407 case TYPE_CODE_RANGE:
2408 return TYPE_LOW_BOUND (type) < 0;
2412 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2413 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2414 the unpacked buffer.
2416 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2417 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2419 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2422 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2424 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2427 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2428 gdb_byte *unpacked, int unpacked_len,
2429 int is_big_endian, int is_signed_type,
2432 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2433 int src_idx; /* Index into the source area */
2434 int src_bytes_left; /* Number of source bytes left to process. */
2435 int srcBitsLeft; /* Number of source bits left to move */
2436 int unusedLS; /* Number of bits in next significant
2437 byte of source that are unused */
2439 int unpacked_idx; /* Index into the unpacked buffer */
2440 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2442 unsigned long accum; /* Staging area for bits being transferred */
2443 int accumSize; /* Number of meaningful bits in accum */
2446 /* Transmit bytes from least to most significant; delta is the direction
2447 the indices move. */
2448 int delta = is_big_endian ? -1 : 1;
2450 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2452 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2453 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2454 bit_size, unpacked_len);
2456 srcBitsLeft = bit_size;
2457 src_bytes_left = src_len;
2458 unpacked_bytes_left = unpacked_len;
2463 src_idx = src_len - 1;
2465 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2469 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2475 unpacked_idx = unpacked_len - 1;
2479 /* Non-scalar values must be aligned at a byte boundary... */
2481 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2482 /* ... And are placed at the beginning (most-significant) bytes
2484 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2485 unpacked_bytes_left = unpacked_idx + 1;
2490 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2492 src_idx = unpacked_idx = 0;
2493 unusedLS = bit_offset;
2496 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2501 while (src_bytes_left > 0)
2503 /* Mask for removing bits of the next source byte that are not
2504 part of the value. */
2505 unsigned int unusedMSMask =
2506 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2508 /* Sign-extend bits for this byte. */
2509 unsigned int signMask = sign & ~unusedMSMask;
2512 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2513 accumSize += HOST_CHAR_BIT - unusedLS;
2514 if (accumSize >= HOST_CHAR_BIT)
2516 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2517 accumSize -= HOST_CHAR_BIT;
2518 accum >>= HOST_CHAR_BIT;
2519 unpacked_bytes_left -= 1;
2520 unpacked_idx += delta;
2522 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2524 src_bytes_left -= 1;
2527 while (unpacked_bytes_left > 0)
2529 accum |= sign << accumSize;
2530 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2531 accumSize -= HOST_CHAR_BIT;
2534 accum >>= HOST_CHAR_BIT;
2535 unpacked_bytes_left -= 1;
2536 unpacked_idx += delta;
2540 /* Create a new value of type TYPE from the contents of OBJ starting
2541 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2542 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2543 assigning through the result will set the field fetched from.
2544 VALADDR is ignored unless OBJ is NULL, in which case,
2545 VALADDR+OFFSET must address the start of storage containing the
2546 packed value. The value returned in this case is never an lval.
2547 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2550 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2551 long offset, int bit_offset, int bit_size,
2555 const gdb_byte *src; /* First byte containing data to unpack */
2557 const int is_scalar = is_scalar_type (type);
2558 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
2559 gdb::byte_vector staging;
2561 type = ada_check_typedef (type);
2564 src = valaddr + offset;
2566 src = value_contents (obj) + offset;
2568 if (is_dynamic_type (type))
2570 /* The length of TYPE might by dynamic, so we need to resolve
2571 TYPE in order to know its actual size, which we then use
2572 to create the contents buffer of the value we return.
2573 The difficulty is that the data containing our object is
2574 packed, and therefore maybe not at a byte boundary. So, what
2575 we do, is unpack the data into a byte-aligned buffer, and then
2576 use that buffer as our object's value for resolving the type. */
2577 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2578 staging.resize (staging_len);
2580 ada_unpack_from_contents (src, bit_offset, bit_size,
2581 staging.data (), staging.size (),
2582 is_big_endian, has_negatives (type),
2584 type = resolve_dynamic_type (type, staging.data (), 0);
2585 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2587 /* This happens when the length of the object is dynamic,
2588 and is actually smaller than the space reserved for it.
2589 For instance, in an array of variant records, the bit_size
2590 we're given is the array stride, which is constant and
2591 normally equal to the maximum size of its element.
2592 But, in reality, each element only actually spans a portion
2594 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2600 v = allocate_value (type);
2601 src = valaddr + offset;
2603 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2605 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2608 v = value_at (type, value_address (obj) + offset);
2609 buf = (gdb_byte *) alloca (src_len);
2610 read_memory (value_address (v), buf, src_len);
2615 v = allocate_value (type);
2616 src = value_contents (obj) + offset;
2621 long new_offset = offset;
2623 set_value_component_location (v, obj);
2624 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2625 set_value_bitsize (v, bit_size);
2626 if (value_bitpos (v) >= HOST_CHAR_BIT)
2629 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2631 set_value_offset (v, new_offset);
2633 /* Also set the parent value. This is needed when trying to
2634 assign a new value (in inferior memory). */
2635 set_value_parent (v, obj);
2638 set_value_bitsize (v, bit_size);
2639 unpacked = value_contents_writeable (v);
2643 memset (unpacked, 0, TYPE_LENGTH (type));
2647 if (staging.size () == TYPE_LENGTH (type))
2649 /* Small short-cut: If we've unpacked the data into a buffer
2650 of the same size as TYPE's length, then we can reuse that,
2651 instead of doing the unpacking again. */
2652 memcpy (unpacked, staging.data (), staging.size ());
2655 ada_unpack_from_contents (src, bit_offset, bit_size,
2656 unpacked, TYPE_LENGTH (type),
2657 is_big_endian, has_negatives (type), is_scalar);
2662 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2663 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2666 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2667 int src_offset, int n, int bits_big_endian_p)
2669 unsigned int accum, mask;
2670 int accum_bits, chunk_size;
2672 target += targ_offset / HOST_CHAR_BIT;
2673 targ_offset %= HOST_CHAR_BIT;
2674 source += src_offset / HOST_CHAR_BIT;
2675 src_offset %= HOST_CHAR_BIT;
2676 if (bits_big_endian_p)
2678 accum = (unsigned char) *source;
2680 accum_bits = HOST_CHAR_BIT - src_offset;
2686 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2687 accum_bits += HOST_CHAR_BIT;
2689 chunk_size = HOST_CHAR_BIT - targ_offset;
2692 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2693 mask = ((1 << chunk_size) - 1) << unused_right;
2696 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2698 accum_bits -= chunk_size;
2705 accum = (unsigned char) *source >> src_offset;
2707 accum_bits = HOST_CHAR_BIT - src_offset;
2711 accum = accum + ((unsigned char) *source << accum_bits);
2712 accum_bits += HOST_CHAR_BIT;
2714 chunk_size = HOST_CHAR_BIT - targ_offset;
2717 mask = ((1 << chunk_size) - 1) << targ_offset;
2718 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2720 accum_bits -= chunk_size;
2721 accum >>= chunk_size;
2728 /* Store the contents of FROMVAL into the location of TOVAL.
2729 Return a new value with the location of TOVAL and contents of
2730 FROMVAL. Handles assignment into packed fields that have
2731 floating-point or non-scalar types. */
2733 static struct value *
2734 ada_value_assign (struct value *toval, struct value *fromval)
2736 struct type *type = value_type (toval);
2737 int bits = value_bitsize (toval);
2739 toval = ada_coerce_ref (toval);
2740 fromval = ada_coerce_ref (fromval);
2742 if (ada_is_direct_array_type (value_type (toval)))
2743 toval = ada_coerce_to_simple_array (toval);
2744 if (ada_is_direct_array_type (value_type (fromval)))
2745 fromval = ada_coerce_to_simple_array (fromval);
2747 if (!deprecated_value_modifiable (toval))
2748 error (_("Left operand of assignment is not a modifiable lvalue."));
2750 if (VALUE_LVAL (toval) == lval_memory
2752 && (TYPE_CODE (type) == TYPE_CODE_FLT
2753 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2755 int len = (value_bitpos (toval)
2756 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2758 gdb_byte *buffer = (gdb_byte *) alloca (len);
2760 CORE_ADDR to_addr = value_address (toval);
2762 if (TYPE_CODE (type) == TYPE_CODE_FLT)
2763 fromval = value_cast (type, fromval);
2765 read_memory (to_addr, buffer, len);
2766 from_size = value_bitsize (fromval);
2768 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2769 if (gdbarch_bits_big_endian (get_type_arch (type)))
2770 move_bits (buffer, value_bitpos (toval),
2771 value_contents (fromval), from_size - bits, bits, 1);
2773 move_bits (buffer, value_bitpos (toval),
2774 value_contents (fromval), 0, bits, 0);
2775 write_memory_with_notification (to_addr, buffer, len);
2777 val = value_copy (toval);
2778 memcpy (value_contents_raw (val), value_contents (fromval),
2779 TYPE_LENGTH (type));
2780 deprecated_set_value_type (val, type);
2785 return value_assign (toval, fromval);
2789 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2790 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2791 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2792 COMPONENT, and not the inferior's memory. The current contents
2793 of COMPONENT are ignored.
2795 Although not part of the initial design, this function also works
2796 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2797 had a null address, and COMPONENT had an address which is equal to
2798 its offset inside CONTAINER. */
2801 value_assign_to_component (struct value *container, struct value *component,
2804 LONGEST offset_in_container =
2805 (LONGEST) (value_address (component) - value_address (container));
2806 int bit_offset_in_container =
2807 value_bitpos (component) - value_bitpos (container);
2810 val = value_cast (value_type (component), val);
2812 if (value_bitsize (component) == 0)
2813 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2815 bits = value_bitsize (component);
2817 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2818 move_bits (value_contents_writeable (container) + offset_in_container,
2819 value_bitpos (container) + bit_offset_in_container,
2820 value_contents (val),
2821 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2824 move_bits (value_contents_writeable (container) + offset_in_container,
2825 value_bitpos (container) + bit_offset_in_container,
2826 value_contents (val), 0, bits, 0);
2829 /* The value of the element of array ARR at the ARITY indices given in IND.
2830 ARR may be either a simple array, GNAT array descriptor, or pointer
2834 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2838 struct type *elt_type;
2840 elt = ada_coerce_to_simple_array (arr);
2842 elt_type = ada_check_typedef (value_type (elt));
2843 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2844 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2845 return value_subscript_packed (elt, arity, ind);
2847 for (k = 0; k < arity; k += 1)
2849 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2850 error (_("too many subscripts (%d expected)"), k);
2851 elt = value_subscript (elt, pos_atr (ind[k]));
2856 /* Assuming ARR is a pointer to a GDB array, the value of the element
2857 of *ARR at the ARITY indices given in IND.
2858 Does not read the entire array into memory.
2860 Note: Unlike what one would expect, this function is used instead of
2861 ada_value_subscript for basically all non-packed array types. The reason
2862 for this is that a side effect of doing our own pointer arithmetics instead
2863 of relying on value_subscript is that there is no implicit typedef peeling.
2864 This is important for arrays of array accesses, where it allows us to
2865 preserve the fact that the array's element is an array access, where the
2866 access part os encoded in a typedef layer. */
2868 static struct value *
2869 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2872 struct value *array_ind = ada_value_ind (arr);
2874 = check_typedef (value_enclosing_type (array_ind));
2876 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2877 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2878 return value_subscript_packed (array_ind, arity, ind);
2880 for (k = 0; k < arity; k += 1)
2883 struct value *lwb_value;
2885 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2886 error (_("too many subscripts (%d expected)"), k);
2887 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2889 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2890 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2891 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
2892 type = TYPE_TARGET_TYPE (type);
2895 return value_ind (arr);
2898 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2899 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2900 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2901 this array is LOW, as per Ada rules. */
2902 static struct value *
2903 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2906 struct type *type0 = ada_check_typedef (type);
2907 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
2908 struct type *index_type
2909 = create_static_range_type (NULL, base_index_type, low, high);
2910 struct type *slice_type = create_array_type_with_stride
2911 (NULL, TYPE_TARGET_TYPE (type0), index_type,
2912 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2913 TYPE_FIELD_BITSIZE (type0, 0));
2914 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2915 LONGEST base_low_pos, low_pos;
2918 if (!discrete_position (base_index_type, low, &low_pos)
2919 || !discrete_position (base_index_type, base_low, &base_low_pos))
2921 warning (_("unable to get positions in slice, use bounds instead"));
2923 base_low_pos = base_low;
2926 base = value_as_address (array_ptr)
2927 + ((low_pos - base_low_pos)
2928 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
2929 return value_at_lazy (slice_type, base);
2933 static struct value *
2934 ada_value_slice (struct value *array, int low, int high)
2936 struct type *type = ada_check_typedef (value_type (array));
2937 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2938 struct type *index_type
2939 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2940 struct type *slice_type = create_array_type_with_stride
2941 (NULL, TYPE_TARGET_TYPE (type), index_type,
2942 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2943 TYPE_FIELD_BITSIZE (type, 0));
2944 LONGEST low_pos, high_pos;
2946 if (!discrete_position (base_index_type, low, &low_pos)
2947 || !discrete_position (base_index_type, high, &high_pos))
2949 warning (_("unable to get positions in slice, use bounds instead"));
2954 return value_cast (slice_type,
2955 value_slice (array, low, high_pos - low_pos + 1));
2958 /* If type is a record type in the form of a standard GNAT array
2959 descriptor, returns the number of dimensions for type. If arr is a
2960 simple array, returns the number of "array of"s that prefix its
2961 type designation. Otherwise, returns 0. */
2964 ada_array_arity (struct type *type)
2971 type = desc_base_type (type);
2974 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2975 return desc_arity (desc_bounds_type (type));
2977 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2980 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2986 /* If TYPE is a record type in the form of a standard GNAT array
2987 descriptor or a simple array type, returns the element type for
2988 TYPE after indexing by NINDICES indices, or by all indices if
2989 NINDICES is -1. Otherwise, returns NULL. */
2992 ada_array_element_type (struct type *type, int nindices)
2994 type = desc_base_type (type);
2996 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2999 struct type *p_array_type;
3001 p_array_type = desc_data_target_type (type);
3003 k = ada_array_arity (type);
3007 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
3008 if (nindices >= 0 && k > nindices)
3010 while (k > 0 && p_array_type != NULL)
3012 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
3015 return p_array_type;
3017 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
3019 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
3021 type = TYPE_TARGET_TYPE (type);
3030 /* The type of nth index in arrays of given type (n numbering from 1).
3031 Does not examine memory. Throws an error if N is invalid or TYPE
3032 is not an array type. NAME is the name of the Ada attribute being
3033 evaluated ('range, 'first, 'last, or 'length); it is used in building
3034 the error message. */
3036 static struct type *
3037 ada_index_type (struct type *type, int n, const char *name)
3039 struct type *result_type;
3041 type = desc_base_type (type);
3043 if (n < 0 || n > ada_array_arity (type))
3044 error (_("invalid dimension number to '%s"), name);
3046 if (ada_is_simple_array_type (type))
3050 for (i = 1; i < n; i += 1)
3051 type = TYPE_TARGET_TYPE (type);
3052 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
3053 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3054 has a target type of TYPE_CODE_UNDEF. We compensate here, but
3055 perhaps stabsread.c would make more sense. */
3056 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
3061 result_type = desc_index_type (desc_bounds_type (type), n);
3062 if (result_type == NULL)
3063 error (_("attempt to take bound of something that is not an array"));
3069 /* Given that arr is an array type, returns the lower bound of the
3070 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3071 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
3072 array-descriptor type. It works for other arrays with bounds supplied
3073 by run-time quantities other than discriminants. */
3076 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3078 struct type *type, *index_type_desc, *index_type;
3081 gdb_assert (which == 0 || which == 1);
3083 if (ada_is_constrained_packed_array_type (arr_type))
3084 arr_type = decode_constrained_packed_array_type (arr_type);
3086 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3087 return (LONGEST) - which;
3089 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3090 type = TYPE_TARGET_TYPE (arr_type);
3094 if (TYPE_FIXED_INSTANCE (type))
3096 /* The array has already been fixed, so we do not need to
3097 check the parallel ___XA type again. That encoding has
3098 already been applied, so ignore it now. */
3099 index_type_desc = NULL;
3103 index_type_desc = ada_find_parallel_type (type, "___XA");
3104 ada_fixup_array_indexes_type (index_type_desc);
3107 if (index_type_desc != NULL)
3108 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3112 struct type *elt_type = check_typedef (type);
3114 for (i = 1; i < n; i++)
3115 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3117 index_type = TYPE_INDEX_TYPE (elt_type);
3121 (LONGEST) (which == 0
3122 ? ada_discrete_type_low_bound (index_type)
3123 : ada_discrete_type_high_bound (index_type));
3126 /* Given that arr is an array value, returns the lower bound of the
3127 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3128 WHICH is 1. This routine will also work for arrays with bounds
3129 supplied by run-time quantities other than discriminants. */
3132 ada_array_bound (struct value *arr, int n, int which)
3134 struct type *arr_type;
3136 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3137 arr = value_ind (arr);
3138 arr_type = value_enclosing_type (arr);
3140 if (ada_is_constrained_packed_array_type (arr_type))
3141 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3142 else if (ada_is_simple_array_type (arr_type))
3143 return ada_array_bound_from_type (arr_type, n, which);
3145 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3148 /* Given that arr is an array value, returns the length of the
3149 nth index. This routine will also work for arrays with bounds
3150 supplied by run-time quantities other than discriminants.
3151 Does not work for arrays indexed by enumeration types with representation
3152 clauses at the moment. */
3155 ada_array_length (struct value *arr, int n)
3157 struct type *arr_type, *index_type;
3160 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3161 arr = value_ind (arr);
3162 arr_type = value_enclosing_type (arr);
3164 if (ada_is_constrained_packed_array_type (arr_type))
3165 return ada_array_length (decode_constrained_packed_array (arr), n);
3167 if (ada_is_simple_array_type (arr_type))
3169 low = ada_array_bound_from_type (arr_type, n, 0);
3170 high = ada_array_bound_from_type (arr_type, n, 1);
3174 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3175 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3178 arr_type = check_typedef (arr_type);
3179 index_type = ada_index_type (arr_type, n, "length");
3180 if (index_type != NULL)
3182 struct type *base_type;
3183 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3184 base_type = TYPE_TARGET_TYPE (index_type);
3186 base_type = index_type;
3188 low = pos_atr (value_from_longest (base_type, low));
3189 high = pos_atr (value_from_longest (base_type, high));
3191 return high - low + 1;
3194 /* An empty array whose type is that of ARR_TYPE (an array type),
3195 with bounds LOW to LOW-1. */
3197 static struct value *
3198 empty_array (struct type *arr_type, int low)
3200 struct type *arr_type0 = ada_check_typedef (arr_type);
3201 struct type *index_type
3202 = create_static_range_type
3203 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
3204 struct type *elt_type = ada_array_element_type (arr_type0, 1);
3206 return allocate_value (create_array_type (NULL, elt_type, index_type));
3210 /* Name resolution */
3212 /* The "decoded" name for the user-definable Ada operator corresponding
3216 ada_decoded_op_name (enum exp_opcode op)
3220 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3222 if (ada_opname_table[i].op == op)
3223 return ada_opname_table[i].decoded;
3225 error (_("Could not find operator name for opcode"));
3229 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3230 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3231 undefined namespace) and converts operators that are
3232 user-defined into appropriate function calls. If CONTEXT_TYPE is
3233 non-null, it provides a preferred result type [at the moment, only
3234 type void has any effect---causing procedures to be preferred over
3235 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3236 return type is preferred. May change (expand) *EXP. */
3239 resolve (expression_up *expp, int void_context_p)
3241 struct type *context_type = NULL;
3245 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3247 resolve_subexp (expp, &pc, 1, context_type);
3250 /* Resolve the operator of the subexpression beginning at
3251 position *POS of *EXPP. "Resolving" consists of replacing
3252 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3253 with their resolutions, replacing built-in operators with
3254 function calls to user-defined operators, where appropriate, and,
3255 when DEPROCEDURE_P is non-zero, converting function-valued variables
3256 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3257 are as in ada_resolve, above. */
3259 static struct value *
3260 resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
3261 struct type *context_type)
3265 struct expression *exp; /* Convenience: == *expp. */
3266 enum exp_opcode op = (*expp)->elts[pc].opcode;
3267 struct value **argvec; /* Vector of operand types (alloca'ed). */
3268 int nargs; /* Number of operands. */
3270 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
3276 /* Pass one: resolve operands, saving their types and updating *pos,
3281 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3282 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3287 resolve_subexp (expp, pos, 0, NULL);
3289 nargs = longest_to_int (exp->elts[pc + 1].longconst);
3294 resolve_subexp (expp, pos, 0, NULL);
3299 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
3302 case OP_ATR_MODULUS:
3312 case TERNOP_IN_RANGE:
3313 case BINOP_IN_BOUNDS:
3319 case OP_DISCRETE_RANGE:
3321 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3330 arg1 = resolve_subexp (expp, pos, 0, NULL);
3332 resolve_subexp (expp, pos, 1, NULL);
3334 resolve_subexp (expp, pos, 1, value_type (arg1));
3351 case BINOP_LOGICAL_AND:
3352 case BINOP_LOGICAL_OR:
3353 case BINOP_BITWISE_AND:
3354 case BINOP_BITWISE_IOR:
3355 case BINOP_BITWISE_XOR:
3358 case BINOP_NOTEQUAL:
3365 case BINOP_SUBSCRIPT:
3373 case UNOP_LOGICAL_NOT:
3383 case OP_VAR_MSYM_VALUE:
3390 case OP_INTERNALVAR:
3400 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3403 case STRUCTOP_STRUCT:
3404 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3417 error (_("Unexpected operator during name resolution"));
3420 argvec = XALLOCAVEC (struct value *, nargs + 1);
3421 for (i = 0; i < nargs; i += 1)
3422 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3426 /* Pass two: perform any resolution on principal operator. */
3433 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
3435 struct block_symbol *candidates;
3439 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3440 (exp->elts[pc + 2].symbol),
3441 exp->elts[pc + 1].block, VAR_DOMAIN,
3443 make_cleanup (xfree, candidates);
3445 if (n_candidates > 1)
3447 /* Types tend to get re-introduced locally, so if there
3448 are any local symbols that are not types, first filter
3451 for (j = 0; j < n_candidates; j += 1)
3452 switch (SYMBOL_CLASS (candidates[j].symbol))
3457 case LOC_REGPARM_ADDR:
3465 if (j < n_candidates)
3468 while (j < n_candidates)
3470 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
3472 candidates[j] = candidates[n_candidates - 1];
3481 if (n_candidates == 0)
3482 error (_("No definition found for %s"),
3483 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3484 else if (n_candidates == 1)
3486 else if (deprocedure_p
3487 && !is_nonfunction (candidates, n_candidates))
3489 i = ada_resolve_function
3490 (candidates, n_candidates, NULL, 0,
3491 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3494 error (_("Could not find a match for %s"),
3495 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3499 printf_filtered (_("Multiple matches for %s\n"),
3500 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3501 user_select_syms (candidates, n_candidates, 1);
3505 exp->elts[pc + 1].block = candidates[i].block;
3506 exp->elts[pc + 2].symbol = candidates[i].symbol;
3507 innermost_block.update (candidates[i]);
3511 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3514 replace_operator_with_call (expp, pc, 0, 0,
3515 exp->elts[pc + 2].symbol,
3516 exp->elts[pc + 1].block);
3523 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3524 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3526 struct block_symbol *candidates;
3530 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3531 (exp->elts[pc + 5].symbol),
3532 exp->elts[pc + 4].block, VAR_DOMAIN,
3534 make_cleanup (xfree, candidates);
3536 if (n_candidates == 1)
3540 i = ada_resolve_function
3541 (candidates, n_candidates,
3543 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3546 error (_("Could not find a match for %s"),
3547 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3550 exp->elts[pc + 4].block = candidates[i].block;
3551 exp->elts[pc + 5].symbol = candidates[i].symbol;
3552 innermost_block.update (candidates[i]);
3563 case BINOP_BITWISE_AND:
3564 case BINOP_BITWISE_IOR:
3565 case BINOP_BITWISE_XOR:
3567 case BINOP_NOTEQUAL:
3575 case UNOP_LOGICAL_NOT:
3577 if (possible_user_operator_p (op, argvec))
3579 struct block_symbol *candidates;
3583 ada_lookup_symbol_list (ada_decoded_op_name (op),
3584 (struct block *) NULL, VAR_DOMAIN,
3586 make_cleanup (xfree, candidates);
3588 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
3589 ada_decoded_op_name (op), NULL);
3593 replace_operator_with_call (expp, pc, nargs, 1,
3594 candidates[i].symbol,
3595 candidates[i].block);
3602 do_cleanups (old_chain);
3607 do_cleanups (old_chain);
3608 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3609 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3610 exp->elts[pc + 1].objfile,
3611 exp->elts[pc + 2].msymbol);
3613 return evaluate_subexp_type (exp, pos);
3616 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3617 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3619 /* The term "match" here is rather loose. The match is heuristic and
3623 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3625 ftype = ada_check_typedef (ftype);
3626 atype = ada_check_typedef (atype);
3628 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3629 ftype = TYPE_TARGET_TYPE (ftype);
3630 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3631 atype = TYPE_TARGET_TYPE (atype);
3633 switch (TYPE_CODE (ftype))
3636 return TYPE_CODE (ftype) == TYPE_CODE (atype);
3638 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3639 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3640 TYPE_TARGET_TYPE (atype), 0);
3643 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3645 case TYPE_CODE_ENUM:
3646 case TYPE_CODE_RANGE:
3647 switch (TYPE_CODE (atype))
3650 case TYPE_CODE_ENUM:
3651 case TYPE_CODE_RANGE:
3657 case TYPE_CODE_ARRAY:
3658 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3659 || ada_is_array_descriptor_type (atype));
3661 case TYPE_CODE_STRUCT:
3662 if (ada_is_array_descriptor_type (ftype))
3663 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3664 || ada_is_array_descriptor_type (atype));
3666 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3667 && !ada_is_array_descriptor_type (atype));
3669 case TYPE_CODE_UNION:
3671 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3675 /* Return non-zero if the formals of FUNC "sufficiently match" the
3676 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3677 may also be an enumeral, in which case it is treated as a 0-
3678 argument function. */
3681 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3684 struct type *func_type = SYMBOL_TYPE (func);
3686 if (SYMBOL_CLASS (func) == LOC_CONST
3687 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3688 return (n_actuals == 0);
3689 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3692 if (TYPE_NFIELDS (func_type) != n_actuals)
3695 for (i = 0; i < n_actuals; i += 1)
3697 if (actuals[i] == NULL)
3701 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3703 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3705 if (!ada_type_match (ftype, atype, 1))
3712 /* False iff function type FUNC_TYPE definitely does not produce a value
3713 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3714 FUNC_TYPE is not a valid function type with a non-null return type
3715 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3718 return_match (struct type *func_type, struct type *context_type)
3720 struct type *return_type;
3722 if (func_type == NULL)
3725 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3726 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3728 return_type = get_base_type (func_type);
3729 if (return_type == NULL)
3732 context_type = get_base_type (context_type);
3734 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3735 return context_type == NULL || return_type == context_type;
3736 else if (context_type == NULL)
3737 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3739 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3743 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3744 function (if any) that matches the types of the NARGS arguments in
3745 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3746 that returns that type, then eliminate matches that don't. If
3747 CONTEXT_TYPE is void and there is at least one match that does not
3748 return void, eliminate all matches that do.
3750 Asks the user if there is more than one match remaining. Returns -1
3751 if there is no such symbol or none is selected. NAME is used
3752 solely for messages. May re-arrange and modify SYMS in
3753 the process; the index returned is for the modified vector. */
3756 ada_resolve_function (struct block_symbol syms[],
3757 int nsyms, struct value **args, int nargs,
3758 const char *name, struct type *context_type)
3762 int m; /* Number of hits */
3765 /* In the first pass of the loop, we only accept functions matching
3766 context_type. If none are found, we add a second pass of the loop
3767 where every function is accepted. */
3768 for (fallback = 0; m == 0 && fallback < 2; fallback++)
3770 for (k = 0; k < nsyms; k += 1)
3772 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
3774 if (ada_args_match (syms[k].symbol, args, nargs)
3775 && (fallback || return_match (type, context_type)))
3783 /* If we got multiple matches, ask the user which one to use. Don't do this
3784 interactive thing during completion, though, as the purpose of the
3785 completion is providing a list of all possible matches. Prompting the
3786 user to filter it down would be completely unexpected in this case. */
3789 else if (m > 1 && !parse_completion)
3791 printf_filtered (_("Multiple matches for %s\n"), name);
3792 user_select_syms (syms, m, 1);
3798 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3799 in a listing of choices during disambiguation (see sort_choices, below).
3800 The idea is that overloadings of a subprogram name from the
3801 same package should sort in their source order. We settle for ordering
3802 such symbols by their trailing number (__N or $N). */
3805 encoded_ordered_before (const char *N0, const char *N1)
3809 else if (N0 == NULL)
3815 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3817 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3819 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3820 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3825 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3828 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3830 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3831 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3833 return (strcmp (N0, N1) < 0);
3837 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3841 sort_choices (struct block_symbol syms[], int nsyms)
3845 for (i = 1; i < nsyms; i += 1)
3847 struct block_symbol sym = syms[i];
3850 for (j = i - 1; j >= 0; j -= 1)
3852 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3853 SYMBOL_LINKAGE_NAME (sym.symbol)))
3855 syms[j + 1] = syms[j];
3861 /* Whether GDB should display formals and return types for functions in the
3862 overloads selection menu. */
3863 static int print_signatures = 1;
3865 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3866 all but functions, the signature is just the name of the symbol. For
3867 functions, this is the name of the function, the list of types for formals
3868 and the return type (if any). */
3871 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3872 const struct type_print_options *flags)
3874 struct type *type = SYMBOL_TYPE (sym);
3876 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3877 if (!print_signatures
3879 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3882 if (TYPE_NFIELDS (type) > 0)
3886 fprintf_filtered (stream, " (");
3887 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3890 fprintf_filtered (stream, "; ");
3891 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3894 fprintf_filtered (stream, ")");
3896 if (TYPE_TARGET_TYPE (type) != NULL
3897 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3899 fprintf_filtered (stream, " return ");
3900 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3904 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3905 by asking the user (if necessary), returning the number selected,
3906 and setting the first elements of SYMS items. Error if no symbols
3909 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3910 to be re-integrated one of these days. */
3913 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3916 int *chosen = XALLOCAVEC (int , nsyms);
3918 int first_choice = (max_results == 1) ? 1 : 2;
3919 const char *select_mode = multiple_symbols_select_mode ();
3921 if (max_results < 1)
3922 error (_("Request to select 0 symbols!"));
3926 if (select_mode == multiple_symbols_cancel)
3928 canceled because the command is ambiguous\n\
3929 See set/show multiple-symbol."));
3931 /* If select_mode is "all", then return all possible symbols.
3932 Only do that if more than one symbol can be selected, of course.
3933 Otherwise, display the menu as usual. */
3934 if (select_mode == multiple_symbols_all && max_results > 1)
3937 printf_unfiltered (_("[0] cancel\n"));
3938 if (max_results > 1)
3939 printf_unfiltered (_("[1] all\n"));
3941 sort_choices (syms, nsyms);
3943 for (i = 0; i < nsyms; i += 1)
3945 if (syms[i].symbol == NULL)
3948 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3950 struct symtab_and_line sal =
3951 find_function_start_sal (syms[i].symbol, 1);
3953 printf_unfiltered ("[%d] ", i + first_choice);
3954 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3955 &type_print_raw_options);
3956 if (sal.symtab == NULL)
3957 printf_unfiltered (_(" at <no source file available>:%d\n"),
3960 printf_unfiltered (_(" at %s:%d\n"),
3961 symtab_to_filename_for_display (sal.symtab),
3968 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3969 && SYMBOL_TYPE (syms[i].symbol) != NULL
3970 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
3971 struct symtab *symtab = NULL;
3973 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3974 symtab = symbol_symtab (syms[i].symbol);
3976 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3978 printf_unfiltered ("[%d] ", i + first_choice);
3979 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3980 &type_print_raw_options);
3981 printf_unfiltered (_(" at %s:%d\n"),
3982 symtab_to_filename_for_display (symtab),
3983 SYMBOL_LINE (syms[i].symbol));
3985 else if (is_enumeral
3986 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
3988 printf_unfiltered (("[%d] "), i + first_choice);
3989 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3990 gdb_stdout, -1, 0, &type_print_raw_options);
3991 printf_unfiltered (_("'(%s) (enumeral)\n"),
3992 SYMBOL_PRINT_NAME (syms[i].symbol));
3996 printf_unfiltered ("[%d] ", i + first_choice);
3997 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3998 &type_print_raw_options);
4001 printf_unfiltered (is_enumeral
4002 ? _(" in %s (enumeral)\n")
4004 symtab_to_filename_for_display (symtab));
4006 printf_unfiltered (is_enumeral
4007 ? _(" (enumeral)\n")
4013 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4016 for (i = 0; i < n_chosen; i += 1)
4017 syms[i] = syms[chosen[i]];
4022 /* Read and validate a set of numeric choices from the user in the
4023 range 0 .. N_CHOICES-1. Place the results in increasing
4024 order in CHOICES[0 .. N-1], and return N.
4026 The user types choices as a sequence of numbers on one line
4027 separated by blanks, encoding them as follows:
4029 + A choice of 0 means to cancel the selection, throwing an error.
4030 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4031 + The user chooses k by typing k+IS_ALL_CHOICE+1.
4033 The user is not allowed to choose more than MAX_RESULTS values.
4035 ANNOTATION_SUFFIX, if present, is used to annotate the input
4036 prompts (for use with the -f switch). */
4039 get_selections (int *choices, int n_choices, int max_results,
4040 int is_all_choice, const char *annotation_suffix)
4045 int first_choice = is_all_choice ? 2 : 1;
4047 prompt = getenv ("PS2");
4051 args = command_line_input (prompt, 0, annotation_suffix);
4054 error_no_arg (_("one or more choice numbers"));
4058 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4059 order, as given in args. Choices are validated. */
4065 args = skip_spaces (args);
4066 if (*args == '\0' && n_chosen == 0)
4067 error_no_arg (_("one or more choice numbers"));
4068 else if (*args == '\0')
4071 choice = strtol (args, &args2, 10);
4072 if (args == args2 || choice < 0
4073 || choice > n_choices + first_choice - 1)
4074 error (_("Argument must be choice number"));
4078 error (_("cancelled"));
4080 if (choice < first_choice)
4082 n_chosen = n_choices;
4083 for (j = 0; j < n_choices; j += 1)
4087 choice -= first_choice;
4089 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4093 if (j < 0 || choice != choices[j])
4097 for (k = n_chosen - 1; k > j; k -= 1)
4098 choices[k + 1] = choices[k];
4099 choices[j + 1] = choice;
4104 if (n_chosen > max_results)
4105 error (_("Select no more than %d of the above"), max_results);
4110 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4111 on the function identified by SYM and BLOCK, and taking NARGS
4112 arguments. Update *EXPP as needed to hold more space. */
4115 replace_operator_with_call (expression_up *expp, int pc, int nargs,
4116 int oplen, struct symbol *sym,
4117 const struct block *block)
4119 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4120 symbol, -oplen for operator being replaced). */
4121 struct expression *newexp = (struct expression *)
4122 xzalloc (sizeof (struct expression)
4123 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
4124 struct expression *exp = expp->get ();
4126 newexp->nelts = exp->nelts + 7 - oplen;
4127 newexp->language_defn = exp->language_defn;
4128 newexp->gdbarch = exp->gdbarch;
4129 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
4130 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4131 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
4133 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4134 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4136 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4137 newexp->elts[pc + 4].block = block;
4138 newexp->elts[pc + 5].symbol = sym;
4140 expp->reset (newexp);
4143 /* Type-class predicates */
4145 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4149 numeric_type_p (struct type *type)
4155 switch (TYPE_CODE (type))
4160 case TYPE_CODE_RANGE:
4161 return (type == TYPE_TARGET_TYPE (type)
4162 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4169 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4172 integer_type_p (struct type *type)
4178 switch (TYPE_CODE (type))
4182 case TYPE_CODE_RANGE:
4183 return (type == TYPE_TARGET_TYPE (type)
4184 || integer_type_p (TYPE_TARGET_TYPE (type)));
4191 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4194 scalar_type_p (struct type *type)
4200 switch (TYPE_CODE (type))
4203 case TYPE_CODE_RANGE:
4204 case TYPE_CODE_ENUM:
4213 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4216 discrete_type_p (struct type *type)
4222 switch (TYPE_CODE (type))
4225 case TYPE_CODE_RANGE:
4226 case TYPE_CODE_ENUM:
4227 case TYPE_CODE_BOOL:
4235 /* Returns non-zero if OP with operands in the vector ARGS could be
4236 a user-defined function. Errs on the side of pre-defined operators
4237 (i.e., result 0). */
4240 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4242 struct type *type0 =
4243 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4244 struct type *type1 =
4245 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4259 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4263 case BINOP_BITWISE_AND:
4264 case BINOP_BITWISE_IOR:
4265 case BINOP_BITWISE_XOR:
4266 return (!(integer_type_p (type0) && integer_type_p (type1)));
4269 case BINOP_NOTEQUAL:
4274 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4277 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4280 return (!(numeric_type_p (type0) && integer_type_p (type1)));
4284 case UNOP_LOGICAL_NOT:
4286 return (!numeric_type_p (type0));
4295 1. In the following, we assume that a renaming type's name may
4296 have an ___XD suffix. It would be nice if this went away at some
4298 2. We handle both the (old) purely type-based representation of
4299 renamings and the (new) variable-based encoding. At some point,
4300 it is devoutly to be hoped that the former goes away
4301 (FIXME: hilfinger-2007-07-09).
4302 3. Subprogram renamings are not implemented, although the XRS
4303 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4305 /* If SYM encodes a renaming,
4307 <renaming> renames <renamed entity>,
4309 sets *LEN to the length of the renamed entity's name,
4310 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4311 the string describing the subcomponent selected from the renamed
4312 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4313 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4314 are undefined). Otherwise, returns a value indicating the category
4315 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4316 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4317 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4318 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4319 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4320 may be NULL, in which case they are not assigned.
4322 [Currently, however, GCC does not generate subprogram renamings.] */
4324 enum ada_renaming_category
4325 ada_parse_renaming (struct symbol *sym,
4326 const char **renamed_entity, int *len,
4327 const char **renaming_expr)
4329 enum ada_renaming_category kind;
4334 return ADA_NOT_RENAMING;
4335 switch (SYMBOL_CLASS (sym))
4338 return ADA_NOT_RENAMING;
4340 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4341 renamed_entity, len, renaming_expr);
4345 case LOC_OPTIMIZED_OUT:
4346 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4348 return ADA_NOT_RENAMING;
4352 kind = ADA_OBJECT_RENAMING;
4356 kind = ADA_EXCEPTION_RENAMING;
4360 kind = ADA_PACKAGE_RENAMING;
4364 kind = ADA_SUBPROGRAM_RENAMING;
4368 return ADA_NOT_RENAMING;
4372 if (renamed_entity != NULL)
4373 *renamed_entity = info;
4374 suffix = strstr (info, "___XE");
4375 if (suffix == NULL || suffix == info)
4376 return ADA_NOT_RENAMING;
4378 *len = strlen (info) - strlen (suffix);
4380 if (renaming_expr != NULL)
4381 *renaming_expr = suffix;
4385 /* Assuming TYPE encodes a renaming according to the old encoding in
4386 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4387 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4388 ADA_NOT_RENAMING otherwise. */
4389 static enum ada_renaming_category
4390 parse_old_style_renaming (struct type *type,
4391 const char **renamed_entity, int *len,
4392 const char **renaming_expr)
4394 enum ada_renaming_category kind;
4399 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4400 || TYPE_NFIELDS (type) != 1)
4401 return ADA_NOT_RENAMING;
4403 name = type_name_no_tag (type);
4405 return ADA_NOT_RENAMING;
4407 name = strstr (name, "___XR");
4409 return ADA_NOT_RENAMING;
4414 kind = ADA_OBJECT_RENAMING;
4417 kind = ADA_EXCEPTION_RENAMING;
4420 kind = ADA_PACKAGE_RENAMING;
4423 kind = ADA_SUBPROGRAM_RENAMING;
4426 return ADA_NOT_RENAMING;
4429 info = TYPE_FIELD_NAME (type, 0);
4431 return ADA_NOT_RENAMING;
4432 if (renamed_entity != NULL)
4433 *renamed_entity = info;
4434 suffix = strstr (info, "___XE");
4435 if (renaming_expr != NULL)
4436 *renaming_expr = suffix + 5;
4437 if (suffix == NULL || suffix == info)
4438 return ADA_NOT_RENAMING;
4440 *len = suffix - info;
4444 /* Compute the value of the given RENAMING_SYM, which is expected to
4445 be a symbol encoding a renaming expression. BLOCK is the block
4446 used to evaluate the renaming. */
4448 static struct value *
4449 ada_read_renaming_var_value (struct symbol *renaming_sym,
4450 const struct block *block)
4452 const char *sym_name;
4454 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4455 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4456 return evaluate_expression (expr.get ());
4460 /* Evaluation: Function Calls */
4462 /* Return an lvalue containing the value VAL. This is the identity on
4463 lvalues, and otherwise has the side-effect of allocating memory
4464 in the inferior where a copy of the value contents is copied. */
4466 static struct value *
4467 ensure_lval (struct value *val)
4469 if (VALUE_LVAL (val) == not_lval
4470 || VALUE_LVAL (val) == lval_internalvar)
4472 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4473 const CORE_ADDR addr =
4474 value_as_long (value_allocate_space_in_inferior (len));
4476 VALUE_LVAL (val) = lval_memory;
4477 set_value_address (val, addr);
4478 write_memory (addr, value_contents (val), len);
4484 /* Return the value ACTUAL, converted to be an appropriate value for a
4485 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4486 allocating any necessary descriptors (fat pointers), or copies of
4487 values not residing in memory, updating it as needed. */
4490 ada_convert_actual (struct value *actual, struct type *formal_type0)
4492 struct type *actual_type = ada_check_typedef (value_type (actual));
4493 struct type *formal_type = ada_check_typedef (formal_type0);
4494 struct type *formal_target =
4495 TYPE_CODE (formal_type) == TYPE_CODE_PTR
4496 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4497 struct type *actual_target =
4498 TYPE_CODE (actual_type) == TYPE_CODE_PTR
4499 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4501 if (ada_is_array_descriptor_type (formal_target)
4502 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
4503 return make_array_descriptor (formal_type, actual);
4504 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4505 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
4507 struct value *result;
4509 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4510 && ada_is_array_descriptor_type (actual_target))
4511 result = desc_data (actual);
4512 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4514 if (VALUE_LVAL (actual) != lval_memory)
4518 actual_type = ada_check_typedef (value_type (actual));
4519 val = allocate_value (actual_type);
4520 memcpy ((char *) value_contents_raw (val),
4521 (char *) value_contents (actual),
4522 TYPE_LENGTH (actual_type));
4523 actual = ensure_lval (val);
4525 result = value_addr (actual);
4529 return value_cast_pointers (formal_type, result, 0);
4531 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4532 return ada_value_ind (actual);
4533 else if (ada_is_aligner_type (formal_type))
4535 /* We need to turn this parameter into an aligner type
4537 struct value *aligner = allocate_value (formal_type);
4538 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4540 value_assign_to_component (aligner, component, actual);
4547 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4548 type TYPE. This is usually an inefficient no-op except on some targets
4549 (such as AVR) where the representation of a pointer and an address
4553 value_pointer (struct value *value, struct type *type)
4555 struct gdbarch *gdbarch = get_type_arch (type);
4556 unsigned len = TYPE_LENGTH (type);
4557 gdb_byte *buf = (gdb_byte *) alloca (len);
4560 addr = value_address (value);
4561 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4562 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4567 /* Push a descriptor of type TYPE for array value ARR on the stack at
4568 *SP, updating *SP to reflect the new descriptor. Return either
4569 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4570 to-descriptor type rather than a descriptor type), a struct value *
4571 representing a pointer to this descriptor. */
4573 static struct value *
4574 make_array_descriptor (struct type *type, struct value *arr)
4576 struct type *bounds_type = desc_bounds_type (type);
4577 struct type *desc_type = desc_base_type (type);
4578 struct value *descriptor = allocate_value (desc_type);
4579 struct value *bounds = allocate_value (bounds_type);
4582 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4585 modify_field (value_type (bounds), value_contents_writeable (bounds),
4586 ada_array_bound (arr, i, 0),
4587 desc_bound_bitpos (bounds_type, i, 0),
4588 desc_bound_bitsize (bounds_type, i, 0));
4589 modify_field (value_type (bounds), value_contents_writeable (bounds),
4590 ada_array_bound (arr, i, 1),
4591 desc_bound_bitpos (bounds_type, i, 1),
4592 desc_bound_bitsize (bounds_type, i, 1));
4595 bounds = ensure_lval (bounds);
4597 modify_field (value_type (descriptor),
4598 value_contents_writeable (descriptor),
4599 value_pointer (ensure_lval (arr),
4600 TYPE_FIELD_TYPE (desc_type, 0)),
4601 fat_pntr_data_bitpos (desc_type),
4602 fat_pntr_data_bitsize (desc_type));
4604 modify_field (value_type (descriptor),
4605 value_contents_writeable (descriptor),
4606 value_pointer (bounds,
4607 TYPE_FIELD_TYPE (desc_type, 1)),
4608 fat_pntr_bounds_bitpos (desc_type),
4609 fat_pntr_bounds_bitsize (desc_type));
4611 descriptor = ensure_lval (descriptor);
4613 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4614 return value_addr (descriptor);
4619 /* Symbol Cache Module */
4621 /* Performance measurements made as of 2010-01-15 indicate that
4622 this cache does bring some noticeable improvements. Depending
4623 on the type of entity being printed, the cache can make it as much
4624 as an order of magnitude faster than without it.
4626 The descriptive type DWARF extension has significantly reduced
4627 the need for this cache, at least when DWARF is being used. However,
4628 even in this case, some expensive name-based symbol searches are still
4629 sometimes necessary - to find an XVZ variable, mostly. */
4631 /* Initialize the contents of SYM_CACHE. */
4634 ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4636 obstack_init (&sym_cache->cache_space);
4637 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4640 /* Free the memory used by SYM_CACHE. */
4643 ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
4645 obstack_free (&sym_cache->cache_space, NULL);
4649 /* Return the symbol cache associated to the given program space PSPACE.
4650 If not allocated for this PSPACE yet, allocate and initialize one. */
4652 static struct ada_symbol_cache *
4653 ada_get_symbol_cache (struct program_space *pspace)
4655 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4657 if (pspace_data->sym_cache == NULL)
4659 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4660 ada_init_symbol_cache (pspace_data->sym_cache);
4663 return pspace_data->sym_cache;
4666 /* Clear all entries from the symbol cache. */
4669 ada_clear_symbol_cache (void)
4671 struct ada_symbol_cache *sym_cache
4672 = ada_get_symbol_cache (current_program_space);
4674 obstack_free (&sym_cache->cache_space, NULL);
4675 ada_init_symbol_cache (sym_cache);
4678 /* Search our cache for an entry matching NAME and DOMAIN.
4679 Return it if found, or NULL otherwise. */
4681 static struct cache_entry **
4682 find_entry (const char *name, domain_enum domain)
4684 struct ada_symbol_cache *sym_cache
4685 = ada_get_symbol_cache (current_program_space);
4686 int h = msymbol_hash (name) % HASH_SIZE;
4687 struct cache_entry **e;
4689 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4691 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4697 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4698 Return 1 if found, 0 otherwise.
4700 If an entry was found and SYM is not NULL, set *SYM to the entry's
4701 SYM. Same principle for BLOCK if not NULL. */
4704 lookup_cached_symbol (const char *name, domain_enum domain,
4705 struct symbol **sym, const struct block **block)
4707 struct cache_entry **e = find_entry (name, domain);
4714 *block = (*e)->block;
4718 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4719 in domain DOMAIN, save this result in our symbol cache. */
4722 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4723 const struct block *block)
4725 struct ada_symbol_cache *sym_cache
4726 = ada_get_symbol_cache (current_program_space);
4729 struct cache_entry *e;
4731 /* Symbols for builtin types don't have a block.
4732 For now don't cache such symbols. */
4733 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4736 /* If the symbol is a local symbol, then do not cache it, as a search
4737 for that symbol depends on the context. To determine whether
4738 the symbol is local or not, we check the block where we found it
4739 against the global and static blocks of its associated symtab. */
4741 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4742 GLOBAL_BLOCK) != block
4743 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4744 STATIC_BLOCK) != block)
4747 h = msymbol_hash (name) % HASH_SIZE;
4748 e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space,
4750 e->next = sym_cache->root[h];
4751 sym_cache->root[h] = e;
4753 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
4754 strcpy (copy, name);
4762 /* Return the symbol name match type that should be used used when
4763 searching for all symbols matching LOOKUP_NAME.
4765 LOOKUP_NAME is expected to be a symbol name after transformation
4768 static symbol_name_match_type
4769 name_match_type_from_name (const char *lookup_name)
4771 return (strstr (lookup_name, "__") == NULL
4772 ? symbol_name_match_type::WILD
4773 : symbol_name_match_type::FULL);
4776 /* Return the result of a standard (literal, C-like) lookup of NAME in
4777 given DOMAIN, visible from lexical block BLOCK. */
4779 static struct symbol *
4780 standard_lookup (const char *name, const struct block *block,
4783 /* Initialize it just to avoid a GCC false warning. */
4784 struct block_symbol sym = {NULL, NULL};
4786 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4788 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4789 cache_symbol (name, domain, sym.symbol, sym.block);
4794 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4795 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4796 since they contend in overloading in the same way. */
4798 is_nonfunction (struct block_symbol syms[], int n)
4802 for (i = 0; i < n; i += 1)
4803 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4804 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4805 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
4811 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4812 struct types. Otherwise, they may not. */
4815 equiv_types (struct type *type0, struct type *type1)
4819 if (type0 == NULL || type1 == NULL
4820 || TYPE_CODE (type0) != TYPE_CODE (type1))
4822 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4823 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4824 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4825 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4831 /* True iff SYM0 represents the same entity as SYM1, or one that is
4832 no more defined than that of SYM1. */
4835 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4839 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4840 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4843 switch (SYMBOL_CLASS (sym0))
4849 struct type *type0 = SYMBOL_TYPE (sym0);
4850 struct type *type1 = SYMBOL_TYPE (sym1);
4851 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4852 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4853 int len0 = strlen (name0);
4856 TYPE_CODE (type0) == TYPE_CODE (type1)
4857 && (equiv_types (type0, type1)
4858 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4859 && startswith (name1 + len0, "___XV")));
4862 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4863 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4869 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4870 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4873 add_defn_to_vec (struct obstack *obstackp,
4875 const struct block *block)
4878 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
4880 /* Do not try to complete stub types, as the debugger is probably
4881 already scanning all symbols matching a certain name at the
4882 time when this function is called. Trying to replace the stub
4883 type by its associated full type will cause us to restart a scan
4884 which may lead to an infinite recursion. Instead, the client
4885 collecting the matching symbols will end up collecting several
4886 matches, with at least one of them complete. It can then filter
4887 out the stub ones if needed. */
4889 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4891 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4893 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4895 prevDefns[i].symbol = sym;
4896 prevDefns[i].block = block;
4902 struct block_symbol info;
4906 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4910 /* Number of block_symbol structures currently collected in current vector in
4914 num_defns_collected (struct obstack *obstackp)
4916 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4919 /* Vector of block_symbol structures currently collected in current vector in
4920 OBSTACKP. If FINISH, close off the vector and return its final address. */
4922 static struct block_symbol *
4923 defns_collected (struct obstack *obstackp, int finish)
4926 return (struct block_symbol *) obstack_finish (obstackp);
4928 return (struct block_symbol *) obstack_base (obstackp);
4931 /* Return a bound minimal symbol matching NAME according to Ada
4932 decoding rules. Returns an invalid symbol if there is no such
4933 minimal symbol. Names prefixed with "standard__" are handled
4934 specially: "standard__" is first stripped off, and only static and
4935 global symbols are searched. */
4937 struct bound_minimal_symbol
4938 ada_lookup_simple_minsym (const char *name)
4940 struct bound_minimal_symbol result;
4941 struct objfile *objfile;
4942 struct minimal_symbol *msymbol;
4944 memset (&result, 0, sizeof (result));
4946 symbol_name_match_type match_type = name_match_type_from_name (name);
4947 lookup_name_info lookup_name (name, match_type);
4949 symbol_name_matcher_ftype *match_name
4950 = ada_get_symbol_name_matcher (lookup_name);
4952 ALL_MSYMBOLS (objfile, msymbol)
4954 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4955 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4957 result.minsym = msymbol;
4958 result.objfile = objfile;
4966 /* For all subprograms that statically enclose the subprogram of the
4967 selected frame, add symbols matching identifier NAME in DOMAIN
4968 and their blocks to the list of data in OBSTACKP, as for
4969 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4970 with a wildcard prefix. */
4973 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4974 const lookup_name_info &lookup_name,
4979 /* True if TYPE is definitely an artificial type supplied to a symbol
4980 for which no debugging information was given in the symbol file. */
4983 is_nondebugging_type (struct type *type)
4985 const char *name = ada_type_name (type);
4987 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4990 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4991 that are deemed "identical" for practical purposes.
4993 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4994 types and that their number of enumerals is identical (in other
4995 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4998 ada_identical_enum_types_p (struct type *type1, struct type *type2)
5002 /* The heuristic we use here is fairly conservative. We consider
5003 that 2 enumerate types are identical if they have the same
5004 number of enumerals and that all enumerals have the same
5005 underlying value and name. */
5007 /* All enums in the type should have an identical underlying value. */
5008 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5009 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
5012 /* All enumerals should also have the same name (modulo any numerical
5014 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5016 const char *name_1 = TYPE_FIELD_NAME (type1, i);
5017 const char *name_2 = TYPE_FIELD_NAME (type2, i);
5018 int len_1 = strlen (name_1);
5019 int len_2 = strlen (name_2);
5021 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5022 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5024 || strncmp (TYPE_FIELD_NAME (type1, i),
5025 TYPE_FIELD_NAME (type2, i),
5033 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
5034 that are deemed "identical" for practical purposes. Sometimes,
5035 enumerals are not strictly identical, but their types are so similar
5036 that they can be considered identical.
5038 For instance, consider the following code:
5040 type Color is (Black, Red, Green, Blue, White);
5041 type RGB_Color is new Color range Red .. Blue;
5043 Type RGB_Color is a subrange of an implicit type which is a copy
5044 of type Color. If we call that implicit type RGB_ColorB ("B" is
5045 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5046 As a result, when an expression references any of the enumeral
5047 by name (Eg. "print green"), the expression is technically
5048 ambiguous and the user should be asked to disambiguate. But
5049 doing so would only hinder the user, since it wouldn't matter
5050 what choice he makes, the outcome would always be the same.
5051 So, for practical purposes, we consider them as the same. */
5054 symbols_are_identical_enums (struct block_symbol *syms, int nsyms)
5058 /* Before performing a thorough comparison check of each type,
5059 we perform a series of inexpensive checks. We expect that these
5060 checks will quickly fail in the vast majority of cases, and thus
5061 help prevent the unnecessary use of a more expensive comparison.
5062 Said comparison also expects us to make some of these checks
5063 (see ada_identical_enum_types_p). */
5065 /* Quick check: All symbols should have an enum type. */
5066 for (i = 0; i < nsyms; i++)
5067 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
5070 /* Quick check: They should all have the same value. */
5071 for (i = 1; i < nsyms; i++)
5072 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
5075 /* Quick check: They should all have the same number of enumerals. */
5076 for (i = 1; i < nsyms; i++)
5077 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5078 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
5081 /* All the sanity checks passed, so we might have a set of
5082 identical enumeration types. Perform a more complete
5083 comparison of the type of each symbol. */
5084 for (i = 1; i < nsyms; i++)
5085 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5086 SYMBOL_TYPE (syms[0].symbol)))
5092 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
5093 duplicate other symbols in the list (The only case I know of where
5094 this happens is when object files containing stabs-in-ecoff are
5095 linked with files containing ordinary ecoff debugging symbols (or no
5096 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5097 Returns the number of items in the modified list. */
5100 remove_extra_symbols (struct block_symbol *syms, int nsyms)
5104 /* We should never be called with less than 2 symbols, as there
5105 cannot be any extra symbol in that case. But it's easy to
5106 handle, since we have nothing to do in that case. */
5115 /* If two symbols have the same name and one of them is a stub type,
5116 the get rid of the stub. */
5118 if (TYPE_STUB (SYMBOL_TYPE (syms[i].symbol))
5119 && SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL)
5121 for (j = 0; j < nsyms; j++)
5124 && !TYPE_STUB (SYMBOL_TYPE (syms[j].symbol))
5125 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5126 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5127 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0)
5132 /* Two symbols with the same name, same class and same address
5133 should be identical. */
5135 else if (SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL
5136 && SYMBOL_CLASS (syms[i].symbol) == LOC_STATIC
5137 && is_nondebugging_type (SYMBOL_TYPE (syms[i].symbol)))
5139 for (j = 0; j < nsyms; j += 1)
5142 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5143 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5144 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0
5145 && SYMBOL_CLASS (syms[i].symbol)
5146 == SYMBOL_CLASS (syms[j].symbol)
5147 && SYMBOL_VALUE_ADDRESS (syms[i].symbol)
5148 == SYMBOL_VALUE_ADDRESS (syms[j].symbol))
5155 for (j = i + 1; j < nsyms; j += 1)
5156 syms[j - 1] = syms[j];
5163 /* If all the remaining symbols are identical enumerals, then
5164 just keep the first one and discard the rest.
5166 Unlike what we did previously, we do not discard any entry
5167 unless they are ALL identical. This is because the symbol
5168 comparison is not a strict comparison, but rather a practical
5169 comparison. If all symbols are considered identical, then
5170 we can just go ahead and use the first one and discard the rest.
5171 But if we cannot reduce the list to a single element, we have
5172 to ask the user to disambiguate anyways. And if we have to
5173 present a multiple-choice menu, it's less confusing if the list
5174 isn't missing some choices that were identical and yet distinct. */
5175 if (symbols_are_identical_enums (syms, nsyms))
5181 /* Given a type that corresponds to a renaming entity, use the type name
5182 to extract the scope (package name or function name, fully qualified,
5183 and following the GNAT encoding convention) where this renaming has been
5184 defined. The string returned needs to be deallocated after use. */
5187 xget_renaming_scope (struct type *renaming_type)
5189 /* The renaming types adhere to the following convention:
5190 <scope>__<rename>___<XR extension>.
5191 So, to extract the scope, we search for the "___XR" extension,
5192 and then backtrack until we find the first "__". */
5194 const char *name = type_name_no_tag (renaming_type);
5195 const char *suffix = strstr (name, "___XR");
5200 /* Now, backtrack a bit until we find the first "__". Start looking
5201 at suffix - 3, as the <rename> part is at least one character long. */
5203 for (last = suffix - 3; last > name; last--)
5204 if (last[0] == '_' && last[1] == '_')
5207 /* Make a copy of scope and return it. */
5209 scope_len = last - name;
5210 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
5212 strncpy (scope, name, scope_len);
5213 scope[scope_len] = '\0';
5218 /* Return nonzero if NAME corresponds to a package name. */
5221 is_package_name (const char *name)
5223 /* Here, We take advantage of the fact that no symbols are generated
5224 for packages, while symbols are generated for each function.
5225 So the condition for NAME represent a package becomes equivalent
5226 to NAME not existing in our list of symbols. There is only one
5227 small complication with library-level functions (see below). */
5231 /* If it is a function that has not been defined at library level,
5232 then we should be able to look it up in the symbols. */
5233 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5236 /* Library-level function names start with "_ada_". See if function
5237 "_ada_" followed by NAME can be found. */
5239 /* Do a quick check that NAME does not contain "__", since library-level
5240 functions names cannot contain "__" in them. */
5241 if (strstr (name, "__") != NULL)
5244 fun_name = xstrprintf ("_ada_%s", name);
5246 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
5249 /* Return nonzero if SYM corresponds to a renaming entity that is
5250 not visible from FUNCTION_NAME. */
5253 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5256 struct cleanup *old_chain;
5258 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5261 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
5262 old_chain = make_cleanup (xfree, scope);
5264 /* If the rename has been defined in a package, then it is visible. */
5265 if (is_package_name (scope))
5267 do_cleanups (old_chain);
5271 /* Check that the rename is in the current function scope by checking
5272 that its name starts with SCOPE. */
5274 /* If the function name starts with "_ada_", it means that it is
5275 a library-level function. Strip this prefix before doing the
5276 comparison, as the encoding for the renaming does not contain
5278 if (startswith (function_name, "_ada_"))
5282 int is_invisible = !startswith (function_name, scope);
5284 do_cleanups (old_chain);
5285 return is_invisible;
5289 /* Remove entries from SYMS that corresponds to a renaming entity that
5290 is not visible from the function associated with CURRENT_BLOCK or
5291 that is superfluous due to the presence of more specific renaming
5292 information. Places surviving symbols in the initial entries of
5293 SYMS and returns the number of surviving symbols.
5296 First, in cases where an object renaming is implemented as a
5297 reference variable, GNAT may produce both the actual reference
5298 variable and the renaming encoding. In this case, we discard the
5301 Second, GNAT emits a type following a specified encoding for each renaming
5302 entity. Unfortunately, STABS currently does not support the definition
5303 of types that are local to a given lexical block, so all renamings types
5304 are emitted at library level. As a consequence, if an application
5305 contains two renaming entities using the same name, and a user tries to
5306 print the value of one of these entities, the result of the ada symbol
5307 lookup will also contain the wrong renaming type.
5309 This function partially covers for this limitation by attempting to
5310 remove from the SYMS list renaming symbols that should be visible
5311 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5312 method with the current information available. The implementation
5313 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5315 - When the user tries to print a rename in a function while there
5316 is another rename entity defined in a package: Normally, the
5317 rename in the function has precedence over the rename in the
5318 package, so the latter should be removed from the list. This is
5319 currently not the case.
5321 - This function will incorrectly remove valid renames if
5322 the CURRENT_BLOCK corresponds to a function which symbol name
5323 has been changed by an "Export" pragma. As a consequence,
5324 the user will be unable to print such rename entities. */
5327 remove_irrelevant_renamings (struct block_symbol *syms,
5328 int nsyms, const struct block *current_block)
5330 struct symbol *current_function;
5331 const char *current_function_name;
5333 int is_new_style_renaming;
5335 /* If there is both a renaming foo___XR... encoded as a variable and
5336 a simple variable foo in the same block, discard the latter.
5337 First, zero out such symbols, then compress. */
5338 is_new_style_renaming = 0;
5339 for (i = 0; i < nsyms; i += 1)
5341 struct symbol *sym = syms[i].symbol;
5342 const struct block *block = syms[i].block;
5346 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5348 name = SYMBOL_LINKAGE_NAME (sym);
5349 suffix = strstr (name, "___XR");
5353 int name_len = suffix - name;
5356 is_new_style_renaming = 1;
5357 for (j = 0; j < nsyms; j += 1)
5358 if (i != j && syms[j].symbol != NULL
5359 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].symbol),
5361 && block == syms[j].block)
5362 syms[j].symbol = NULL;
5365 if (is_new_style_renaming)
5369 for (j = k = 0; j < nsyms; j += 1)
5370 if (syms[j].symbol != NULL)
5378 /* Extract the function name associated to CURRENT_BLOCK.
5379 Abort if unable to do so. */
5381 if (current_block == NULL)
5384 current_function = block_linkage_function (current_block);
5385 if (current_function == NULL)
5388 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5389 if (current_function_name == NULL)
5392 /* Check each of the symbols, and remove it from the list if it is
5393 a type corresponding to a renaming that is out of the scope of
5394 the current block. */
5399 if (ada_parse_renaming (syms[i].symbol, NULL, NULL, NULL)
5400 == ADA_OBJECT_RENAMING
5401 && old_renaming_is_invisible (syms[i].symbol, current_function_name))
5405 for (j = i + 1; j < nsyms; j += 1)
5406 syms[j - 1] = syms[j];
5416 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5417 whose name and domain match NAME and DOMAIN respectively.
5418 If no match was found, then extend the search to "enclosing"
5419 routines (in other words, if we're inside a nested function,
5420 search the symbols defined inside the enclosing functions).
5421 If WILD_MATCH_P is nonzero, perform the naming matching in
5422 "wild" mode (see function "wild_match" for more info).
5424 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5427 ada_add_local_symbols (struct obstack *obstackp,
5428 const lookup_name_info &lookup_name,
5429 const struct block *block, domain_enum domain)
5431 int block_depth = 0;
5433 while (block != NULL)
5436 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5438 /* If we found a non-function match, assume that's the one. */
5439 if (is_nonfunction (defns_collected (obstackp, 0),
5440 num_defns_collected (obstackp)))
5443 block = BLOCK_SUPERBLOCK (block);
5446 /* If no luck so far, try to find NAME as a local symbol in some lexically
5447 enclosing subprogram. */
5448 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
5449 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
5452 /* An object of this type is used as the user_data argument when
5453 calling the map_matching_symbols method. */
5457 struct objfile *objfile;
5458 struct obstack *obstackp;
5459 struct symbol *arg_sym;
5463 /* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
5464 to a list of symbols. DATA0 is a pointer to a struct match_data *
5465 containing the obstack that collects the symbol list, the file that SYM
5466 must come from, a flag indicating whether a non-argument symbol has
5467 been found in the current block, and the last argument symbol
5468 passed in SYM within the current block (if any). When SYM is null,
5469 marking the end of a block, the argument symbol is added if no
5470 other has been found. */
5473 aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
5475 struct match_data *data = (struct match_data *) data0;
5479 if (!data->found_sym && data->arg_sym != NULL)
5480 add_defn_to_vec (data->obstackp,
5481 fixup_symbol_section (data->arg_sym, data->objfile),
5483 data->found_sym = 0;
5484 data->arg_sym = NULL;
5488 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5490 else if (SYMBOL_IS_ARGUMENT (sym))
5491 data->arg_sym = sym;
5494 data->found_sym = 1;
5495 add_defn_to_vec (data->obstackp,
5496 fixup_symbol_section (sym, data->objfile),
5503 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5504 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5505 symbols to OBSTACKP. Return whether we found such symbols. */
5508 ada_add_block_renamings (struct obstack *obstackp,
5509 const struct block *block,
5510 const lookup_name_info &lookup_name,
5513 struct using_direct *renaming;
5514 int defns_mark = num_defns_collected (obstackp);
5516 symbol_name_matcher_ftype *name_match
5517 = ada_get_symbol_name_matcher (lookup_name);
5519 for (renaming = block_using (block);
5521 renaming = renaming->next)
5525 /* Avoid infinite recursions: skip this renaming if we are actually
5526 already traversing it.
5528 Currently, symbol lookup in Ada don't use the namespace machinery from
5529 C++/Fortran support: skip namespace imports that use them. */
5530 if (renaming->searched
5531 || (renaming->import_src != NULL
5532 && renaming->import_src[0] != '\0')
5533 || (renaming->import_dest != NULL
5534 && renaming->import_dest[0] != '\0'))
5536 renaming->searched = 1;
5538 /* TODO: here, we perform another name-based symbol lookup, which can
5539 pull its own multiple overloads. In theory, we should be able to do
5540 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5541 not a simple name. But in order to do this, we would need to enhance
5542 the DWARF reader to associate a symbol to this renaming, instead of a
5543 name. So, for now, we do something simpler: re-use the C++/Fortran
5544 namespace machinery. */
5545 r_name = (renaming->alias != NULL
5547 : renaming->declaration);
5548 if (name_match (r_name, lookup_name, NULL))
5550 lookup_name_info decl_lookup_name (renaming->declaration,
5551 lookup_name.match_type ());
5552 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5555 renaming->searched = 0;
5557 return num_defns_collected (obstackp) != defns_mark;
5560 /* Implements compare_names, but only applying the comparision using
5561 the given CASING. */
5564 compare_names_with_case (const char *string1, const char *string2,
5565 enum case_sensitivity casing)
5567 while (*string1 != '\0' && *string2 != '\0')
5571 if (isspace (*string1) || isspace (*string2))
5572 return strcmp_iw_ordered (string1, string2);
5574 if (casing == case_sensitive_off)
5576 c1 = tolower (*string1);
5577 c2 = tolower (*string2);
5594 return strcmp_iw_ordered (string1, string2);
5596 if (*string2 == '\0')
5598 if (is_name_suffix (string1))
5605 if (*string2 == '(')
5606 return strcmp_iw_ordered (string1, string2);
5609 if (casing == case_sensitive_off)
5610 return tolower (*string1) - tolower (*string2);
5612 return *string1 - *string2;
5617 /* Compare STRING1 to STRING2, with results as for strcmp.
5618 Compatible with strcmp_iw_ordered in that...
5620 strcmp_iw_ordered (STRING1, STRING2) <= 0
5624 compare_names (STRING1, STRING2) <= 0
5626 (they may differ as to what symbols compare equal). */
5629 compare_names (const char *string1, const char *string2)
5633 /* Similar to what strcmp_iw_ordered does, we need to perform
5634 a case-insensitive comparison first, and only resort to
5635 a second, case-sensitive, comparison if the first one was
5636 not sufficient to differentiate the two strings. */
5638 result = compare_names_with_case (string1, string2, case_sensitive_off);
5640 result = compare_names_with_case (string1, string2, case_sensitive_on);
5645 /* Convenience function to get at the Ada encoded lookup name for
5646 LOOKUP_NAME, as a C string. */
5649 ada_lookup_name (const lookup_name_info &lookup_name)
5651 return lookup_name.ada ().lookup_name ().c_str ();
5654 /* Add to OBSTACKP all non-local symbols whose name and domain match
5655 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5656 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5657 symbols otherwise. */
5660 add_nonlocal_symbols (struct obstack *obstackp,
5661 const lookup_name_info &lookup_name,
5662 domain_enum domain, int global)
5664 struct objfile *objfile;
5665 struct compunit_symtab *cu;
5666 struct match_data data;
5668 memset (&data, 0, sizeof data);
5669 data.obstackp = obstackp;
5671 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5673 ALL_OBJFILES (objfile)
5675 data.objfile = objfile;
5678 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5680 aux_add_nonlocal_symbols, &data,
5681 symbol_name_match_type::WILD,
5684 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5686 aux_add_nonlocal_symbols, &data,
5687 symbol_name_match_type::FULL,
5690 ALL_OBJFILE_COMPUNITS (objfile, cu)
5692 const struct block *global_block
5693 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5695 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5701 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5703 const char *name = ada_lookup_name (lookup_name);
5704 std::string name1 = std::string ("<_ada_") + name + '>';
5706 ALL_OBJFILES (objfile)
5708 data.objfile = objfile;
5709 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5711 aux_add_nonlocal_symbols,
5713 symbol_name_match_type::FULL,
5719 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5720 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5721 returning the number of matches. Add these to OBSTACKP.
5723 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5724 symbol match within the nest of blocks whose innermost member is BLOCK,
5725 is the one match returned (no other matches in that or
5726 enclosing blocks is returned). If there are any matches in or
5727 surrounding BLOCK, then these alone are returned.
5729 Names prefixed with "standard__" are handled specially:
5730 "standard__" is first stripped off (by the lookup_name
5731 constructor), and only static and global symbols are searched.
5733 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5734 to lookup global symbols. */
5737 ada_add_all_symbols (struct obstack *obstackp,
5738 const struct block *block,
5739 const lookup_name_info &lookup_name,
5742 int *made_global_lookup_p)
5746 if (made_global_lookup_p)
5747 *made_global_lookup_p = 0;
5749 /* Special case: If the user specifies a symbol name inside package
5750 Standard, do a non-wild matching of the symbol name without
5751 the "standard__" prefix. This was primarily introduced in order
5752 to allow the user to specifically access the standard exceptions
5753 using, for instance, Standard.Constraint_Error when Constraint_Error
5754 is ambiguous (due to the user defining its own Constraint_Error
5755 entity inside its program). */
5756 if (lookup_name.ada ().standard_p ())
5759 /* Check the non-global symbols. If we have ANY match, then we're done. */
5764 ada_add_local_symbols (obstackp, lookup_name, block, domain);
5767 /* In the !full_search case we're are being called by
5768 ada_iterate_over_symbols, and we don't want to search
5770 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5772 if (num_defns_collected (obstackp) > 0 || !full_search)
5776 /* No non-global symbols found. Check our cache to see if we have
5777 already performed this search before. If we have, then return
5780 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5781 domain, &sym, &block))
5784 add_defn_to_vec (obstackp, sym, block);
5788 if (made_global_lookup_p)
5789 *made_global_lookup_p = 1;
5791 /* Search symbols from all global blocks. */
5793 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
5795 /* Now add symbols from all per-file blocks if we've gotten no hits
5796 (not strictly correct, but perhaps better than an error). */
5798 if (num_defns_collected (obstackp) == 0)
5799 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
5802 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5803 is non-zero, enclosing scope and in global scopes, returning the number of
5805 Sets *RESULTS to point to a newly allocated vector of (SYM,BLOCK) tuples,
5806 indicating the symbols found and the blocks and symbol tables (if
5807 any) in which they were found. This vector should be freed when
5810 When full_search is non-zero, any non-function/non-enumeral
5811 symbol match within the nest of blocks whose innermost member is BLOCK,
5812 is the one match returned (no other matches in that or
5813 enclosing blocks is returned). If there are any matches in or
5814 surrounding BLOCK, then these alone are returned.
5816 Names prefixed with "standard__" are handled specially: "standard__"
5817 is first stripped off, and only static and global symbols are searched. */
5820 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5821 const struct block *block,
5823 struct block_symbol **results,
5826 int syms_from_global_search;
5829 auto_obstack obstack;
5831 ada_add_all_symbols (&obstack, block, lookup_name,
5832 domain, full_search, &syms_from_global_search);
5834 ndefns = num_defns_collected (&obstack);
5836 results_size = obstack_object_size (&obstack);
5837 *results = (struct block_symbol *) malloc (results_size);
5838 memcpy (*results, defns_collected (&obstack, 1), results_size);
5840 ndefns = remove_extra_symbols (*results, ndefns);
5842 if (ndefns == 0 && full_search && syms_from_global_search)
5843 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5845 if (ndefns == 1 && full_search && syms_from_global_search)
5846 cache_symbol (ada_lookup_name (lookup_name), domain,
5847 (*results)[0].symbol, (*results)[0].block);
5849 ndefns = remove_irrelevant_renamings (*results, ndefns, block);
5854 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5855 in global scopes, returning the number of matches, and setting *RESULTS
5856 to a newly-allocated vector of (SYM,BLOCK) tuples. This newly-allocated
5857 vector should be freed when no longer useful.
5859 See ada_lookup_symbol_list_worker for further details. */
5862 ada_lookup_symbol_list (const char *name, const struct block *block,
5863 domain_enum domain, struct block_symbol **results)
5865 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5866 lookup_name_info lookup_name (name, name_match_type);
5868 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
5871 /* Implementation of the la_iterate_over_symbols method. */
5874 ada_iterate_over_symbols
5875 (const struct block *block, const lookup_name_info &name,
5877 gdb::function_view<symbol_found_callback_ftype> callback)
5880 struct block_symbol *results;
5881 struct cleanup *old_chain;
5883 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5884 old_chain = make_cleanup (xfree, results);
5886 for (i = 0; i < ndefs; ++i)
5888 if (!callback (results[i].symbol))
5892 do_cleanups (old_chain);
5895 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5896 to 1, but choosing the first symbol found if there are multiple
5899 The result is stored in *INFO, which must be non-NULL.
5900 If no match is found, INFO->SYM is set to NULL. */
5903 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5905 struct block_symbol *info)
5907 /* Since we already have an encoded name, wrap it in '<>' to force a
5908 verbatim match. Otherwise, if the name happens to not look like
5909 an encoded name (because it doesn't include a "__"),
5910 ada_lookup_name_info would re-encode/fold it again, and that
5911 would e.g., incorrectly lowercase object renaming names like
5912 "R28b" -> "r28b". */
5913 std::string verbatim = std::string ("<") + name + '>';
5915 gdb_assert (info != NULL);
5916 *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL);
5919 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5920 scope and in global scopes, or NULL if none. NAME is folded and
5921 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5922 choosing the first symbol if there are multiple choices.
5923 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5926 ada_lookup_symbol (const char *name, const struct block *block0,
5927 domain_enum domain, int *is_a_field_of_this)
5929 if (is_a_field_of_this != NULL)
5930 *is_a_field_of_this = 0;
5932 struct block_symbol *candidates;
5934 struct cleanup *old_chain;
5936 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
5937 old_chain = make_cleanup (xfree, candidates);
5939 if (n_candidates == 0)
5941 do_cleanups (old_chain);
5945 block_symbol info = candidates[0];
5946 info.symbol = fixup_symbol_section (info.symbol, NULL);
5948 do_cleanups (old_chain);
5953 static struct block_symbol
5954 ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5956 const struct block *block,
5957 const domain_enum domain)
5959 struct block_symbol sym;
5961 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
5962 if (sym.symbol != NULL)
5965 /* If we haven't found a match at this point, try the primitive
5966 types. In other languages, this search is performed before
5967 searching for global symbols in order to short-circuit that
5968 global-symbol search if it happens that the name corresponds
5969 to a primitive type. But we cannot do the same in Ada, because
5970 it is perfectly legitimate for a program to declare a type which
5971 has the same name as a standard type. If looking up a type in
5972 that situation, we have traditionally ignored the primitive type
5973 in favor of user-defined types. This is why, unlike most other
5974 languages, we search the primitive types this late and only after
5975 having searched the global symbols without success. */
5977 if (domain == VAR_DOMAIN)
5979 struct gdbarch *gdbarch;
5982 gdbarch = target_gdbarch ();
5984 gdbarch = block_gdbarch (block);
5985 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5986 if (sym.symbol != NULL)
5990 return (struct block_symbol) {NULL, NULL};
5994 /* True iff STR is a possible encoded suffix of a normal Ada name
5995 that is to be ignored for matching purposes. Suffixes of parallel
5996 names (e.g., XVE) are not included here. Currently, the possible suffixes
5997 are given by any of the regular expressions:
5999 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
6000 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
6001 TKB [subprogram suffix for task bodies]
6002 _E[0-9]+[bs]$ [protected object entry suffixes]
6003 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
6005 Also, any leading "__[0-9]+" sequence is skipped before the suffix
6006 match is performed. This sequence is used to differentiate homonyms,
6007 is an optional part of a valid name suffix. */
6010 is_name_suffix (const char *str)
6013 const char *matching;
6014 const int len = strlen (str);
6016 /* Skip optional leading __[0-9]+. */
6018 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
6021 while (isdigit (str[0]))
6027 if (str[0] == '.' || str[0] == '$')
6030 while (isdigit (matching[0]))
6032 if (matching[0] == '\0')
6038 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
6041 while (isdigit (matching[0]))
6043 if (matching[0] == '\0')
6047 /* "TKB" suffixes are used for subprograms implementing task bodies. */
6049 if (strcmp (str, "TKB") == 0)
6053 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
6054 with a N at the end. Unfortunately, the compiler uses the same
6055 convention for other internal types it creates. So treating
6056 all entity names that end with an "N" as a name suffix causes
6057 some regressions. For instance, consider the case of an enumerated
6058 type. To support the 'Image attribute, it creates an array whose
6060 Having a single character like this as a suffix carrying some
6061 information is a bit risky. Perhaps we should change the encoding
6062 to be something like "_N" instead. In the meantime, do not do
6063 the following check. */
6064 /* Protected Object Subprograms */
6065 if (len == 1 && str [0] == 'N')
6070 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6073 while (isdigit (matching[0]))
6075 if ((matching[0] == 'b' || matching[0] == 's')
6076 && matching [1] == '\0')
6080 /* ??? We should not modify STR directly, as we are doing below. This
6081 is fine in this case, but may become problematic later if we find
6082 that this alternative did not work, and want to try matching
6083 another one from the begining of STR. Since we modified it, we
6084 won't be able to find the begining of the string anymore! */
6088 while (str[0] != '_' && str[0] != '\0')
6090 if (str[0] != 'n' && str[0] != 'b')
6096 if (str[0] == '\000')
6101 if (str[1] != '_' || str[2] == '\000')
6105 if (strcmp (str + 3, "JM") == 0)
6107 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6108 the LJM suffix in favor of the JM one. But we will
6109 still accept LJM as a valid suffix for a reasonable
6110 amount of time, just to allow ourselves to debug programs
6111 compiled using an older version of GNAT. */
6112 if (strcmp (str + 3, "LJM") == 0)
6116 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6117 || str[4] == 'U' || str[4] == 'P')
6119 if (str[4] == 'R' && str[5] != 'T')
6123 if (!isdigit (str[2]))
6125 for (k = 3; str[k] != '\0'; k += 1)
6126 if (!isdigit (str[k]) && str[k] != '_')
6130 if (str[0] == '$' && isdigit (str[1]))
6132 for (k = 2; str[k] != '\0'; k += 1)
6133 if (!isdigit (str[k]) && str[k] != '_')
6140 /* Return non-zero if the string starting at NAME and ending before
6141 NAME_END contains no capital letters. */
6144 is_valid_name_for_wild_match (const char *name0)
6146 const char *decoded_name = ada_decode (name0);
6149 /* If the decoded name starts with an angle bracket, it means that
6150 NAME0 does not follow the GNAT encoding format. It should then
6151 not be allowed as a possible wild match. */
6152 if (decoded_name[0] == '<')
6155 for (i=0; decoded_name[i] != '\0'; i++)
6156 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6162 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6163 that could start a simple name. Assumes that *NAMEP points into
6164 the string beginning at NAME0. */
6167 advance_wild_match (const char **namep, const char *name0, int target0)
6169 const char *name = *namep;
6179 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6182 if (name == name0 + 5 && startswith (name0, "_ada"))
6187 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6188 || name[2] == target0))
6196 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6206 /* Return true iff NAME encodes a name of the form prefix.PATN.
6207 Ignores any informational suffixes of NAME (i.e., for which
6208 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6212 wild_match (const char *name, const char *patn)
6215 const char *name0 = name;
6219 const char *match = name;
6223 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6226 if (*p == '\0' && is_name_suffix (name))
6227 return match == name0 || is_valid_name_for_wild_match (name0);
6229 if (name[-1] == '_')
6232 if (!advance_wild_match (&name, name0, *patn))
6237 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6238 any trailing suffixes that encode debugging information or leading
6239 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6240 information that is ignored). */
6243 full_match (const char *sym_name, const char *search_name)
6245 size_t search_name_len = strlen (search_name);
6247 if (strncmp (sym_name, search_name, search_name_len) == 0
6248 && is_name_suffix (sym_name + search_name_len))
6251 if (startswith (sym_name, "_ada_")
6252 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6253 && is_name_suffix (sym_name + search_name_len + 5))
6259 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6260 *defn_symbols, updating the list of symbols in OBSTACKP (if
6261 necessary). OBJFILE is the section containing BLOCK. */
6264 ada_add_block_symbols (struct obstack *obstackp,
6265 const struct block *block,
6266 const lookup_name_info &lookup_name,
6267 domain_enum domain, struct objfile *objfile)
6269 struct block_iterator iter;
6270 /* A matching argument symbol, if any. */
6271 struct symbol *arg_sym;
6272 /* Set true when we find a matching non-argument symbol. */
6278 for (sym = block_iter_match_first (block, lookup_name, &iter);
6280 sym = block_iter_match_next (lookup_name, &iter))
6282 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6283 SYMBOL_DOMAIN (sym), domain))
6285 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6287 if (SYMBOL_IS_ARGUMENT (sym))
6292 add_defn_to_vec (obstackp,
6293 fixup_symbol_section (sym, objfile),
6300 /* Handle renamings. */
6302 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
6305 if (!found_sym && arg_sym != NULL)
6307 add_defn_to_vec (obstackp,
6308 fixup_symbol_section (arg_sym, objfile),
6312 if (!lookup_name.ada ().wild_match_p ())
6316 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6317 const char *name = ada_lookup_name.c_str ();
6318 size_t name_len = ada_lookup_name.size ();
6320 ALL_BLOCK_SYMBOLS (block, iter, sym)
6322 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6323 SYMBOL_DOMAIN (sym), domain))
6327 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6330 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
6332 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6337 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6339 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6341 if (SYMBOL_IS_ARGUMENT (sym))
6346 add_defn_to_vec (obstackp,
6347 fixup_symbol_section (sym, objfile),
6355 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6356 They aren't parameters, right? */
6357 if (!found_sym && arg_sym != NULL)
6359 add_defn_to_vec (obstackp,
6360 fixup_symbol_section (arg_sym, objfile),
6367 /* Symbol Completion */
6372 ada_lookup_name_info::matches
6373 (const char *sym_name,
6374 symbol_name_match_type match_type,
6375 completion_match_result *comp_match_res) const
6378 const char *text = m_encoded_name.c_str ();
6379 size_t text_len = m_encoded_name.size ();
6381 /* First, test against the fully qualified name of the symbol. */
6383 if (strncmp (sym_name, text, text_len) == 0)
6386 if (match && !m_encoded_p)
6388 /* One needed check before declaring a positive match is to verify
6389 that iff we are doing a verbatim match, the decoded version
6390 of the symbol name starts with '<'. Otherwise, this symbol name
6391 is not a suitable completion. */
6392 const char *sym_name_copy = sym_name;
6393 bool has_angle_bracket;
6395 sym_name = ada_decode (sym_name);
6396 has_angle_bracket = (sym_name[0] == '<');
6397 match = (has_angle_bracket == m_verbatim_p);
6398 sym_name = sym_name_copy;
6401 if (match && !m_verbatim_p)
6403 /* When doing non-verbatim match, another check that needs to
6404 be done is to verify that the potentially matching symbol name
6405 does not include capital letters, because the ada-mode would
6406 not be able to understand these symbol names without the
6407 angle bracket notation. */
6410 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6415 /* Second: Try wild matching... */
6417 if (!match && m_wild_match_p)
6419 /* Since we are doing wild matching, this means that TEXT
6420 may represent an unqualified symbol name. We therefore must
6421 also compare TEXT against the unqualified name of the symbol. */
6422 sym_name = ada_unqualified_name (ada_decode (sym_name));
6424 if (strncmp (sym_name, text, text_len) == 0)
6428 /* Finally: If we found a match, prepare the result to return. */
6433 if (comp_match_res != NULL)
6435 std::string &match_str = comp_match_res->match.storage ();
6438 match_str = ada_decode (sym_name);
6442 match_str = add_angle_brackets (sym_name);
6444 match_str = sym_name;
6448 comp_match_res->set_match (match_str.c_str ());
6454 /* Add the list of possible symbol names completing TEXT to TRACKER.
6455 WORD is the entire command on which completion is made. */
6458 ada_collect_symbol_completion_matches (completion_tracker &tracker,
6459 complete_symbol_mode mode,
6460 symbol_name_match_type name_match_type,
6461 const char *text, const char *word,
6462 enum type_code code)
6465 struct compunit_symtab *s;
6466 struct minimal_symbol *msymbol;
6467 struct objfile *objfile;
6468 const struct block *b, *surrounding_static_block = 0;
6469 struct block_iterator iter;
6470 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
6472 gdb_assert (code == TYPE_CODE_UNDEF);
6474 lookup_name_info lookup_name (text, name_match_type, true);
6476 /* First, look at the partial symtab symbols. */
6477 expand_symtabs_matching (NULL,
6483 /* At this point scan through the misc symbol vectors and add each
6484 symbol you find to the list. Eventually we want to ignore
6485 anything that isn't a text symbol (everything else will be
6486 handled by the psymtab code above). */
6488 ALL_MSYMBOLS (objfile, msymbol)
6492 if (completion_skip_symbol (mode, msymbol))
6495 language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6497 /* Ada minimal symbols won't have their language set to Ada. If
6498 we let completion_list_add_name compare using the
6499 default/C-like matcher, then when completing e.g., symbols in a
6500 package named "pck", we'd match internal Ada symbols like
6501 "pckS", which are invalid in an Ada expression, unless you wrap
6502 them in '<' '>' to request a verbatim match.
6504 Unfortunately, some Ada encoded names successfully demangle as
6505 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6506 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6507 with the wrong language set. Paper over that issue here. */
6508 if (symbol_language == language_auto
6509 || symbol_language == language_cplus)
6510 symbol_language = language_ada;
6512 completion_list_add_name (tracker,
6514 MSYMBOL_LINKAGE_NAME (msymbol),
6515 lookup_name, text, word);
6518 /* Search upwards from currently selected frame (so that we can
6519 complete on local vars. */
6521 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6523 if (!BLOCK_SUPERBLOCK (b))
6524 surrounding_static_block = b; /* For elmin of dups */
6526 ALL_BLOCK_SYMBOLS (b, iter, sym)
6528 if (completion_skip_symbol (mode, sym))
6531 completion_list_add_name (tracker,
6532 SYMBOL_LANGUAGE (sym),
6533 SYMBOL_LINKAGE_NAME (sym),
6534 lookup_name, text, word);
6538 /* Go through the symtabs and check the externs and statics for
6539 symbols which match. */
6541 ALL_COMPUNITS (objfile, s)
6544 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
6545 ALL_BLOCK_SYMBOLS (b, iter, sym)
6547 if (completion_skip_symbol (mode, sym))
6550 completion_list_add_name (tracker,
6551 SYMBOL_LANGUAGE (sym),
6552 SYMBOL_LINKAGE_NAME (sym),
6553 lookup_name, text, word);
6557 ALL_COMPUNITS (objfile, s)
6560 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
6561 /* Don't do this block twice. */
6562 if (b == surrounding_static_block)
6564 ALL_BLOCK_SYMBOLS (b, iter, sym)
6566 if (completion_skip_symbol (mode, sym))
6569 completion_list_add_name (tracker,
6570 SYMBOL_LANGUAGE (sym),
6571 SYMBOL_LINKAGE_NAME (sym),
6572 lookup_name, text, word);
6576 do_cleanups (old_chain);
6581 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6582 for tagged types. */
6585 ada_is_dispatch_table_ptr_type (struct type *type)
6589 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6592 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6596 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6599 /* Return non-zero if TYPE is an interface tag. */
6602 ada_is_interface_tag (struct type *type)
6604 const char *name = TYPE_NAME (type);
6609 return (strcmp (name, "ada__tags__interface_tag") == 0);
6612 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6613 to be invisible to users. */
6616 ada_is_ignored_field (struct type *type, int field_num)
6618 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6621 /* Check the name of that field. */
6623 const char *name = TYPE_FIELD_NAME (type, field_num);
6625 /* Anonymous field names should not be printed.
6626 brobecker/2007-02-20: I don't think this can actually happen
6627 but we don't want to print the value of annonymous fields anyway. */
6631 /* Normally, fields whose name start with an underscore ("_")
6632 are fields that have been internally generated by the compiler,
6633 and thus should not be printed. The "_parent" field is special,
6634 however: This is a field internally generated by the compiler
6635 for tagged types, and it contains the components inherited from
6636 the parent type. This field should not be printed as is, but
6637 should not be ignored either. */
6638 if (name[0] == '_' && !startswith (name, "_parent"))
6642 /* If this is the dispatch table of a tagged type or an interface tag,
6644 if (ada_is_tagged_type (type, 1)
6645 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6646 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
6649 /* Not a special field, so it should not be ignored. */
6653 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6654 pointer or reference type whose ultimate target has a tag field. */
6657 ada_is_tagged_type (struct type *type, int refok)
6659 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6662 /* True iff TYPE represents the type of X'Tag */
6665 ada_is_tag_type (struct type *type)
6667 type = ada_check_typedef (type);
6669 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6673 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6675 return (name != NULL
6676 && strcmp (name, "ada__tags__dispatch_table") == 0);
6680 /* The type of the tag on VAL. */
6683 ada_tag_type (struct value *val)
6685 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6688 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6689 retired at Ada 05). */
6692 is_ada95_tag (struct value *tag)
6694 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6697 /* The value of the tag on VAL. */
6700 ada_value_tag (struct value *val)
6702 return ada_value_struct_elt (val, "_tag", 0);
6705 /* The value of the tag on the object of type TYPE whose contents are
6706 saved at VALADDR, if it is non-null, or is at memory address
6709 static struct value *
6710 value_tag_from_contents_and_address (struct type *type,
6711 const gdb_byte *valaddr,
6714 int tag_byte_offset;
6715 struct type *tag_type;
6717 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6720 const gdb_byte *valaddr1 = ((valaddr == NULL)
6722 : valaddr + tag_byte_offset);
6723 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6725 return value_from_contents_and_address (tag_type, valaddr1, address1);
6730 static struct type *
6731 type_from_tag (struct value *tag)
6733 const char *type_name = ada_tag_name (tag);
6735 if (type_name != NULL)
6736 return ada_find_any_type (ada_encode (type_name));
6740 /* Given a value OBJ of a tagged type, return a value of this
6741 type at the base address of the object. The base address, as
6742 defined in Ada.Tags, it is the address of the primary tag of
6743 the object, and therefore where the field values of its full
6744 view can be fetched. */
6747 ada_tag_value_at_base_address (struct value *obj)
6750 LONGEST offset_to_top = 0;
6751 struct type *ptr_type, *obj_type;
6753 CORE_ADDR base_address;
6755 obj_type = value_type (obj);
6757 /* It is the responsability of the caller to deref pointers. */
6759 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6760 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6763 tag = ada_value_tag (obj);
6767 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6769 if (is_ada95_tag (tag))
6772 ptr_type = language_lookup_primitive_type
6773 (language_def (language_ada), target_gdbarch(), "storage_offset");
6774 ptr_type = lookup_pointer_type (ptr_type);
6775 val = value_cast (ptr_type, tag);
6779 /* It is perfectly possible that an exception be raised while
6780 trying to determine the base address, just like for the tag;
6781 see ada_tag_name for more details. We do not print the error
6782 message for the same reason. */
6786 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6789 CATCH (e, RETURN_MASK_ERROR)
6795 /* If offset is null, nothing to do. */
6797 if (offset_to_top == 0)
6800 /* -1 is a special case in Ada.Tags; however, what should be done
6801 is not quite clear from the documentation. So do nothing for
6804 if (offset_to_top == -1)
6807 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6808 from the base address. This was however incompatible with
6809 C++ dispatch table: C++ uses a *negative* value to *add*
6810 to the base address. Ada's convention has therefore been
6811 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6812 use the same convention. Here, we support both cases by
6813 checking the sign of OFFSET_TO_TOP. */
6815 if (offset_to_top > 0)
6816 offset_to_top = -offset_to_top;
6818 base_address = value_address (obj) + offset_to_top;
6819 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6821 /* Make sure that we have a proper tag at the new address.
6822 Otherwise, offset_to_top is bogus (which can happen when
6823 the object is not initialized yet). */
6828 obj_type = type_from_tag (tag);
6833 return value_from_contents_and_address (obj_type, NULL, base_address);
6836 /* Return the "ada__tags__type_specific_data" type. */
6838 static struct type *
6839 ada_get_tsd_type (struct inferior *inf)
6841 struct ada_inferior_data *data = get_ada_inferior_data (inf);
6843 if (data->tsd_type == 0)
6844 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6845 return data->tsd_type;
6848 /* Return the TSD (type-specific data) associated to the given TAG.
6849 TAG is assumed to be the tag of a tagged-type entity.
6851 May return NULL if we are unable to get the TSD. */
6853 static struct value *
6854 ada_get_tsd_from_tag (struct value *tag)
6859 /* First option: The TSD is simply stored as a field of our TAG.
6860 Only older versions of GNAT would use this format, but we have
6861 to test it first, because there are no visible markers for
6862 the current approach except the absence of that field. */
6864 val = ada_value_struct_elt (tag, "tsd", 1);
6868 /* Try the second representation for the dispatch table (in which
6869 there is no explicit 'tsd' field in the referent of the tag pointer,
6870 and instead the tsd pointer is stored just before the dispatch
6873 type = ada_get_tsd_type (current_inferior());
6876 type = lookup_pointer_type (lookup_pointer_type (type));
6877 val = value_cast (type, tag);
6880 return value_ind (value_ptradd (val, -1));
6883 /* Given the TSD of a tag (type-specific data), return a string
6884 containing the name of the associated type.
6886 The returned value is good until the next call. May return NULL
6887 if we are unable to determine the tag name. */
6890 ada_tag_name_from_tsd (struct value *tsd)
6892 static char name[1024];
6896 val = ada_value_struct_elt (tsd, "expanded_name", 1);
6899 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6900 for (p = name; *p != '\0'; p += 1)
6906 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6909 Return NULL if the TAG is not an Ada tag, or if we were unable to
6910 determine the name of that tag. The result is good until the next
6914 ada_tag_name (struct value *tag)
6918 if (!ada_is_tag_type (value_type (tag)))
6921 /* It is perfectly possible that an exception be raised while trying
6922 to determine the TAG's name, even under normal circumstances:
6923 The associated variable may be uninitialized or corrupted, for
6924 instance. We do not let any exception propagate past this point.
6925 instead we return NULL.
6927 We also do not print the error message either (which often is very
6928 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6929 the caller print a more meaningful message if necessary. */
6932 struct value *tsd = ada_get_tsd_from_tag (tag);
6935 name = ada_tag_name_from_tsd (tsd);
6937 CATCH (e, RETURN_MASK_ERROR)
6945 /* The parent type of TYPE, or NULL if none. */
6948 ada_parent_type (struct type *type)
6952 type = ada_check_typedef (type);
6954 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6957 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6958 if (ada_is_parent_field (type, i))
6960 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6962 /* If the _parent field is a pointer, then dereference it. */
6963 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6964 parent_type = TYPE_TARGET_TYPE (parent_type);
6965 /* If there is a parallel XVS type, get the actual base type. */
6966 parent_type = ada_get_base_type (parent_type);
6968 return ada_check_typedef (parent_type);
6974 /* True iff field number FIELD_NUM of structure type TYPE contains the
6975 parent-type (inherited) fields of a derived type. Assumes TYPE is
6976 a structure type with at least FIELD_NUM+1 fields. */
6979 ada_is_parent_field (struct type *type, int field_num)
6981 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6983 return (name != NULL
6984 && (startswith (name, "PARENT")
6985 || startswith (name, "_parent")));
6988 /* True iff field number FIELD_NUM of structure type TYPE is a
6989 transparent wrapper field (which should be silently traversed when doing
6990 field selection and flattened when printing). Assumes TYPE is a
6991 structure type with at least FIELD_NUM+1 fields. Such fields are always
6995 ada_is_wrapper_field (struct type *type, int field_num)
6997 const char *name = TYPE_FIELD_NAME (type, field_num);
6999 if (name != NULL && strcmp (name, "RETVAL") == 0)
7001 /* This happens in functions with "out" or "in out" parameters
7002 which are passed by copy. For such functions, GNAT describes
7003 the function's return type as being a struct where the return
7004 value is in a field called RETVAL, and where the other "out"
7005 or "in out" parameters are fields of that struct. This is not
7010 return (name != NULL
7011 && (startswith (name, "PARENT")
7012 || strcmp (name, "REP") == 0
7013 || startswith (name, "_parent")
7014 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
7017 /* True iff field number FIELD_NUM of structure or union type TYPE
7018 is a variant wrapper. Assumes TYPE is a structure type with at least
7019 FIELD_NUM+1 fields. */
7022 ada_is_variant_part (struct type *type, int field_num)
7024 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
7026 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
7027 || (is_dynamic_field (type, field_num)
7028 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
7029 == TYPE_CODE_UNION)));
7032 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
7033 whose discriminants are contained in the record type OUTER_TYPE,
7034 returns the type of the controlling discriminant for the variant.
7035 May return NULL if the type could not be found. */
7038 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
7040 const char *name = ada_variant_discrim_name (var_type);
7042 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
7045 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
7046 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
7047 represents a 'when others' clause; otherwise 0. */
7050 ada_is_others_clause (struct type *type, int field_num)
7052 const char *name = TYPE_FIELD_NAME (type, field_num);
7054 return (name != NULL && name[0] == 'O');
7057 /* Assuming that TYPE0 is the type of the variant part of a record,
7058 returns the name of the discriminant controlling the variant.
7059 The value is valid until the next call to ada_variant_discrim_name. */
7062 ada_variant_discrim_name (struct type *type0)
7064 static char *result = NULL;
7065 static size_t result_len = 0;
7068 const char *discrim_end;
7069 const char *discrim_start;
7071 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7072 type = TYPE_TARGET_TYPE (type0);
7076 name = ada_type_name (type);
7078 if (name == NULL || name[0] == '\000')
7081 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7084 if (startswith (discrim_end, "___XVN"))
7087 if (discrim_end == name)
7090 for (discrim_start = discrim_end; discrim_start != name + 3;
7093 if (discrim_start == name + 1)
7095 if ((discrim_start > name + 3
7096 && startswith (discrim_start - 3, "___"))
7097 || discrim_start[-1] == '.')
7101 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7102 strncpy (result, discrim_start, discrim_end - discrim_start);
7103 result[discrim_end - discrim_start] = '\0';
7107 /* Scan STR for a subtype-encoded number, beginning at position K.
7108 Put the position of the character just past the number scanned in
7109 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7110 Return 1 if there was a valid number at the given position, and 0
7111 otherwise. A "subtype-encoded" number consists of the absolute value
7112 in decimal, followed by the letter 'm' to indicate a negative number.
7113 Assumes 0m does not occur. */
7116 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
7120 if (!isdigit (str[k]))
7123 /* Do it the hard way so as not to make any assumption about
7124 the relationship of unsigned long (%lu scan format code) and
7127 while (isdigit (str[k]))
7129 RU = RU * 10 + (str[k] - '0');
7136 *R = (-(LONGEST) (RU - 1)) - 1;
7142 /* NOTE on the above: Technically, C does not say what the results of
7143 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7144 number representable as a LONGEST (although either would probably work
7145 in most implementations). When RU>0, the locution in the then branch
7146 above is always equivalent to the negative of RU. */
7153 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7154 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7155 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
7158 ada_in_variant (LONGEST val, struct type *type, int field_num)
7160 const char *name = TYPE_FIELD_NAME (type, field_num);
7174 if (!ada_scan_number (name, p + 1, &W, &p))
7184 if (!ada_scan_number (name, p + 1, &L, &p)
7185 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7187 if (val >= L && val <= U)
7199 /* FIXME: Lots of redundancy below. Try to consolidate. */
7201 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7202 ARG_TYPE, extract and return the value of one of its (non-static)
7203 fields. FIELDNO says which field. Differs from value_primitive_field
7204 only in that it can handle packed values of arbitrary type. */
7206 static struct value *
7207 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
7208 struct type *arg_type)
7212 arg_type = ada_check_typedef (arg_type);
7213 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7215 /* Handle packed fields. */
7217 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7219 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7220 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
7222 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
7223 offset + bit_pos / 8,
7224 bit_pos % 8, bit_size, type);
7227 return value_primitive_field (arg1, offset, fieldno, arg_type);
7230 /* Find field with name NAME in object of type TYPE. If found,
7231 set the following for each argument that is non-null:
7232 - *FIELD_TYPE_P to the field's type;
7233 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7234 an object of that type;
7235 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7236 - *BIT_SIZE_P to its size in bits if the field is packed, and
7238 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7239 fields up to but not including the desired field, or by the total
7240 number of fields if not found. A NULL value of NAME never
7241 matches; the function just counts visible fields in this case.
7243 Notice that we need to handle when a tagged record hierarchy
7244 has some components with the same name, like in this scenario:
7246 type Top_T is tagged record
7252 type Middle_T is new Top.Top_T with record
7253 N : Character := 'a';
7257 type Bottom_T is new Middle.Middle_T with record
7259 C : Character := '5';
7261 A : Character := 'J';
7264 Let's say we now have a variable declared and initialized as follow:
7266 TC : Top_A := new Bottom_T;
7268 And then we use this variable to call this function
7270 procedure Assign (Obj: in out Top_T; TV : Integer);
7274 Assign (Top_T (B), 12);
7276 Now, we're in the debugger, and we're inside that procedure
7277 then and we want to print the value of obj.c:
7279 Usually, the tagged record or one of the parent type owns the
7280 component to print and there's no issue but in this particular
7281 case, what does it mean to ask for Obj.C? Since the actual
7282 type for object is type Bottom_T, it could mean two things: type
7283 component C from the Middle_T view, but also component C from
7284 Bottom_T. So in that "undefined" case, when the component is
7285 not found in the non-resolved type (which includes all the
7286 components of the parent type), then resolve it and see if we
7287 get better luck once expanded.
7289 In the case of homonyms in the derived tagged type, we don't
7290 guaranty anything, and pick the one that's easiest for us
7293 Returns 1 if found, 0 otherwise. */
7296 find_struct_field (const char *name, struct type *type, int offset,
7297 struct type **field_type_p,
7298 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7302 int parent_offset = -1;
7304 type = ada_check_typedef (type);
7306 if (field_type_p != NULL)
7307 *field_type_p = NULL;
7308 if (byte_offset_p != NULL)
7310 if (bit_offset_p != NULL)
7312 if (bit_size_p != NULL)
7315 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7317 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7318 int fld_offset = offset + bit_pos / 8;
7319 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7321 if (t_field_name == NULL)
7324 else if (ada_is_parent_field (type, i))
7326 /* This is a field pointing us to the parent type of a tagged
7327 type. As hinted in this function's documentation, we give
7328 preference to fields in the current record first, so what
7329 we do here is just record the index of this field before
7330 we skip it. If it turns out we couldn't find our field
7331 in the current record, then we'll get back to it and search
7332 inside it whether the field might exist in the parent. */
7338 else if (name != NULL && field_name_match (t_field_name, name))
7340 int bit_size = TYPE_FIELD_BITSIZE (type, i);
7342 if (field_type_p != NULL)
7343 *field_type_p = TYPE_FIELD_TYPE (type, i);
7344 if (byte_offset_p != NULL)
7345 *byte_offset_p = fld_offset;
7346 if (bit_offset_p != NULL)
7347 *bit_offset_p = bit_pos % 8;
7348 if (bit_size_p != NULL)
7349 *bit_size_p = bit_size;
7352 else if (ada_is_wrapper_field (type, i))
7354 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7355 field_type_p, byte_offset_p, bit_offset_p,
7356 bit_size_p, index_p))
7359 else if (ada_is_variant_part (type, i))
7361 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7364 struct type *field_type
7365 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
7367 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7369 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7371 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7372 field_type_p, byte_offset_p,
7373 bit_offset_p, bit_size_p, index_p))
7377 else if (index_p != NULL)
7381 /* Field not found so far. If this is a tagged type which
7382 has a parent, try finding that field in the parent now. */
7384 if (parent_offset != -1)
7386 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7387 int fld_offset = offset + bit_pos / 8;
7389 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7390 fld_offset, field_type_p, byte_offset_p,
7391 bit_offset_p, bit_size_p, index_p))
7398 /* Number of user-visible fields in record type TYPE. */
7401 num_visible_fields (struct type *type)
7406 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7410 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7411 and search in it assuming it has (class) type TYPE.
7412 If found, return value, else return NULL.
7414 Searches recursively through wrapper fields (e.g., '_parent').
7416 In the case of homonyms in the tagged types, please refer to the
7417 long explanation in find_struct_field's function documentation. */
7419 static struct value *
7420 ada_search_struct_field (const char *name, struct value *arg, int offset,
7424 int parent_offset = -1;
7426 type = ada_check_typedef (type);
7427 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7429 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7431 if (t_field_name == NULL)
7434 else if (ada_is_parent_field (type, i))
7436 /* This is a field pointing us to the parent type of a tagged
7437 type. As hinted in this function's documentation, we give
7438 preference to fields in the current record first, so what
7439 we do here is just record the index of this field before
7440 we skip it. If it turns out we couldn't find our field
7441 in the current record, then we'll get back to it and search
7442 inside it whether the field might exist in the parent. */
7448 else if (field_name_match (t_field_name, name))
7449 return ada_value_primitive_field (arg, offset, i, type);
7451 else if (ada_is_wrapper_field (type, i))
7453 struct value *v = /* Do not let indent join lines here. */
7454 ada_search_struct_field (name, arg,
7455 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7456 TYPE_FIELD_TYPE (type, i));
7462 else if (ada_is_variant_part (type, i))
7464 /* PNH: Do we ever get here? See find_struct_field. */
7466 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7468 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7470 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7472 struct value *v = ada_search_struct_field /* Force line
7475 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7476 TYPE_FIELD_TYPE (field_type, j));
7484 /* Field not found so far. If this is a tagged type which
7485 has a parent, try finding that field in the parent now. */
7487 if (parent_offset != -1)
7489 struct value *v = ada_search_struct_field (
7490 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7491 TYPE_FIELD_TYPE (type, parent_offset));
7500 static struct value *ada_index_struct_field_1 (int *, struct value *,
7501 int, struct type *);
7504 /* Return field #INDEX in ARG, where the index is that returned by
7505 * find_struct_field through its INDEX_P argument. Adjust the address
7506 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7507 * If found, return value, else return NULL. */
7509 static struct value *
7510 ada_index_struct_field (int index, struct value *arg, int offset,
7513 return ada_index_struct_field_1 (&index, arg, offset, type);
7517 /* Auxiliary function for ada_index_struct_field. Like
7518 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7521 static struct value *
7522 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7526 type = ada_check_typedef (type);
7528 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7530 if (TYPE_FIELD_NAME (type, i) == NULL)
7532 else if (ada_is_wrapper_field (type, i))
7534 struct value *v = /* Do not let indent join lines here. */
7535 ada_index_struct_field_1 (index_p, arg,
7536 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7537 TYPE_FIELD_TYPE (type, i));
7543 else if (ada_is_variant_part (type, i))
7545 /* PNH: Do we ever get here? See ada_search_struct_field,
7546 find_struct_field. */
7547 error (_("Cannot assign this kind of variant record"));
7549 else if (*index_p == 0)
7550 return ada_value_primitive_field (arg, offset, i, type);
7557 /* Given ARG, a value of type (pointer or reference to a)*
7558 structure/union, extract the component named NAME from the ultimate
7559 target structure/union and return it as a value with its
7562 The routine searches for NAME among all members of the structure itself
7563 and (recursively) among all members of any wrapper members
7566 If NO_ERR, then simply return NULL in case of error, rather than
7570 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
7572 struct type *t, *t1;
7576 t1 = t = ada_check_typedef (value_type (arg));
7577 if (TYPE_CODE (t) == TYPE_CODE_REF)
7579 t1 = TYPE_TARGET_TYPE (t);
7582 t1 = ada_check_typedef (t1);
7583 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7585 arg = coerce_ref (arg);
7590 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7592 t1 = TYPE_TARGET_TYPE (t);
7595 t1 = ada_check_typedef (t1);
7596 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7598 arg = value_ind (arg);
7605 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
7609 v = ada_search_struct_field (name, arg, 0, t);
7612 int bit_offset, bit_size, byte_offset;
7613 struct type *field_type;
7616 if (TYPE_CODE (t) == TYPE_CODE_PTR)
7617 address = value_address (ada_value_ind (arg));
7619 address = value_address (ada_coerce_ref (arg));
7621 /* Check to see if this is a tagged type. We also need to handle
7622 the case where the type is a reference to a tagged type, but
7623 we have to be careful to exclude pointers to tagged types.
7624 The latter should be shown as usual (as a pointer), whereas
7625 a reference should mostly be transparent to the user. */
7627 if (ada_is_tagged_type (t1, 0)
7628 || (TYPE_CODE (t1) == TYPE_CODE_REF
7629 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7631 /* We first try to find the searched field in the current type.
7632 If not found then let's look in the fixed type. */
7634 if (!find_struct_field (name, t1, 0,
7635 &field_type, &byte_offset, &bit_offset,
7637 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7641 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7644 if (find_struct_field (name, t1, 0,
7645 &field_type, &byte_offset, &bit_offset,
7650 if (TYPE_CODE (t) == TYPE_CODE_REF)
7651 arg = ada_coerce_ref (arg);
7653 arg = ada_value_ind (arg);
7654 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7655 bit_offset, bit_size,
7659 v = value_at_lazy (field_type, address + byte_offset);
7663 if (v != NULL || no_err)
7666 error (_("There is no member named %s."), name);
7672 error (_("Attempt to extract a component of "
7673 "a value that is not a record."));
7676 /* Return a string representation of type TYPE. */
7679 type_as_string (struct type *type)
7681 string_file tmp_stream;
7683 type_print (type, "", &tmp_stream, -1);
7685 return std::move (tmp_stream.string ());
7688 /* Given a type TYPE, look up the type of the component of type named NAME.
7689 If DISPP is non-null, add its byte displacement from the beginning of a
7690 structure (pointed to by a value) of type TYPE to *DISPP (does not
7691 work for packed fields).
7693 Matches any field whose name has NAME as a prefix, possibly
7696 TYPE can be either a struct or union. If REFOK, TYPE may also
7697 be a (pointer or reference)+ to a struct or union, and the
7698 ultimate target type will be searched.
7700 Looks recursively into variant clauses and parent types.
7702 In the case of homonyms in the tagged types, please refer to the
7703 long explanation in find_struct_field's function documentation.
7705 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7706 TYPE is not a type of the right kind. */
7708 static struct type *
7709 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7713 int parent_offset = -1;
7718 if (refok && type != NULL)
7721 type = ada_check_typedef (type);
7722 if (TYPE_CODE (type) != TYPE_CODE_PTR
7723 && TYPE_CODE (type) != TYPE_CODE_REF)
7725 type = TYPE_TARGET_TYPE (type);
7729 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7730 && TYPE_CODE (type) != TYPE_CODE_UNION))
7735 error (_("Type %s is not a structure or union type"),
7736 type != NULL ? type_as_string (type).c_str () : _("(null)"));
7739 type = to_static_fixed_type (type);
7741 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7743 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7746 if (t_field_name == NULL)
7749 else if (ada_is_parent_field (type, i))
7751 /* This is a field pointing us to the parent type of a tagged
7752 type. As hinted in this function's documentation, we give
7753 preference to fields in the current record first, so what
7754 we do here is just record the index of this field before
7755 we skip it. If it turns out we couldn't find our field
7756 in the current record, then we'll get back to it and search
7757 inside it whether the field might exist in the parent. */
7763 else if (field_name_match (t_field_name, name))
7764 return TYPE_FIELD_TYPE (type, i);
7766 else if (ada_is_wrapper_field (type, i))
7768 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7774 else if (ada_is_variant_part (type, i))
7777 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7780 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7782 /* FIXME pnh 2008/01/26: We check for a field that is
7783 NOT wrapped in a struct, since the compiler sometimes
7784 generates these for unchecked variant types. Revisit
7785 if the compiler changes this practice. */
7786 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
7788 if (v_field_name != NULL
7789 && field_name_match (v_field_name, name))
7790 t = TYPE_FIELD_TYPE (field_type, j);
7792 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7803 /* Field not found so far. If this is a tagged type which
7804 has a parent, try finding that field in the parent now. */
7806 if (parent_offset != -1)
7810 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7819 const char *name_str = name != NULL ? name : _("<null>");
7821 error (_("Type %s has no component named %s"),
7822 type_as_string (type).c_str (), name_str);
7828 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7829 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7830 represents an unchecked union (that is, the variant part of a
7831 record that is named in an Unchecked_Union pragma). */
7834 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7836 const char *discrim_name = ada_variant_discrim_name (var_type);
7838 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7842 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7843 within a value of type OUTER_TYPE that is stored in GDB at
7844 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7845 numbering from 0) is applicable. Returns -1 if none are. */
7848 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
7849 const gdb_byte *outer_valaddr)
7853 const char *discrim_name = ada_variant_discrim_name (var_type);
7854 struct value *outer;
7855 struct value *discrim;
7856 LONGEST discrim_val;
7858 /* Using plain value_from_contents_and_address here causes problems
7859 because we will end up trying to resolve a type that is currently
7860 being constructed. */
7861 outer = value_from_contents_and_address_unresolved (outer_type,
7863 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7864 if (discrim == NULL)
7866 discrim_val = value_as_long (discrim);
7869 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7871 if (ada_is_others_clause (var_type, i))
7873 else if (ada_in_variant (discrim_val, var_type, i))
7877 return others_clause;
7882 /* Dynamic-Sized Records */
7884 /* Strategy: The type ostensibly attached to a value with dynamic size
7885 (i.e., a size that is not statically recorded in the debugging
7886 data) does not accurately reflect the size or layout of the value.
7887 Our strategy is to convert these values to values with accurate,
7888 conventional types that are constructed on the fly. */
7890 /* There is a subtle and tricky problem here. In general, we cannot
7891 determine the size of dynamic records without its data. However,
7892 the 'struct value' data structure, which GDB uses to represent
7893 quantities in the inferior process (the target), requires the size
7894 of the type at the time of its allocation in order to reserve space
7895 for GDB's internal copy of the data. That's why the
7896 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7897 rather than struct value*s.
7899 However, GDB's internal history variables ($1, $2, etc.) are
7900 struct value*s containing internal copies of the data that are not, in
7901 general, the same as the data at their corresponding addresses in
7902 the target. Fortunately, the types we give to these values are all
7903 conventional, fixed-size types (as per the strategy described
7904 above), so that we don't usually have to perform the
7905 'to_fixed_xxx_type' conversions to look at their values.
7906 Unfortunately, there is one exception: if one of the internal
7907 history variables is an array whose elements are unconstrained
7908 records, then we will need to create distinct fixed types for each
7909 element selected. */
7911 /* The upshot of all of this is that many routines take a (type, host
7912 address, target address) triple as arguments to represent a value.
7913 The host address, if non-null, is supposed to contain an internal
7914 copy of the relevant data; otherwise, the program is to consult the
7915 target at the target address. */
7917 /* Assuming that VAL0 represents a pointer value, the result of
7918 dereferencing it. Differs from value_ind in its treatment of
7919 dynamic-sized types. */
7922 ada_value_ind (struct value *val0)
7924 struct value *val = value_ind (val0);
7926 if (ada_is_tagged_type (value_type (val), 0))
7927 val = ada_tag_value_at_base_address (val);
7929 return ada_to_fixed_value (val);
7932 /* The value resulting from dereferencing any "reference to"
7933 qualifiers on VAL0. */
7935 static struct value *
7936 ada_coerce_ref (struct value *val0)
7938 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
7940 struct value *val = val0;
7942 val = coerce_ref (val);
7944 if (ada_is_tagged_type (value_type (val), 0))
7945 val = ada_tag_value_at_base_address (val);
7947 return ada_to_fixed_value (val);
7953 /* Return OFF rounded upward if necessary to a multiple of
7954 ALIGNMENT (a power of 2). */
7957 align_value (unsigned int off, unsigned int alignment)
7959 return (off + alignment - 1) & ~(alignment - 1);
7962 /* Return the bit alignment required for field #F of template type TYPE. */
7965 field_alignment (struct type *type, int f)
7967 const char *name = TYPE_FIELD_NAME (type, f);
7971 /* The field name should never be null, unless the debugging information
7972 is somehow malformed. In this case, we assume the field does not
7973 require any alignment. */
7977 len = strlen (name);
7979 if (!isdigit (name[len - 1]))
7982 if (isdigit (name[len - 2]))
7983 align_offset = len - 2;
7985 align_offset = len - 1;
7987 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7988 return TARGET_CHAR_BIT;
7990 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7993 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7995 static struct symbol *
7996 ada_find_any_type_symbol (const char *name)
8000 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
8001 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
8004 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
8008 /* Find a type named NAME. Ignores ambiguity. This routine will look
8009 solely for types defined by debug info, it will not search the GDB
8012 static struct type *
8013 ada_find_any_type (const char *name)
8015 struct symbol *sym = ada_find_any_type_symbol (name);
8018 return SYMBOL_TYPE (sym);
8023 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
8024 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
8025 symbol, in which case it is returned. Otherwise, this looks for
8026 symbols whose name is that of NAME_SYM suffixed with "___XR".
8027 Return symbol if found, and NULL otherwise. */
8030 ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
8032 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
8035 if (strstr (name, "___XR") != NULL)
8038 sym = find_old_style_renaming_symbol (name, block);
8043 /* Not right yet. FIXME pnh 7/20/2007. */
8044 sym = ada_find_any_type_symbol (name);
8045 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
8051 static struct symbol *
8052 find_old_style_renaming_symbol (const char *name, const struct block *block)
8054 const struct symbol *function_sym = block_linkage_function (block);
8057 if (function_sym != NULL)
8059 /* If the symbol is defined inside a function, NAME is not fully
8060 qualified. This means we need to prepend the function name
8061 as well as adding the ``___XR'' suffix to build the name of
8062 the associated renaming symbol. */
8063 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
8064 /* Function names sometimes contain suffixes used
8065 for instance to qualify nested subprograms. When building
8066 the XR type name, we need to make sure that this suffix is
8067 not included. So do not include any suffix in the function
8068 name length below. */
8069 int function_name_len = ada_name_prefix_len (function_name);
8070 const int rename_len = function_name_len + 2 /* "__" */
8071 + strlen (name) + 6 /* "___XR\0" */ ;
8073 /* Strip the suffix if necessary. */
8074 ada_remove_trailing_digits (function_name, &function_name_len);
8075 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
8076 ada_remove_Xbn_suffix (function_name, &function_name_len);
8078 /* Library-level functions are a special case, as GNAT adds
8079 a ``_ada_'' prefix to the function name to avoid namespace
8080 pollution. However, the renaming symbols themselves do not
8081 have this prefix, so we need to skip this prefix if present. */
8082 if (function_name_len > 5 /* "_ada_" */
8083 && strstr (function_name, "_ada_") == function_name)
8086 function_name_len -= 5;
8089 rename = (char *) alloca (rename_len * sizeof (char));
8090 strncpy (rename, function_name, function_name_len);
8091 xsnprintf (rename + function_name_len, rename_len - function_name_len,
8096 const int rename_len = strlen (name) + 6;
8098 rename = (char *) alloca (rename_len * sizeof (char));
8099 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
8102 return ada_find_any_type_symbol (rename);
8105 /* Because of GNAT encoding conventions, several GDB symbols may match a
8106 given type name. If the type denoted by TYPE0 is to be preferred to
8107 that of TYPE1 for purposes of type printing, return non-zero;
8108 otherwise return 0. */
8111 ada_prefer_type (struct type *type0, struct type *type1)
8115 else if (type0 == NULL)
8117 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
8119 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
8121 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
8123 else if (ada_is_constrained_packed_array_type (type0))
8125 else if (ada_is_array_descriptor_type (type0)
8126 && !ada_is_array_descriptor_type (type1))
8130 const char *type0_name = type_name_no_tag (type0);
8131 const char *type1_name = type_name_no_tag (type1);
8133 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
8134 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
8140 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
8141 null, its TYPE_TAG_NAME. Null if TYPE is null. */
8144 ada_type_name (struct type *type)
8148 else if (TYPE_NAME (type) != NULL)
8149 return TYPE_NAME (type);
8151 return TYPE_TAG_NAME (type);
8154 /* Search the list of "descriptive" types associated to TYPE for a type
8155 whose name is NAME. */
8157 static struct type *
8158 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
8160 struct type *result, *tmp;
8162 if (ada_ignore_descriptive_types_p)
8165 /* If there no descriptive-type info, then there is no parallel type
8167 if (!HAVE_GNAT_AUX_INFO (type))
8170 result = TYPE_DESCRIPTIVE_TYPE (type);
8171 while (result != NULL)
8173 const char *result_name = ada_type_name (result);
8175 if (result_name == NULL)
8177 warning (_("unexpected null name on descriptive type"));
8181 /* If the names match, stop. */
8182 if (strcmp (result_name, name) == 0)
8185 /* Otherwise, look at the next item on the list, if any. */
8186 if (HAVE_GNAT_AUX_INFO (result))
8187 tmp = TYPE_DESCRIPTIVE_TYPE (result);
8191 /* If not found either, try after having resolved the typedef. */
8196 result = check_typedef (result);
8197 if (HAVE_GNAT_AUX_INFO (result))
8198 result = TYPE_DESCRIPTIVE_TYPE (result);
8204 /* If we didn't find a match, see whether this is a packed array. With
8205 older compilers, the descriptive type information is either absent or
8206 irrelevant when it comes to packed arrays so the above lookup fails.
8207 Fall back to using a parallel lookup by name in this case. */
8208 if (result == NULL && ada_is_constrained_packed_array_type (type))
8209 return ada_find_any_type (name);
8214 /* Find a parallel type to TYPE with the specified NAME, using the
8215 descriptive type taken from the debugging information, if available,
8216 and otherwise using the (slower) name-based method. */
8218 static struct type *
8219 ada_find_parallel_type_with_name (struct type *type, const char *name)
8221 struct type *result = NULL;
8223 if (HAVE_GNAT_AUX_INFO (type))
8224 result = find_parallel_type_by_descriptive_type (type, name);
8226 result = ada_find_any_type (name);
8231 /* Same as above, but specify the name of the parallel type by appending
8232 SUFFIX to the name of TYPE. */
8235 ada_find_parallel_type (struct type *type, const char *suffix)
8238 const char *type_name = ada_type_name (type);
8241 if (type_name == NULL)
8244 len = strlen (type_name);
8246 name = (char *) alloca (len + strlen (suffix) + 1);
8248 strcpy (name, type_name);
8249 strcpy (name + len, suffix);
8251 return ada_find_parallel_type_with_name (type, name);
8254 /* If TYPE is a variable-size record type, return the corresponding template
8255 type describing its fields. Otherwise, return NULL. */
8257 static struct type *
8258 dynamic_template_type (struct type *type)
8260 type = ada_check_typedef (type);
8262 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
8263 || ada_type_name (type) == NULL)
8267 int len = strlen (ada_type_name (type));
8269 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8272 return ada_find_parallel_type (type, "___XVE");
8276 /* Assuming that TEMPL_TYPE is a union or struct type, returns
8277 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
8280 is_dynamic_field (struct type *templ_type, int field_num)
8282 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
8285 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8286 && strstr (name, "___XVL") != NULL;
8289 /* The index of the variant field of TYPE, or -1 if TYPE does not
8290 represent a variant record type. */
8293 variant_field_index (struct type *type)
8297 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8300 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8302 if (ada_is_variant_part (type, f))
8308 /* A record type with no fields. */
8310 static struct type *
8311 empty_record (struct type *templ)
8313 struct type *type = alloc_type_copy (templ);
8315 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8316 TYPE_NFIELDS (type) = 0;
8317 TYPE_FIELDS (type) = NULL;
8318 INIT_CPLUS_SPECIFIC (type);
8319 TYPE_NAME (type) = "<empty>";
8320 TYPE_TAG_NAME (type) = NULL;
8321 TYPE_LENGTH (type) = 0;
8325 /* An ordinary record type (with fixed-length fields) that describes
8326 the value of type TYPE at VALADDR or ADDRESS (see comments at
8327 the beginning of this section) VAL according to GNAT conventions.
8328 DVAL0 should describe the (portion of a) record that contains any
8329 necessary discriminants. It should be NULL if value_type (VAL) is
8330 an outer-level type (i.e., as opposed to a branch of a variant.) A
8331 variant field (unless unchecked) is replaced by a particular branch
8334 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8335 length are not statically known are discarded. As a consequence,
8336 VALADDR, ADDRESS and DVAL0 are ignored.
8338 NOTE: Limitations: For now, we assume that dynamic fields and
8339 variants occupy whole numbers of bytes. However, they need not be
8343 ada_template_to_fixed_record_type_1 (struct type *type,
8344 const gdb_byte *valaddr,
8345 CORE_ADDR address, struct value *dval0,
8346 int keep_dynamic_fields)
8348 struct value *mark = value_mark ();
8351 int nfields, bit_len;
8357 /* Compute the number of fields in this record type that are going
8358 to be processed: unless keep_dynamic_fields, this includes only
8359 fields whose position and length are static will be processed. */
8360 if (keep_dynamic_fields)
8361 nfields = TYPE_NFIELDS (type);
8365 while (nfields < TYPE_NFIELDS (type)
8366 && !ada_is_variant_part (type, nfields)
8367 && !is_dynamic_field (type, nfields))
8371 rtype = alloc_type_copy (type);
8372 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8373 INIT_CPLUS_SPECIFIC (rtype);
8374 TYPE_NFIELDS (rtype) = nfields;
8375 TYPE_FIELDS (rtype) = (struct field *)
8376 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8377 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8378 TYPE_NAME (rtype) = ada_type_name (type);
8379 TYPE_TAG_NAME (rtype) = NULL;
8380 TYPE_FIXED_INSTANCE (rtype) = 1;
8386 for (f = 0; f < nfields; f += 1)
8388 off = align_value (off, field_alignment (type, f))
8389 + TYPE_FIELD_BITPOS (type, f);
8390 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
8391 TYPE_FIELD_BITSIZE (rtype, f) = 0;
8393 if (ada_is_variant_part (type, f))
8398 else if (is_dynamic_field (type, f))
8400 const gdb_byte *field_valaddr = valaddr;
8401 CORE_ADDR field_address = address;
8402 struct type *field_type =
8403 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8407 /* rtype's length is computed based on the run-time
8408 value of discriminants. If the discriminants are not
8409 initialized, the type size may be completely bogus and
8410 GDB may fail to allocate a value for it. So check the
8411 size first before creating the value. */
8412 ada_ensure_varsize_limit (rtype);
8413 /* Using plain value_from_contents_and_address here
8414 causes problems because we will end up trying to
8415 resolve a type that is currently being
8417 dval = value_from_contents_and_address_unresolved (rtype,
8420 rtype = value_type (dval);
8425 /* If the type referenced by this field is an aligner type, we need
8426 to unwrap that aligner type, because its size might not be set.
8427 Keeping the aligner type would cause us to compute the wrong
8428 size for this field, impacting the offset of the all the fields
8429 that follow this one. */
8430 if (ada_is_aligner_type (field_type))
8432 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8434 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8435 field_address = cond_offset_target (field_address, field_offset);
8436 field_type = ada_aligned_type (field_type);
8439 field_valaddr = cond_offset_host (field_valaddr,
8440 off / TARGET_CHAR_BIT);
8441 field_address = cond_offset_target (field_address,
8442 off / TARGET_CHAR_BIT);
8444 /* Get the fixed type of the field. Note that, in this case,
8445 we do not want to get the real type out of the tag: if
8446 the current field is the parent part of a tagged record,
8447 we will get the tag of the object. Clearly wrong: the real
8448 type of the parent is not the real type of the child. We
8449 would end up in an infinite loop. */
8450 field_type = ada_get_base_type (field_type);
8451 field_type = ada_to_fixed_type (field_type, field_valaddr,
8452 field_address, dval, 0);
8453 /* If the field size is already larger than the maximum
8454 object size, then the record itself will necessarily
8455 be larger than the maximum object size. We need to make
8456 this check now, because the size might be so ridiculously
8457 large (due to an uninitialized variable in the inferior)
8458 that it would cause an overflow when adding it to the
8460 ada_ensure_varsize_limit (field_type);
8462 TYPE_FIELD_TYPE (rtype, f) = field_type;
8463 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8464 /* The multiplication can potentially overflow. But because
8465 the field length has been size-checked just above, and
8466 assuming that the maximum size is a reasonable value,
8467 an overflow should not happen in practice. So rather than
8468 adding overflow recovery code to this already complex code,
8469 we just assume that it's not going to happen. */
8471 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8475 /* Note: If this field's type is a typedef, it is important
8476 to preserve the typedef layer.
8478 Otherwise, we might be transforming a typedef to a fat
8479 pointer (encoding a pointer to an unconstrained array),
8480 into a basic fat pointer (encoding an unconstrained
8481 array). As both types are implemented using the same
8482 structure, the typedef is the only clue which allows us
8483 to distinguish between the two options. Stripping it
8484 would prevent us from printing this field appropriately. */
8485 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
8486 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8487 if (TYPE_FIELD_BITSIZE (type, f) > 0)
8489 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8492 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8494 /* We need to be careful of typedefs when computing
8495 the length of our field. If this is a typedef,
8496 get the length of the target type, not the length
8498 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8499 field_type = ada_typedef_target_type (field_type);
8502 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8505 if (off + fld_bit_len > bit_len)
8506 bit_len = off + fld_bit_len;
8508 TYPE_LENGTH (rtype) =
8509 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8512 /* We handle the variant part, if any, at the end because of certain
8513 odd cases in which it is re-ordered so as NOT to be the last field of
8514 the record. This can happen in the presence of representation
8516 if (variant_field >= 0)
8518 struct type *branch_type;
8520 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8524 /* Using plain value_from_contents_and_address here causes
8525 problems because we will end up trying to resolve a type
8526 that is currently being constructed. */
8527 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8529 rtype = value_type (dval);
8535 to_fixed_variant_branch_type
8536 (TYPE_FIELD_TYPE (type, variant_field),
8537 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8538 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8539 if (branch_type == NULL)
8541 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8542 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8543 TYPE_NFIELDS (rtype) -= 1;
8547 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8548 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8550 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8552 if (off + fld_bit_len > bit_len)
8553 bit_len = off + fld_bit_len;
8554 TYPE_LENGTH (rtype) =
8555 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8559 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8560 should contain the alignment of that record, which should be a strictly
8561 positive value. If null or negative, then something is wrong, most
8562 probably in the debug info. In that case, we don't round up the size
8563 of the resulting type. If this record is not part of another structure,
8564 the current RTYPE length might be good enough for our purposes. */
8565 if (TYPE_LENGTH (type) <= 0)
8567 if (TYPE_NAME (rtype))
8568 warning (_("Invalid type size for `%s' detected: %d."),
8569 TYPE_NAME (rtype), TYPE_LENGTH (type));
8571 warning (_("Invalid type size for <unnamed> detected: %d."),
8572 TYPE_LENGTH (type));
8576 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8577 TYPE_LENGTH (type));
8580 value_free_to_mark (mark);
8581 if (TYPE_LENGTH (rtype) > varsize_limit)
8582 error (_("record type with dynamic size is larger than varsize-limit"));
8586 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8589 static struct type *
8590 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8591 CORE_ADDR address, struct value *dval0)
8593 return ada_template_to_fixed_record_type_1 (type, valaddr,
8597 /* An ordinary record type in which ___XVL-convention fields and
8598 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8599 static approximations, containing all possible fields. Uses
8600 no runtime values. Useless for use in values, but that's OK,
8601 since the results are used only for type determinations. Works on both
8602 structs and unions. Representation note: to save space, we memorize
8603 the result of this function in the TYPE_TARGET_TYPE of the
8606 static struct type *
8607 template_to_static_fixed_type (struct type *type0)
8613 /* No need no do anything if the input type is already fixed. */
8614 if (TYPE_FIXED_INSTANCE (type0))
8617 /* Likewise if we already have computed the static approximation. */
8618 if (TYPE_TARGET_TYPE (type0) != NULL)
8619 return TYPE_TARGET_TYPE (type0);
8621 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8623 nfields = TYPE_NFIELDS (type0);
8625 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8626 recompute all over next time. */
8627 TYPE_TARGET_TYPE (type0) = type;
8629 for (f = 0; f < nfields; f += 1)
8631 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
8632 struct type *new_type;
8634 if (is_dynamic_field (type0, f))
8636 field_type = ada_check_typedef (field_type);
8637 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8640 new_type = static_unwrap_type (field_type);
8642 if (new_type != field_type)
8644 /* Clone TYPE0 only the first time we get a new field type. */
8647 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8648 TYPE_CODE (type) = TYPE_CODE (type0);
8649 INIT_CPLUS_SPECIFIC (type);
8650 TYPE_NFIELDS (type) = nfields;
8651 TYPE_FIELDS (type) = (struct field *)
8652 TYPE_ALLOC (type, nfields * sizeof (struct field));
8653 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8654 sizeof (struct field) * nfields);
8655 TYPE_NAME (type) = ada_type_name (type0);
8656 TYPE_TAG_NAME (type) = NULL;
8657 TYPE_FIXED_INSTANCE (type) = 1;
8658 TYPE_LENGTH (type) = 0;
8660 TYPE_FIELD_TYPE (type, f) = new_type;
8661 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8668 /* Given an object of type TYPE whose contents are at VALADDR and
8669 whose address in memory is ADDRESS, returns a revision of TYPE,
8670 which should be a non-dynamic-sized record, in which the variant
8671 part, if any, is replaced with the appropriate branch. Looks
8672 for discriminant values in DVAL0, which can be NULL if the record
8673 contains the necessary discriminant values. */
8675 static struct type *
8676 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8677 CORE_ADDR address, struct value *dval0)
8679 struct value *mark = value_mark ();
8682 struct type *branch_type;
8683 int nfields = TYPE_NFIELDS (type);
8684 int variant_field = variant_field_index (type);
8686 if (variant_field == -1)
8691 dval = value_from_contents_and_address (type, valaddr, address);
8692 type = value_type (dval);
8697 rtype = alloc_type_copy (type);
8698 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8699 INIT_CPLUS_SPECIFIC (rtype);
8700 TYPE_NFIELDS (rtype) = nfields;
8701 TYPE_FIELDS (rtype) =
8702 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8703 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
8704 sizeof (struct field) * nfields);
8705 TYPE_NAME (rtype) = ada_type_name (type);
8706 TYPE_TAG_NAME (rtype) = NULL;
8707 TYPE_FIXED_INSTANCE (rtype) = 1;
8708 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8710 branch_type = to_fixed_variant_branch_type
8711 (TYPE_FIELD_TYPE (type, variant_field),
8712 cond_offset_host (valaddr,
8713 TYPE_FIELD_BITPOS (type, variant_field)
8715 cond_offset_target (address,
8716 TYPE_FIELD_BITPOS (type, variant_field)
8717 / TARGET_CHAR_BIT), dval);
8718 if (branch_type == NULL)
8722 for (f = variant_field + 1; f < nfields; f += 1)
8723 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8724 TYPE_NFIELDS (rtype) -= 1;
8728 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8729 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8730 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8731 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8733 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
8735 value_free_to_mark (mark);
8739 /* An ordinary record type (with fixed-length fields) that describes
8740 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8741 beginning of this section]. Any necessary discriminants' values
8742 should be in DVAL, a record value; it may be NULL if the object
8743 at ADDR itself contains any necessary discriminant values.
8744 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8745 values from the record are needed. Except in the case that DVAL,
8746 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8747 unchecked) is replaced by a particular branch of the variant.
8749 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8750 is questionable and may be removed. It can arise during the
8751 processing of an unconstrained-array-of-record type where all the
8752 variant branches have exactly the same size. This is because in
8753 such cases, the compiler does not bother to use the XVS convention
8754 when encoding the record. I am currently dubious of this
8755 shortcut and suspect the compiler should be altered. FIXME. */
8757 static struct type *
8758 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8759 CORE_ADDR address, struct value *dval)
8761 struct type *templ_type;
8763 if (TYPE_FIXED_INSTANCE (type0))
8766 templ_type = dynamic_template_type (type0);
8768 if (templ_type != NULL)
8769 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8770 else if (variant_field_index (type0) >= 0)
8772 if (dval == NULL && valaddr == NULL && address == 0)
8774 return to_record_with_fixed_variant_part (type0, valaddr, address,
8779 TYPE_FIXED_INSTANCE (type0) = 1;
8785 /* An ordinary record type (with fixed-length fields) that describes
8786 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8787 union type. Any necessary discriminants' values should be in DVAL,
8788 a record value. That is, this routine selects the appropriate
8789 branch of the union at ADDR according to the discriminant value
8790 indicated in the union's type name. Returns VAR_TYPE0 itself if
8791 it represents a variant subject to a pragma Unchecked_Union. */
8793 static struct type *
8794 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8795 CORE_ADDR address, struct value *dval)
8798 struct type *templ_type;
8799 struct type *var_type;
8801 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8802 var_type = TYPE_TARGET_TYPE (var_type0);
8804 var_type = var_type0;
8806 templ_type = ada_find_parallel_type (var_type, "___XVU");
8808 if (templ_type != NULL)
8809 var_type = templ_type;
8811 if (is_unchecked_variant (var_type, value_type (dval)))
8814 ada_which_variant_applies (var_type,
8815 value_type (dval), value_contents (dval));
8818 return empty_record (var_type);
8819 else if (is_dynamic_field (var_type, which))
8820 return to_fixed_record_type
8821 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8822 valaddr, address, dval);
8823 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
8825 to_fixed_record_type
8826 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
8828 return TYPE_FIELD_TYPE (var_type, which);
8831 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8832 ENCODING_TYPE, a type following the GNAT conventions for discrete
8833 type encodings, only carries redundant information. */
8836 ada_is_redundant_range_encoding (struct type *range_type,
8837 struct type *encoding_type)
8839 const char *bounds_str;
8843 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8845 if (TYPE_CODE (get_base_type (range_type))
8846 != TYPE_CODE (get_base_type (encoding_type)))
8848 /* The compiler probably used a simple base type to describe
8849 the range type instead of the range's actual base type,
8850 expecting us to get the real base type from the encoding
8851 anyway. In this situation, the encoding cannot be ignored
8856 if (is_dynamic_type (range_type))
8859 if (TYPE_NAME (encoding_type) == NULL)
8862 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8863 if (bounds_str == NULL)
8866 n = 8; /* Skip "___XDLU_". */
8867 if (!ada_scan_number (bounds_str, n, &lo, &n))
8869 if (TYPE_LOW_BOUND (range_type) != lo)
8872 n += 2; /* Skip the "__" separator between the two bounds. */
8873 if (!ada_scan_number (bounds_str, n, &hi, &n))
8875 if (TYPE_HIGH_BOUND (range_type) != hi)
8881 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8882 a type following the GNAT encoding for describing array type
8883 indices, only carries redundant information. */
8886 ada_is_redundant_index_type_desc (struct type *array_type,
8887 struct type *desc_type)
8889 struct type *this_layer = check_typedef (array_type);
8892 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8894 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8895 TYPE_FIELD_TYPE (desc_type, i)))
8897 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8903 /* Assuming that TYPE0 is an array type describing the type of a value
8904 at ADDR, and that DVAL describes a record containing any
8905 discriminants used in TYPE0, returns a type for the value that
8906 contains no dynamic components (that is, no components whose sizes
8907 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8908 true, gives an error message if the resulting type's size is over
8911 static struct type *
8912 to_fixed_array_type (struct type *type0, struct value *dval,
8915 struct type *index_type_desc;
8916 struct type *result;
8917 int constrained_packed_array_p;
8918 static const char *xa_suffix = "___XA";
8920 type0 = ada_check_typedef (type0);
8921 if (TYPE_FIXED_INSTANCE (type0))
8924 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8925 if (constrained_packed_array_p)
8926 type0 = decode_constrained_packed_array_type (type0);
8928 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8930 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8931 encoding suffixed with 'P' may still be generated. If so,
8932 it should be used to find the XA type. */
8934 if (index_type_desc == NULL)
8936 const char *type_name = ada_type_name (type0);
8938 if (type_name != NULL)
8940 const int len = strlen (type_name);
8941 char *name = (char *) alloca (len + strlen (xa_suffix));
8943 if (type_name[len - 1] == 'P')
8945 strcpy (name, type_name);
8946 strcpy (name + len - 1, xa_suffix);
8947 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8952 ada_fixup_array_indexes_type (index_type_desc);
8953 if (index_type_desc != NULL
8954 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8956 /* Ignore this ___XA parallel type, as it does not bring any
8957 useful information. This allows us to avoid creating fixed
8958 versions of the array's index types, which would be identical
8959 to the original ones. This, in turn, can also help avoid
8960 the creation of fixed versions of the array itself. */
8961 index_type_desc = NULL;
8964 if (index_type_desc == NULL)
8966 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8968 /* NOTE: elt_type---the fixed version of elt_type0---should never
8969 depend on the contents of the array in properly constructed
8971 /* Create a fixed version of the array element type.
8972 We're not providing the address of an element here,
8973 and thus the actual object value cannot be inspected to do
8974 the conversion. This should not be a problem, since arrays of
8975 unconstrained objects are not allowed. In particular, all
8976 the elements of an array of a tagged type should all be of
8977 the same type specified in the debugging info. No need to
8978 consult the object tag. */
8979 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8981 /* Make sure we always create a new array type when dealing with
8982 packed array types, since we're going to fix-up the array
8983 type length and element bitsize a little further down. */
8984 if (elt_type0 == elt_type && !constrained_packed_array_p)
8987 result = create_array_type (alloc_type_copy (type0),
8988 elt_type, TYPE_INDEX_TYPE (type0));
8993 struct type *elt_type0;
8996 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
8997 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8999 /* NOTE: result---the fixed version of elt_type0---should never
9000 depend on the contents of the array in properly constructed
9002 /* Create a fixed version of the array element type.
9003 We're not providing the address of an element here,
9004 and thus the actual object value cannot be inspected to do
9005 the conversion. This should not be a problem, since arrays of
9006 unconstrained objects are not allowed. In particular, all
9007 the elements of an array of a tagged type should all be of
9008 the same type specified in the debugging info. No need to
9009 consult the object tag. */
9011 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
9014 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
9016 struct type *range_type =
9017 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
9019 result = create_array_type (alloc_type_copy (elt_type0),
9020 result, range_type);
9021 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
9023 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
9024 error (_("array type with dynamic size is larger than varsize-limit"));
9027 /* We want to preserve the type name. This can be useful when
9028 trying to get the type name of a value that has already been
9029 printed (for instance, if the user did "print VAR; whatis $". */
9030 TYPE_NAME (result) = TYPE_NAME (type0);
9032 if (constrained_packed_array_p)
9034 /* So far, the resulting type has been created as if the original
9035 type was a regular (non-packed) array type. As a result, the
9036 bitsize of the array elements needs to be set again, and the array
9037 length needs to be recomputed based on that bitsize. */
9038 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
9039 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
9041 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
9042 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
9043 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
9044 TYPE_LENGTH (result)++;
9047 TYPE_FIXED_INSTANCE (result) = 1;
9052 /* A standard type (containing no dynamically sized components)
9053 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
9054 DVAL describes a record containing any discriminants used in TYPE0,
9055 and may be NULL if there are none, or if the object of type TYPE at
9056 ADDRESS or in VALADDR contains these discriminants.
9058 If CHECK_TAG is not null, in the case of tagged types, this function
9059 attempts to locate the object's tag and use it to compute the actual
9060 type. However, when ADDRESS is null, we cannot use it to determine the
9061 location of the tag, and therefore compute the tagged type's actual type.
9062 So we return the tagged type without consulting the tag. */
9064 static struct type *
9065 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
9066 CORE_ADDR address, struct value *dval, int check_tag)
9068 type = ada_check_typedef (type);
9069 switch (TYPE_CODE (type))
9073 case TYPE_CODE_STRUCT:
9075 struct type *static_type = to_static_fixed_type (type);
9076 struct type *fixed_record_type =
9077 to_fixed_record_type (type, valaddr, address, NULL);
9079 /* If STATIC_TYPE is a tagged type and we know the object's address,
9080 then we can determine its tag, and compute the object's actual
9081 type from there. Note that we have to use the fixed record
9082 type (the parent part of the record may have dynamic fields
9083 and the way the location of _tag is expressed may depend on
9086 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
9089 value_tag_from_contents_and_address
9093 struct type *real_type = type_from_tag (tag);
9095 value_from_contents_and_address (fixed_record_type,
9098 fixed_record_type = value_type (obj);
9099 if (real_type != NULL)
9100 return to_fixed_record_type
9102 value_address (ada_tag_value_at_base_address (obj)), NULL);
9105 /* Check to see if there is a parallel ___XVZ variable.
9106 If there is, then it provides the actual size of our type. */
9107 else if (ada_type_name (fixed_record_type) != NULL)
9109 const char *name = ada_type_name (fixed_record_type);
9111 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
9112 bool xvz_found = false;
9115 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
9118 xvz_found = get_int_var_value (xvz_name, size);
9120 CATCH (except, RETURN_MASK_ERROR)
9122 /* We found the variable, but somehow failed to read
9123 its value. Rethrow the same error, but with a little
9124 bit more information, to help the user understand
9125 what went wrong (Eg: the variable might have been
9127 throw_error (except.error,
9128 _("unable to read value of %s (%s)"),
9129 xvz_name, except.message);
9133 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
9135 fixed_record_type = copy_type (fixed_record_type);
9136 TYPE_LENGTH (fixed_record_type) = size;
9138 /* The FIXED_RECORD_TYPE may have be a stub. We have
9139 observed this when the debugging info is STABS, and
9140 apparently it is something that is hard to fix.
9142 In practice, we don't need the actual type definition
9143 at all, because the presence of the XVZ variable allows us
9144 to assume that there must be a XVS type as well, which we
9145 should be able to use later, when we need the actual type
9148 In the meantime, pretend that the "fixed" type we are
9149 returning is NOT a stub, because this can cause trouble
9150 when using this type to create new types targeting it.
9151 Indeed, the associated creation routines often check
9152 whether the target type is a stub and will try to replace
9153 it, thus using a type with the wrong size. This, in turn,
9154 might cause the new type to have the wrong size too.
9155 Consider the case of an array, for instance, where the size
9156 of the array is computed from the number of elements in
9157 our array multiplied by the size of its element. */
9158 TYPE_STUB (fixed_record_type) = 0;
9161 return fixed_record_type;
9163 case TYPE_CODE_ARRAY:
9164 return to_fixed_array_type (type, dval, 1);
9165 case TYPE_CODE_UNION:
9169 return to_fixed_variant_branch_type (type, valaddr, address, dval);
9173 /* The same as ada_to_fixed_type_1, except that it preserves the type
9174 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
9176 The typedef layer needs be preserved in order to differentiate between
9177 arrays and array pointers when both types are implemented using the same
9178 fat pointer. In the array pointer case, the pointer is encoded as
9179 a typedef of the pointer type. For instance, considering:
9181 type String_Access is access String;
9182 S1 : String_Access := null;
9184 To the debugger, S1 is defined as a typedef of type String. But
9185 to the user, it is a pointer. So if the user tries to print S1,
9186 we should not dereference the array, but print the array address
9189 If we didn't preserve the typedef layer, we would lose the fact that
9190 the type is to be presented as a pointer (needs de-reference before
9191 being printed). And we would also use the source-level type name. */
9194 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
9195 CORE_ADDR address, struct value *dval, int check_tag)
9198 struct type *fixed_type =
9199 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
9201 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9202 then preserve the typedef layer.
9204 Implementation note: We can only check the main-type portion of
9205 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9206 from TYPE now returns a type that has the same instance flags
9207 as TYPE. For instance, if TYPE is a "typedef const", and its
9208 target type is a "struct", then the typedef elimination will return
9209 a "const" version of the target type. See check_typedef for more
9210 details about how the typedef layer elimination is done.
9212 brobecker/2010-11-19: It seems to me that the only case where it is
9213 useful to preserve the typedef layer is when dealing with fat pointers.
9214 Perhaps, we could add a check for that and preserve the typedef layer
9215 only in that situation. But this seems unecessary so far, probably
9216 because we call check_typedef/ada_check_typedef pretty much everywhere.
9218 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9219 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
9220 == TYPE_MAIN_TYPE (fixed_type)))
9226 /* A standard (static-sized) type corresponding as well as possible to
9227 TYPE0, but based on no runtime data. */
9229 static struct type *
9230 to_static_fixed_type (struct type *type0)
9237 if (TYPE_FIXED_INSTANCE (type0))
9240 type0 = ada_check_typedef (type0);
9242 switch (TYPE_CODE (type0))
9246 case TYPE_CODE_STRUCT:
9247 type = dynamic_template_type (type0);
9249 return template_to_static_fixed_type (type);
9251 return template_to_static_fixed_type (type0);
9252 case TYPE_CODE_UNION:
9253 type = ada_find_parallel_type (type0, "___XVU");
9255 return template_to_static_fixed_type (type);
9257 return template_to_static_fixed_type (type0);
9261 /* A static approximation of TYPE with all type wrappers removed. */
9263 static struct type *
9264 static_unwrap_type (struct type *type)
9266 if (ada_is_aligner_type (type))
9268 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
9269 if (ada_type_name (type1) == NULL)
9270 TYPE_NAME (type1) = ada_type_name (type);
9272 return static_unwrap_type (type1);
9276 struct type *raw_real_type = ada_get_base_type (type);
9278 if (raw_real_type == type)
9281 return to_static_fixed_type (raw_real_type);
9285 /* In some cases, incomplete and private types require
9286 cross-references that are not resolved as records (for example,
9288 type FooP is access Foo;
9290 type Foo is array ...;
9291 ). In these cases, since there is no mechanism for producing
9292 cross-references to such types, we instead substitute for FooP a
9293 stub enumeration type that is nowhere resolved, and whose tag is
9294 the name of the actual type. Call these types "non-record stubs". */
9296 /* A type equivalent to TYPE that is not a non-record stub, if one
9297 exists, otherwise TYPE. */
9300 ada_check_typedef (struct type *type)
9305 /* If our type is a typedef type of a fat pointer, then we're done.
9306 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9307 what allows us to distinguish between fat pointers that represent
9308 array types, and fat pointers that represent array access types
9309 (in both cases, the compiler implements them as fat pointers). */
9310 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9311 && is_thick_pntr (ada_typedef_target_type (type)))
9314 type = check_typedef (type);
9315 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
9316 || !TYPE_STUB (type)
9317 || TYPE_TAG_NAME (type) == NULL)
9321 const char *name = TYPE_TAG_NAME (type);
9322 struct type *type1 = ada_find_any_type (name);
9327 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9328 stubs pointing to arrays, as we don't create symbols for array
9329 types, only for the typedef-to-array types). If that's the case,
9330 strip the typedef layer. */
9331 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9332 type1 = ada_check_typedef (type1);
9338 /* A value representing the data at VALADDR/ADDRESS as described by
9339 type TYPE0, but with a standard (static-sized) type that correctly
9340 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9341 type, then return VAL0 [this feature is simply to avoid redundant
9342 creation of struct values]. */
9344 static struct value *
9345 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9348 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
9350 if (type == type0 && val0 != NULL)
9353 if (VALUE_LVAL (val0) != lval_memory)
9355 /* Our value does not live in memory; it could be a convenience
9356 variable, for instance. Create a not_lval value using val0's
9358 return value_from_contents (type, value_contents (val0));
9361 return value_from_contents_and_address (type, 0, address);
9364 /* A value representing VAL, but with a standard (static-sized) type
9365 that correctly describes it. Does not necessarily create a new
9369 ada_to_fixed_value (struct value *val)
9371 val = unwrap_value (val);
9372 val = ada_to_fixed_value_create (value_type (val),
9373 value_address (val),
9381 /* Table mapping attribute numbers to names.
9382 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
9384 static const char *attribute_names[] = {
9402 ada_attribute_name (enum exp_opcode n)
9404 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9405 return attribute_names[n - OP_ATR_FIRST + 1];
9407 return attribute_names[0];
9410 /* Evaluate the 'POS attribute applied to ARG. */
9413 pos_atr (struct value *arg)
9415 struct value *val = coerce_ref (arg);
9416 struct type *type = value_type (val);
9419 if (!discrete_type_p (type))
9420 error (_("'POS only defined on discrete types"));
9422 if (!discrete_position (type, value_as_long (val), &result))
9423 error (_("enumeration value is invalid: can't find 'POS"));
9428 static struct value *
9429 value_pos_atr (struct type *type, struct value *arg)
9431 return value_from_longest (type, pos_atr (arg));
9434 /* Evaluate the TYPE'VAL attribute applied to ARG. */
9436 static struct value *
9437 value_val_atr (struct type *type, struct value *arg)
9439 if (!discrete_type_p (type))
9440 error (_("'VAL only defined on discrete types"));
9441 if (!integer_type_p (value_type (arg)))
9442 error (_("'VAL requires integral argument"));
9444 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9446 long pos = value_as_long (arg);
9448 if (pos < 0 || pos >= TYPE_NFIELDS (type))
9449 error (_("argument to 'VAL out of range"));
9450 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
9453 return value_from_longest (type, value_as_long (arg));
9459 /* True if TYPE appears to be an Ada character type.
9460 [At the moment, this is true only for Character and Wide_Character;
9461 It is a heuristic test that could stand improvement]. */
9464 ada_is_character_type (struct type *type)
9468 /* If the type code says it's a character, then assume it really is,
9469 and don't check any further. */
9470 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9473 /* Otherwise, assume it's a character type iff it is a discrete type
9474 with a known character type name. */
9475 name = ada_type_name (type);
9476 return (name != NULL
9477 && (TYPE_CODE (type) == TYPE_CODE_INT
9478 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9479 && (strcmp (name, "character") == 0
9480 || strcmp (name, "wide_character") == 0
9481 || strcmp (name, "wide_wide_character") == 0
9482 || strcmp (name, "unsigned char") == 0));
9485 /* True if TYPE appears to be an Ada string type. */
9488 ada_is_string_type (struct type *type)
9490 type = ada_check_typedef (type);
9492 && TYPE_CODE (type) != TYPE_CODE_PTR
9493 && (ada_is_simple_array_type (type)
9494 || ada_is_array_descriptor_type (type))
9495 && ada_array_arity (type) == 1)
9497 struct type *elttype = ada_array_element_type (type, 1);
9499 return ada_is_character_type (elttype);
9505 /* The compiler sometimes provides a parallel XVS type for a given
9506 PAD type. Normally, it is safe to follow the PAD type directly,
9507 but older versions of the compiler have a bug that causes the offset
9508 of its "F" field to be wrong. Following that field in that case
9509 would lead to incorrect results, but this can be worked around
9510 by ignoring the PAD type and using the associated XVS type instead.
9512 Set to True if the debugger should trust the contents of PAD types.
9513 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9514 static int trust_pad_over_xvs = 1;
9516 /* True if TYPE is a struct type introduced by the compiler to force the
9517 alignment of a value. Such types have a single field with a
9518 distinctive name. */
9521 ada_is_aligner_type (struct type *type)
9523 type = ada_check_typedef (type);
9525 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9528 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
9529 && TYPE_NFIELDS (type) == 1
9530 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
9533 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9534 the parallel type. */
9537 ada_get_base_type (struct type *raw_type)
9539 struct type *real_type_namer;
9540 struct type *raw_real_type;
9542 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9545 if (ada_is_aligner_type (raw_type))
9546 /* The encoding specifies that we should always use the aligner type.
9547 So, even if this aligner type has an associated XVS type, we should
9550 According to the compiler gurus, an XVS type parallel to an aligner
9551 type may exist because of a stabs limitation. In stabs, aligner
9552 types are empty because the field has a variable-sized type, and
9553 thus cannot actually be used as an aligner type. As a result,
9554 we need the associated parallel XVS type to decode the type.
9555 Since the policy in the compiler is to not change the internal
9556 representation based on the debugging info format, we sometimes
9557 end up having a redundant XVS type parallel to the aligner type. */
9560 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9561 if (real_type_namer == NULL
9562 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9563 || TYPE_NFIELDS (real_type_namer) != 1)
9566 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9568 /* This is an older encoding form where the base type needs to be
9569 looked up by name. We prefer the newer enconding because it is
9571 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9572 if (raw_real_type == NULL)
9575 return raw_real_type;
9578 /* The field in our XVS type is a reference to the base type. */
9579 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
9582 /* The type of value designated by TYPE, with all aligners removed. */
9585 ada_aligned_type (struct type *type)
9587 if (ada_is_aligner_type (type))
9588 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9590 return ada_get_base_type (type);
9594 /* The address of the aligned value in an object at address VALADDR
9595 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9598 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9600 if (ada_is_aligner_type (type))
9601 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
9603 TYPE_FIELD_BITPOS (type,
9604 0) / TARGET_CHAR_BIT);
9611 /* The printed representation of an enumeration literal with encoded
9612 name NAME. The value is good to the next call of ada_enum_name. */
9614 ada_enum_name (const char *name)
9616 static char *result;
9617 static size_t result_len = 0;
9620 /* First, unqualify the enumeration name:
9621 1. Search for the last '.' character. If we find one, then skip
9622 all the preceding characters, the unqualified name starts
9623 right after that dot.
9624 2. Otherwise, we may be debugging on a target where the compiler
9625 translates dots into "__". Search forward for double underscores,
9626 but stop searching when we hit an overloading suffix, which is
9627 of the form "__" followed by digits. */
9629 tmp = strrchr (name, '.');
9634 while ((tmp = strstr (name, "__")) != NULL)
9636 if (isdigit (tmp[2]))
9647 if (name[1] == 'U' || name[1] == 'W')
9649 if (sscanf (name + 2, "%x", &v) != 1)
9655 GROW_VECT (result, result_len, 16);
9656 if (isascii (v) && isprint (v))
9657 xsnprintf (result, result_len, "'%c'", v);
9658 else if (name[1] == 'U')
9659 xsnprintf (result, result_len, "[\"%02x\"]", v);
9661 xsnprintf (result, result_len, "[\"%04x\"]", v);
9667 tmp = strstr (name, "__");
9669 tmp = strstr (name, "$");
9672 GROW_VECT (result, result_len, tmp - name + 1);
9673 strncpy (result, name, tmp - name);
9674 result[tmp - name] = '\0';
9682 /* Evaluate the subexpression of EXP starting at *POS as for
9683 evaluate_type, updating *POS to point just past the evaluated
9686 static struct value *
9687 evaluate_subexp_type (struct expression *exp, int *pos)
9689 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9692 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9695 static struct value *
9696 unwrap_value (struct value *val)
9698 struct type *type = ada_check_typedef (value_type (val));
9700 if (ada_is_aligner_type (type))
9702 struct value *v = ada_value_struct_elt (val, "F", 0);
9703 struct type *val_type = ada_check_typedef (value_type (v));
9705 if (ada_type_name (val_type) == NULL)
9706 TYPE_NAME (val_type) = ada_type_name (type);
9708 return unwrap_value (v);
9712 struct type *raw_real_type =
9713 ada_check_typedef (ada_get_base_type (type));
9715 /* If there is no parallel XVS or XVE type, then the value is
9716 already unwrapped. Return it without further modification. */
9717 if ((type == raw_real_type)
9718 && ada_find_parallel_type (type, "___XVE") == NULL)
9722 coerce_unspec_val_to_type
9723 (val, ada_to_fixed_type (raw_real_type, 0,
9724 value_address (val),
9729 static struct value *
9730 cast_from_fixed (struct type *type, struct value *arg)
9732 struct value *scale = ada_scaling_factor (value_type (arg));
9733 arg = value_cast (value_type (scale), arg);
9735 arg = value_binop (arg, scale, BINOP_MUL);
9736 return value_cast (type, arg);
9739 static struct value *
9740 cast_to_fixed (struct type *type, struct value *arg)
9742 if (type == value_type (arg))
9745 struct value *scale = ada_scaling_factor (type);
9746 if (ada_is_fixed_point_type (value_type (arg)))
9747 arg = cast_from_fixed (value_type (scale), arg);
9749 arg = value_cast (value_type (scale), arg);
9751 arg = value_binop (arg, scale, BINOP_DIV);
9752 return value_cast (type, arg);
9755 /* Given two array types T1 and T2, return nonzero iff both arrays
9756 contain the same number of elements. */
9759 ada_same_array_size_p (struct type *t1, struct type *t2)
9761 LONGEST lo1, hi1, lo2, hi2;
9763 /* Get the array bounds in order to verify that the size of
9764 the two arrays match. */
9765 if (!get_array_bounds (t1, &lo1, &hi1)
9766 || !get_array_bounds (t2, &lo2, &hi2))
9767 error (_("unable to determine array bounds"));
9769 /* To make things easier for size comparison, normalize a bit
9770 the case of empty arrays by making sure that the difference
9771 between upper bound and lower bound is always -1. */
9777 return (hi1 - lo1 == hi2 - lo2);
9780 /* Assuming that VAL is an array of integrals, and TYPE represents
9781 an array with the same number of elements, but with wider integral
9782 elements, return an array "casted" to TYPE. In practice, this
9783 means that the returned array is built by casting each element
9784 of the original array into TYPE's (wider) element type. */
9786 static struct value *
9787 ada_promote_array_of_integrals (struct type *type, struct value *val)
9789 struct type *elt_type = TYPE_TARGET_TYPE (type);
9794 /* Verify that both val and type are arrays of scalars, and
9795 that the size of val's elements is smaller than the size
9796 of type's element. */
9797 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9798 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9799 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9800 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9801 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9802 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9804 if (!get_array_bounds (type, &lo, &hi))
9805 error (_("unable to determine array bounds"));
9807 res = allocate_value (type);
9809 /* Promote each array element. */
9810 for (i = 0; i < hi - lo + 1; i++)
9812 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9814 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9815 value_contents_all (elt), TYPE_LENGTH (elt_type));
9821 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9822 return the converted value. */
9824 static struct value *
9825 coerce_for_assign (struct type *type, struct value *val)
9827 struct type *type2 = value_type (val);
9832 type2 = ada_check_typedef (type2);
9833 type = ada_check_typedef (type);
9835 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9836 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9838 val = ada_value_ind (val);
9839 type2 = value_type (val);
9842 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
9843 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9845 if (!ada_same_array_size_p (type, type2))
9846 error (_("cannot assign arrays of different length"));
9848 if (is_integral_type (TYPE_TARGET_TYPE (type))
9849 && is_integral_type (TYPE_TARGET_TYPE (type2))
9850 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9851 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9853 /* Allow implicit promotion of the array elements to
9855 return ada_promote_array_of_integrals (type, val);
9858 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9859 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9860 error (_("Incompatible types in assignment"));
9861 deprecated_set_value_type (val, type);
9866 static struct value *
9867 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9870 struct type *type1, *type2;
9873 arg1 = coerce_ref (arg1);
9874 arg2 = coerce_ref (arg2);
9875 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9876 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9878 if (TYPE_CODE (type1) != TYPE_CODE_INT
9879 || TYPE_CODE (type2) != TYPE_CODE_INT)
9880 return value_binop (arg1, arg2, op);
9889 return value_binop (arg1, arg2, op);
9892 v2 = value_as_long (arg2);
9894 error (_("second operand of %s must not be zero."), op_string (op));
9896 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9897 return value_binop (arg1, arg2, op);
9899 v1 = value_as_long (arg1);
9904 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9905 v += v > 0 ? -1 : 1;
9913 /* Should not reach this point. */
9917 val = allocate_value (type1);
9918 store_unsigned_integer (value_contents_raw (val),
9919 TYPE_LENGTH (value_type (val)),
9920 gdbarch_byte_order (get_type_arch (type1)), v);
9925 ada_value_equal (struct value *arg1, struct value *arg2)
9927 if (ada_is_direct_array_type (value_type (arg1))
9928 || ada_is_direct_array_type (value_type (arg2)))
9930 struct type *arg1_type, *arg2_type;
9932 /* Automatically dereference any array reference before
9933 we attempt to perform the comparison. */
9934 arg1 = ada_coerce_ref (arg1);
9935 arg2 = ada_coerce_ref (arg2);
9937 arg1 = ada_coerce_to_simple_array (arg1);
9938 arg2 = ada_coerce_to_simple_array (arg2);
9940 arg1_type = ada_check_typedef (value_type (arg1));
9941 arg2_type = ada_check_typedef (value_type (arg2));
9943 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9944 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
9945 error (_("Attempt to compare array with non-array"));
9946 /* FIXME: The following works only for types whose
9947 representations use all bits (no padding or undefined bits)
9948 and do not have user-defined equality. */
9949 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9950 && memcmp (value_contents (arg1), value_contents (arg2),
9951 TYPE_LENGTH (arg1_type)) == 0);
9953 return value_equal (arg1, arg2);
9956 /* Total number of component associations in the aggregate starting at
9957 index PC in EXP. Assumes that index PC is the start of an
9961 num_component_specs (struct expression *exp, int pc)
9965 m = exp->elts[pc + 1].longconst;
9968 for (i = 0; i < m; i += 1)
9970 switch (exp->elts[pc].opcode)
9976 n += exp->elts[pc + 1].longconst;
9979 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9984 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9985 component of LHS (a simple array or a record), updating *POS past
9986 the expression, assuming that LHS is contained in CONTAINER. Does
9987 not modify the inferior's memory, nor does it modify LHS (unless
9988 LHS == CONTAINER). */
9991 assign_component (struct value *container, struct value *lhs, LONGEST index,
9992 struct expression *exp, int *pos)
9994 struct value *mark = value_mark ();
9996 struct type *lhs_type = check_typedef (value_type (lhs));
9998 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
10000 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
10001 struct value *index_val = value_from_longest (index_type, index);
10003 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
10007 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
10008 elt = ada_to_fixed_value (elt);
10011 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10012 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
10014 value_assign_to_component (container, elt,
10015 ada_evaluate_subexp (NULL, exp, pos,
10018 value_free_to_mark (mark);
10021 /* Assuming that LHS represents an lvalue having a record or array
10022 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
10023 of that aggregate's value to LHS, advancing *POS past the
10024 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
10025 lvalue containing LHS (possibly LHS itself). Does not modify
10026 the inferior's memory, nor does it modify the contents of
10027 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
10029 static struct value *
10030 assign_aggregate (struct value *container,
10031 struct value *lhs, struct expression *exp,
10032 int *pos, enum noside noside)
10034 struct type *lhs_type;
10035 int n = exp->elts[*pos+1].longconst;
10036 LONGEST low_index, high_index;
10039 int max_indices, num_indices;
10043 if (noside != EVAL_NORMAL)
10045 for (i = 0; i < n; i += 1)
10046 ada_evaluate_subexp (NULL, exp, pos, noside);
10050 container = ada_coerce_ref (container);
10051 if (ada_is_direct_array_type (value_type (container)))
10052 container = ada_coerce_to_simple_array (container);
10053 lhs = ada_coerce_ref (lhs);
10054 if (!deprecated_value_modifiable (lhs))
10055 error (_("Left operand of assignment is not a modifiable lvalue."));
10057 lhs_type = check_typedef (value_type (lhs));
10058 if (ada_is_direct_array_type (lhs_type))
10060 lhs = ada_coerce_to_simple_array (lhs);
10061 lhs_type = check_typedef (value_type (lhs));
10062 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
10063 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
10065 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
10068 high_index = num_visible_fields (lhs_type) - 1;
10071 error (_("Left-hand side must be array or record."));
10073 num_specs = num_component_specs (exp, *pos - 3);
10074 max_indices = 4 * num_specs + 4;
10075 indices = XALLOCAVEC (LONGEST, max_indices);
10076 indices[0] = indices[1] = low_index - 1;
10077 indices[2] = indices[3] = high_index + 1;
10080 for (i = 0; i < n; i += 1)
10082 switch (exp->elts[*pos].opcode)
10085 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
10086 &num_indices, max_indices,
10087 low_index, high_index);
10089 case OP_POSITIONAL:
10090 aggregate_assign_positional (container, lhs, exp, pos, indices,
10091 &num_indices, max_indices,
10092 low_index, high_index);
10096 error (_("Misplaced 'others' clause"));
10097 aggregate_assign_others (container, lhs, exp, pos, indices,
10098 num_indices, low_index, high_index);
10101 error (_("Internal error: bad aggregate clause"));
10108 /* Assign into the component of LHS indexed by the OP_POSITIONAL
10109 construct at *POS, updating *POS past the construct, given that
10110 the positions are relative to lower bound LOW, where HIGH is the
10111 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
10112 updating *NUM_INDICES as needed. CONTAINER is as for
10113 assign_aggregate. */
10115 aggregate_assign_positional (struct value *container,
10116 struct value *lhs, struct expression *exp,
10117 int *pos, LONGEST *indices, int *num_indices,
10118 int max_indices, LONGEST low, LONGEST high)
10120 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
10122 if (ind - 1 == high)
10123 warning (_("Extra components in aggregate ignored."));
10126 add_component_interval (ind, ind, indices, num_indices, max_indices);
10128 assign_component (container, lhs, ind, exp, pos);
10131 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10134 /* Assign into the components of LHS indexed by the OP_CHOICES
10135 construct at *POS, updating *POS past the construct, given that
10136 the allowable indices are LOW..HIGH. Record the indices assigned
10137 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
10138 needed. CONTAINER is as for assign_aggregate. */
10140 aggregate_assign_from_choices (struct value *container,
10141 struct value *lhs, struct expression *exp,
10142 int *pos, LONGEST *indices, int *num_indices,
10143 int max_indices, LONGEST low, LONGEST high)
10146 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
10147 int choice_pos, expr_pc;
10148 int is_array = ada_is_direct_array_type (value_type (lhs));
10150 choice_pos = *pos += 3;
10152 for (j = 0; j < n_choices; j += 1)
10153 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10155 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10157 for (j = 0; j < n_choices; j += 1)
10159 LONGEST lower, upper;
10160 enum exp_opcode op = exp->elts[choice_pos].opcode;
10162 if (op == OP_DISCRETE_RANGE)
10165 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10167 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10172 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
10184 name = &exp->elts[choice_pos + 2].string;
10187 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
10190 error (_("Invalid record component association."));
10192 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
10194 if (! find_struct_field (name, value_type (lhs), 0,
10195 NULL, NULL, NULL, NULL, &ind))
10196 error (_("Unknown component name: %s."), name);
10197 lower = upper = ind;
10200 if (lower <= upper && (lower < low || upper > high))
10201 error (_("Index in component association out of bounds."));
10203 add_component_interval (lower, upper, indices, num_indices,
10205 while (lower <= upper)
10210 assign_component (container, lhs, lower, exp, &pos1);
10216 /* Assign the value of the expression in the OP_OTHERS construct in
10217 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10218 have not been previously assigned. The index intervals already assigned
10219 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
10220 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
10222 aggregate_assign_others (struct value *container,
10223 struct value *lhs, struct expression *exp,
10224 int *pos, LONGEST *indices, int num_indices,
10225 LONGEST low, LONGEST high)
10228 int expr_pc = *pos + 1;
10230 for (i = 0; i < num_indices - 2; i += 2)
10234 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10238 localpos = expr_pc;
10239 assign_component (container, lhs, ind, exp, &localpos);
10242 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10245 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
10246 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10247 modifying *SIZE as needed. It is an error if *SIZE exceeds
10248 MAX_SIZE. The resulting intervals do not overlap. */
10250 add_component_interval (LONGEST low, LONGEST high,
10251 LONGEST* indices, int *size, int max_size)
10255 for (i = 0; i < *size; i += 2) {
10256 if (high >= indices[i] && low <= indices[i + 1])
10260 for (kh = i + 2; kh < *size; kh += 2)
10261 if (high < indices[kh])
10263 if (low < indices[i])
10265 indices[i + 1] = indices[kh - 1];
10266 if (high > indices[i + 1])
10267 indices[i + 1] = high;
10268 memcpy (indices + i + 2, indices + kh, *size - kh);
10269 *size -= kh - i - 2;
10272 else if (high < indices[i])
10276 if (*size == max_size)
10277 error (_("Internal error: miscounted aggregate components."));
10279 for (j = *size-1; j >= i+2; j -= 1)
10280 indices[j] = indices[j - 2];
10282 indices[i + 1] = high;
10285 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10288 static struct value *
10289 ada_value_cast (struct type *type, struct value *arg2)
10291 if (type == ada_check_typedef (value_type (arg2)))
10294 if (ada_is_fixed_point_type (type))
10295 return (cast_to_fixed (type, arg2));
10297 if (ada_is_fixed_point_type (value_type (arg2)))
10298 return cast_from_fixed (type, arg2);
10300 return value_cast (type, arg2);
10303 /* Evaluating Ada expressions, and printing their result.
10304 ------------------------------------------------------
10309 We usually evaluate an Ada expression in order to print its value.
10310 We also evaluate an expression in order to print its type, which
10311 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10312 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10313 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10314 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10317 Evaluating expressions is a little more complicated for Ada entities
10318 than it is for entities in languages such as C. The main reason for
10319 this is that Ada provides types whose definition might be dynamic.
10320 One example of such types is variant records. Or another example
10321 would be an array whose bounds can only be known at run time.
10323 The following description is a general guide as to what should be
10324 done (and what should NOT be done) in order to evaluate an expression
10325 involving such types, and when. This does not cover how the semantic
10326 information is encoded by GNAT as this is covered separatly. For the
10327 document used as the reference for the GNAT encoding, see exp_dbug.ads
10328 in the GNAT sources.
10330 Ideally, we should embed each part of this description next to its
10331 associated code. Unfortunately, the amount of code is so vast right
10332 now that it's hard to see whether the code handling a particular
10333 situation might be duplicated or not. One day, when the code is
10334 cleaned up, this guide might become redundant with the comments
10335 inserted in the code, and we might want to remove it.
10337 2. ``Fixing'' an Entity, the Simple Case:
10338 -----------------------------------------
10340 When evaluating Ada expressions, the tricky issue is that they may
10341 reference entities whose type contents and size are not statically
10342 known. Consider for instance a variant record:
10344 type Rec (Empty : Boolean := True) is record
10347 when False => Value : Integer;
10350 Yes : Rec := (Empty => False, Value => 1);
10351 No : Rec := (empty => True);
10353 The size and contents of that record depends on the value of the
10354 descriminant (Rec.Empty). At this point, neither the debugging
10355 information nor the associated type structure in GDB are able to
10356 express such dynamic types. So what the debugger does is to create
10357 "fixed" versions of the type that applies to the specific object.
10358 We also informally refer to this opperation as "fixing" an object,
10359 which means creating its associated fixed type.
10361 Example: when printing the value of variable "Yes" above, its fixed
10362 type would look like this:
10369 On the other hand, if we printed the value of "No", its fixed type
10376 Things become a little more complicated when trying to fix an entity
10377 with a dynamic type that directly contains another dynamic type,
10378 such as an array of variant records, for instance. There are
10379 two possible cases: Arrays, and records.
10381 3. ``Fixing'' Arrays:
10382 ---------------------
10384 The type structure in GDB describes an array in terms of its bounds,
10385 and the type of its elements. By design, all elements in the array
10386 have the same type and we cannot represent an array of variant elements
10387 using the current type structure in GDB. When fixing an array,
10388 we cannot fix the array element, as we would potentially need one
10389 fixed type per element of the array. As a result, the best we can do
10390 when fixing an array is to produce an array whose bounds and size
10391 are correct (allowing us to read it from memory), but without having
10392 touched its element type. Fixing each element will be done later,
10393 when (if) necessary.
10395 Arrays are a little simpler to handle than records, because the same
10396 amount of memory is allocated for each element of the array, even if
10397 the amount of space actually used by each element differs from element
10398 to element. Consider for instance the following array of type Rec:
10400 type Rec_Array is array (1 .. 2) of Rec;
10402 The actual amount of memory occupied by each element might be different
10403 from element to element, depending on the value of their discriminant.
10404 But the amount of space reserved for each element in the array remains
10405 fixed regardless. So we simply need to compute that size using
10406 the debugging information available, from which we can then determine
10407 the array size (we multiply the number of elements of the array by
10408 the size of each element).
10410 The simplest case is when we have an array of a constrained element
10411 type. For instance, consider the following type declarations:
10413 type Bounded_String (Max_Size : Integer) is
10415 Buffer : String (1 .. Max_Size);
10417 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10419 In this case, the compiler describes the array as an array of
10420 variable-size elements (identified by its XVS suffix) for which
10421 the size can be read in the parallel XVZ variable.
10423 In the case of an array of an unconstrained element type, the compiler
10424 wraps the array element inside a private PAD type. This type should not
10425 be shown to the user, and must be "unwrap"'ed before printing. Note
10426 that we also use the adjective "aligner" in our code to designate
10427 these wrapper types.
10429 In some cases, the size allocated for each element is statically
10430 known. In that case, the PAD type already has the correct size,
10431 and the array element should remain unfixed.
10433 But there are cases when this size is not statically known.
10434 For instance, assuming that "Five" is an integer variable:
10436 type Dynamic is array (1 .. Five) of Integer;
10437 type Wrapper (Has_Length : Boolean := False) is record
10440 when True => Length : Integer;
10441 when False => null;
10444 type Wrapper_Array is array (1 .. 2) of Wrapper;
10446 Hello : Wrapper_Array := (others => (Has_Length => True,
10447 Data => (others => 17),
10451 The debugging info would describe variable Hello as being an
10452 array of a PAD type. The size of that PAD type is not statically
10453 known, but can be determined using a parallel XVZ variable.
10454 In that case, a copy of the PAD type with the correct size should
10455 be used for the fixed array.
10457 3. ``Fixing'' record type objects:
10458 ----------------------------------
10460 Things are slightly different from arrays in the case of dynamic
10461 record types. In this case, in order to compute the associated
10462 fixed type, we need to determine the size and offset of each of
10463 its components. This, in turn, requires us to compute the fixed
10464 type of each of these components.
10466 Consider for instance the example:
10468 type Bounded_String (Max_Size : Natural) is record
10469 Str : String (1 .. Max_Size);
10472 My_String : Bounded_String (Max_Size => 10);
10474 In that case, the position of field "Length" depends on the size
10475 of field Str, which itself depends on the value of the Max_Size
10476 discriminant. In order to fix the type of variable My_String,
10477 we need to fix the type of field Str. Therefore, fixing a variant
10478 record requires us to fix each of its components.
10480 However, if a component does not have a dynamic size, the component
10481 should not be fixed. In particular, fields that use a PAD type
10482 should not fixed. Here is an example where this might happen
10483 (assuming type Rec above):
10485 type Container (Big : Boolean) is record
10489 when True => Another : Integer;
10490 when False => null;
10493 My_Container : Container := (Big => False,
10494 First => (Empty => True),
10497 In that example, the compiler creates a PAD type for component First,
10498 whose size is constant, and then positions the component After just
10499 right after it. The offset of component After is therefore constant
10502 The debugger computes the position of each field based on an algorithm
10503 that uses, among other things, the actual position and size of the field
10504 preceding it. Let's now imagine that the user is trying to print
10505 the value of My_Container. If the type fixing was recursive, we would
10506 end up computing the offset of field After based on the size of the
10507 fixed version of field First. And since in our example First has
10508 only one actual field, the size of the fixed type is actually smaller
10509 than the amount of space allocated to that field, and thus we would
10510 compute the wrong offset of field After.
10512 To make things more complicated, we need to watch out for dynamic
10513 components of variant records (identified by the ___XVL suffix in
10514 the component name). Even if the target type is a PAD type, the size
10515 of that type might not be statically known. So the PAD type needs
10516 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10517 we might end up with the wrong size for our component. This can be
10518 observed with the following type declarations:
10520 type Octal is new Integer range 0 .. 7;
10521 type Octal_Array is array (Positive range <>) of Octal;
10522 pragma Pack (Octal_Array);
10524 type Octal_Buffer (Size : Positive) is record
10525 Buffer : Octal_Array (1 .. Size);
10529 In that case, Buffer is a PAD type whose size is unset and needs
10530 to be computed by fixing the unwrapped type.
10532 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10533 ----------------------------------------------------------
10535 Lastly, when should the sub-elements of an entity that remained unfixed
10536 thus far, be actually fixed?
10538 The answer is: Only when referencing that element. For instance
10539 when selecting one component of a record, this specific component
10540 should be fixed at that point in time. Or when printing the value
10541 of a record, each component should be fixed before its value gets
10542 printed. Similarly for arrays, the element of the array should be
10543 fixed when printing each element of the array, or when extracting
10544 one element out of that array. On the other hand, fixing should
10545 not be performed on the elements when taking a slice of an array!
10547 Note that one of the side effects of miscomputing the offset and
10548 size of each field is that we end up also miscomputing the size
10549 of the containing type. This can have adverse results when computing
10550 the value of an entity. GDB fetches the value of an entity based
10551 on the size of its type, and thus a wrong size causes GDB to fetch
10552 the wrong amount of memory. In the case where the computed size is
10553 too small, GDB fetches too little data to print the value of our
10554 entity. Results in this case are unpredictable, as we usually read
10555 past the buffer containing the data =:-o. */
10557 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10558 for that subexpression cast to TO_TYPE. Advance *POS over the
10562 ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10563 enum noside noside, struct type *to_type)
10567 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10568 || exp->elts[pc].opcode == OP_VAR_VALUE)
10573 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10575 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10576 return value_zero (to_type, not_lval);
10578 val = evaluate_var_msym_value (noside,
10579 exp->elts[pc + 1].objfile,
10580 exp->elts[pc + 2].msymbol);
10583 val = evaluate_var_value (noside,
10584 exp->elts[pc + 1].block,
10585 exp->elts[pc + 2].symbol);
10587 if (noside == EVAL_SKIP)
10588 return eval_skip_value (exp);
10590 val = ada_value_cast (to_type, val);
10592 /* Follow the Ada language semantics that do not allow taking
10593 an address of the result of a cast (view conversion in Ada). */
10594 if (VALUE_LVAL (val) == lval_memory)
10596 if (value_lazy (val))
10597 value_fetch_lazy (val);
10598 VALUE_LVAL (val) = not_lval;
10603 value *val = evaluate_subexp (to_type, exp, pos, noside);
10604 if (noside == EVAL_SKIP)
10605 return eval_skip_value (exp);
10606 return ada_value_cast (to_type, val);
10609 /* Implement the evaluate_exp routine in the exp_descriptor structure
10610 for the Ada language. */
10612 static struct value *
10613 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
10614 int *pos, enum noside noside)
10616 enum exp_opcode op;
10620 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10623 struct value **argvec;
10627 op = exp->elts[pc].opcode;
10633 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10635 if (noside == EVAL_NORMAL)
10636 arg1 = unwrap_value (arg1);
10638 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10639 then we need to perform the conversion manually, because
10640 evaluate_subexp_standard doesn't do it. This conversion is
10641 necessary in Ada because the different kinds of float/fixed
10642 types in Ada have different representations.
10644 Similarly, we need to perform the conversion from OP_LONG
10646 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
10647 arg1 = ada_value_cast (expect_type, arg1);
10653 struct value *result;
10656 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10657 /* The result type will have code OP_STRING, bashed there from
10658 OP_ARRAY. Bash it back. */
10659 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10660 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
10666 type = exp->elts[pc + 1].type;
10667 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
10671 type = exp->elts[pc + 1].type;
10672 return ada_evaluate_subexp (type, exp, pos, noside);
10675 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10676 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10678 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10679 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10681 return ada_value_assign (arg1, arg1);
10683 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10684 except if the lhs of our assignment is a convenience variable.
10685 In the case of assigning to a convenience variable, the lhs
10686 should be exactly the result of the evaluation of the rhs. */
10687 type = value_type (arg1);
10688 if (VALUE_LVAL (arg1) == lval_internalvar)
10690 arg2 = evaluate_subexp (type, exp, pos, noside);
10691 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10693 if (ada_is_fixed_point_type (value_type (arg1)))
10694 arg2 = cast_to_fixed (value_type (arg1), arg2);
10695 else if (ada_is_fixed_point_type (value_type (arg2)))
10697 (_("Fixed-point values must be assigned to fixed-point variables"));
10699 arg2 = coerce_for_assign (value_type (arg1), arg2);
10700 return ada_value_assign (arg1, arg2);
10703 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10704 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10705 if (noside == EVAL_SKIP)
10707 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10708 return (value_from_longest
10709 (value_type (arg1),
10710 value_as_long (arg1) + value_as_long (arg2)));
10711 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10712 return (value_from_longest
10713 (value_type (arg2),
10714 value_as_long (arg1) + value_as_long (arg2)));
10715 if ((ada_is_fixed_point_type (value_type (arg1))
10716 || ada_is_fixed_point_type (value_type (arg2)))
10717 && value_type (arg1) != value_type (arg2))
10718 error (_("Operands of fixed-point addition must have the same type"));
10719 /* Do the addition, and cast the result to the type of the first
10720 argument. We cannot cast the result to a reference type, so if
10721 ARG1 is a reference type, find its underlying type. */
10722 type = value_type (arg1);
10723 while (TYPE_CODE (type) == TYPE_CODE_REF)
10724 type = TYPE_TARGET_TYPE (type);
10725 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10726 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
10729 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10730 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10731 if (noside == EVAL_SKIP)
10733 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10734 return (value_from_longest
10735 (value_type (arg1),
10736 value_as_long (arg1) - value_as_long (arg2)));
10737 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10738 return (value_from_longest
10739 (value_type (arg2),
10740 value_as_long (arg1) - value_as_long (arg2)));
10741 if ((ada_is_fixed_point_type (value_type (arg1))
10742 || ada_is_fixed_point_type (value_type (arg2)))
10743 && value_type (arg1) != value_type (arg2))
10744 error (_("Operands of fixed-point subtraction "
10745 "must have the same type"));
10746 /* Do the substraction, and cast the result to the type of the first
10747 argument. We cannot cast the result to a reference type, so if
10748 ARG1 is a reference type, find its underlying type. */
10749 type = value_type (arg1);
10750 while (TYPE_CODE (type) == TYPE_CODE_REF)
10751 type = TYPE_TARGET_TYPE (type);
10752 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10753 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
10759 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10760 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10761 if (noside == EVAL_SKIP)
10763 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10765 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10766 return value_zero (value_type (arg1), not_lval);
10770 type = builtin_type (exp->gdbarch)->builtin_double;
10771 if (ada_is_fixed_point_type (value_type (arg1)))
10772 arg1 = cast_from_fixed (type, arg1);
10773 if (ada_is_fixed_point_type (value_type (arg2)))
10774 arg2 = cast_from_fixed (type, arg2);
10775 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10776 return ada_value_binop (arg1, arg2, op);
10780 case BINOP_NOTEQUAL:
10781 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10782 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
10783 if (noside == EVAL_SKIP)
10785 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10789 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10790 tem = ada_value_equal (arg1, arg2);
10792 if (op == BINOP_NOTEQUAL)
10794 type = language_bool_type (exp->language_defn, exp->gdbarch);
10795 return value_from_longest (type, (LONGEST) tem);
10798 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10799 if (noside == EVAL_SKIP)
10801 else if (ada_is_fixed_point_type (value_type (arg1)))
10802 return value_cast (value_type (arg1), value_neg (arg1));
10805 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10806 return value_neg (arg1);
10809 case BINOP_LOGICAL_AND:
10810 case BINOP_LOGICAL_OR:
10811 case UNOP_LOGICAL_NOT:
10816 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10817 type = language_bool_type (exp->language_defn, exp->gdbarch);
10818 return value_cast (type, val);
10821 case BINOP_BITWISE_AND:
10822 case BINOP_BITWISE_IOR:
10823 case BINOP_BITWISE_XOR:
10827 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10829 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10831 return value_cast (value_type (arg1), val);
10837 if (noside == EVAL_SKIP)
10843 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
10844 /* Only encountered when an unresolved symbol occurs in a
10845 context other than a function call, in which case, it is
10847 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10848 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
10850 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10852 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
10853 /* Check to see if this is a tagged type. We also need to handle
10854 the case where the type is a reference to a tagged type, but
10855 we have to be careful to exclude pointers to tagged types.
10856 The latter should be shown as usual (as a pointer), whereas
10857 a reference should mostly be transparent to the user. */
10858 if (ada_is_tagged_type (type, 0)
10859 || (TYPE_CODE (type) == TYPE_CODE_REF
10860 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10862 /* Tagged types are a little special in the fact that the real
10863 type is dynamic and can only be determined by inspecting the
10864 object's tag. This means that we need to get the object's
10865 value first (EVAL_NORMAL) and then extract the actual object
10868 Note that we cannot skip the final step where we extract
10869 the object type from its tag, because the EVAL_NORMAL phase
10870 results in dynamic components being resolved into fixed ones.
10871 This can cause problems when trying to print the type
10872 description of tagged types whose parent has a dynamic size:
10873 We use the type name of the "_parent" component in order
10874 to print the name of the ancestor type in the type description.
10875 If that component had a dynamic size, the resolution into
10876 a fixed type would result in the loss of that type name,
10877 thus preventing us from printing the name of the ancestor
10878 type in the type description. */
10879 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10881 if (TYPE_CODE (type) != TYPE_CODE_REF)
10883 struct type *actual_type;
10885 actual_type = type_from_tag (ada_value_tag (arg1));
10886 if (actual_type == NULL)
10887 /* If, for some reason, we were unable to determine
10888 the actual type from the tag, then use the static
10889 approximation that we just computed as a fallback.
10890 This can happen if the debugging information is
10891 incomplete, for instance. */
10892 actual_type = type;
10893 return value_zero (actual_type, not_lval);
10897 /* In the case of a ref, ada_coerce_ref takes care
10898 of determining the actual type. But the evaluation
10899 should return a ref as it should be valid to ask
10900 for its address; so rebuild a ref after coerce. */
10901 arg1 = ada_coerce_ref (arg1);
10902 return value_ref (arg1, TYPE_CODE_REF);
10906 /* Records and unions for which GNAT encodings have been
10907 generated need to be statically fixed as well.
10908 Otherwise, non-static fixing produces a type where
10909 all dynamic properties are removed, which prevents "ptype"
10910 from being able to completely describe the type.
10911 For instance, a case statement in a variant record would be
10912 replaced by the relevant components based on the actual
10913 value of the discriminants. */
10914 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10915 && dynamic_template_type (type) != NULL)
10916 || (TYPE_CODE (type) == TYPE_CODE_UNION
10917 && ada_find_parallel_type (type, "___XVU") != NULL))
10920 return value_zero (to_static_fixed_type (type), not_lval);
10924 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10925 return ada_to_fixed_value (arg1);
10930 /* Allocate arg vector, including space for the function to be
10931 called in argvec[0] and a terminating NULL. */
10932 nargs = longest_to_int (exp->elts[pc + 1].longconst);
10933 argvec = XALLOCAVEC (struct value *, nargs + 2);
10935 if (exp->elts[*pos].opcode == OP_VAR_VALUE
10936 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
10937 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10938 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10941 for (tem = 0; tem <= nargs; tem += 1)
10942 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10945 if (noside == EVAL_SKIP)
10949 if (ada_is_constrained_packed_array_type
10950 (desc_base_type (value_type (argvec[0]))))
10951 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
10952 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10953 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10954 /* This is a packed array that has already been fixed, and
10955 therefore already coerced to a simple array. Nothing further
10958 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10960 /* Make sure we dereference references so that all the code below
10961 feels like it's really handling the referenced value. Wrapping
10962 types (for alignment) may be there, so make sure we strip them as
10964 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10966 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10967 && VALUE_LVAL (argvec[0]) == lval_memory)
10968 argvec[0] = value_addr (argvec[0]);
10970 type = ada_check_typedef (value_type (argvec[0]));
10972 /* Ada allows us to implicitly dereference arrays when subscripting
10973 them. So, if this is an array typedef (encoding use for array
10974 access types encoded as fat pointers), strip it now. */
10975 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10976 type = ada_typedef_target_type (type);
10978 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10980 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
10982 case TYPE_CODE_FUNC:
10983 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10985 case TYPE_CODE_ARRAY:
10987 case TYPE_CODE_STRUCT:
10988 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10989 argvec[0] = ada_value_ind (argvec[0]);
10990 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10993 error (_("cannot subscript or call something of type `%s'"),
10994 ada_type_name (value_type (argvec[0])));
10999 switch (TYPE_CODE (type))
11001 case TYPE_CODE_FUNC:
11002 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11004 if (TYPE_TARGET_TYPE (type) == NULL)
11005 error_call_unknown_return_type (NULL);
11006 return allocate_value (TYPE_TARGET_TYPE (type));
11008 return call_function_by_hand (argvec[0], NULL, nargs, argvec + 1);
11009 case TYPE_CODE_INTERNAL_FUNCTION:
11010 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11011 /* We don't know anything about what the internal
11012 function might return, but we have to return
11014 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11017 return call_internal_function (exp->gdbarch, exp->language_defn,
11018 argvec[0], nargs, argvec + 1);
11020 case TYPE_CODE_STRUCT:
11024 arity = ada_array_arity (type);
11025 type = ada_array_element_type (type, nargs);
11027 error (_("cannot subscript or call a record"));
11028 if (arity != nargs)
11029 error (_("wrong number of subscripts; expecting %d"), arity);
11030 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11031 return value_zero (ada_aligned_type (type), lval_memory);
11033 unwrap_value (ada_value_subscript
11034 (argvec[0], nargs, argvec + 1));
11036 case TYPE_CODE_ARRAY:
11037 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11039 type = ada_array_element_type (type, nargs);
11041 error (_("element type of array unknown"));
11043 return value_zero (ada_aligned_type (type), lval_memory);
11046 unwrap_value (ada_value_subscript
11047 (ada_coerce_to_simple_array (argvec[0]),
11048 nargs, argvec + 1));
11049 case TYPE_CODE_PTR: /* Pointer to array */
11050 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11052 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
11053 type = ada_array_element_type (type, nargs);
11055 error (_("element type of array unknown"));
11057 return value_zero (ada_aligned_type (type), lval_memory);
11060 unwrap_value (ada_value_ptr_subscript (argvec[0],
11061 nargs, argvec + 1));
11064 error (_("Attempt to index or call something other than an "
11065 "array or function"));
11070 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11071 struct value *low_bound_val =
11072 evaluate_subexp (NULL_TYPE, exp, pos, noside);
11073 struct value *high_bound_val =
11074 evaluate_subexp (NULL_TYPE, exp, pos, noside);
11076 LONGEST high_bound;
11078 low_bound_val = coerce_ref (low_bound_val);
11079 high_bound_val = coerce_ref (high_bound_val);
11080 low_bound = value_as_long (low_bound_val);
11081 high_bound = value_as_long (high_bound_val);
11083 if (noside == EVAL_SKIP)
11086 /* If this is a reference to an aligner type, then remove all
11088 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11089 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
11090 TYPE_TARGET_TYPE (value_type (array)) =
11091 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
11093 if (ada_is_constrained_packed_array_type (value_type (array)))
11094 error (_("cannot slice a packed array"));
11096 /* If this is a reference to an array or an array lvalue,
11097 convert to a pointer. */
11098 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11099 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
11100 && VALUE_LVAL (array) == lval_memory))
11101 array = value_addr (array);
11103 if (noside == EVAL_AVOID_SIDE_EFFECTS
11104 && ada_is_array_descriptor_type (ada_check_typedef
11105 (value_type (array))))
11106 return empty_array (ada_type_of_array (array, 0), low_bound);
11108 array = ada_coerce_to_simple_array_ptr (array);
11110 /* If we have more than one level of pointer indirection,
11111 dereference the value until we get only one level. */
11112 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
11113 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
11115 array = value_ind (array);
11117 /* Make sure we really do have an array type before going further,
11118 to avoid a SEGV when trying to get the index type or the target
11119 type later down the road if the debug info generated by
11120 the compiler is incorrect or incomplete. */
11121 if (!ada_is_simple_array_type (value_type (array)))
11122 error (_("cannot take slice of non-array"));
11124 if (TYPE_CODE (ada_check_typedef (value_type (array)))
11127 struct type *type0 = ada_check_typedef (value_type (array));
11129 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
11130 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
11133 struct type *arr_type0 =
11134 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
11136 return ada_value_slice_from_ptr (array, arr_type0,
11137 longest_to_int (low_bound),
11138 longest_to_int (high_bound));
11141 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11143 else if (high_bound < low_bound)
11144 return empty_array (value_type (array), low_bound);
11146 return ada_value_slice (array, longest_to_int (low_bound),
11147 longest_to_int (high_bound));
11150 case UNOP_IN_RANGE:
11152 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11153 type = check_typedef (exp->elts[pc + 1].type);
11155 if (noside == EVAL_SKIP)
11158 switch (TYPE_CODE (type))
11161 lim_warning (_("Membership test incompletely implemented; "
11162 "always returns true"));
11163 type = language_bool_type (exp->language_defn, exp->gdbarch);
11164 return value_from_longest (type, (LONGEST) 1);
11166 case TYPE_CODE_RANGE:
11167 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
11168 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
11169 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11170 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11171 type = language_bool_type (exp->language_defn, exp->gdbarch);
11173 value_from_longest (type,
11174 (value_less (arg1, arg3)
11175 || value_equal (arg1, arg3))
11176 && (value_less (arg2, arg1)
11177 || value_equal (arg2, arg1)));
11180 case BINOP_IN_BOUNDS:
11182 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11183 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11185 if (noside == EVAL_SKIP)
11188 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11190 type = language_bool_type (exp->language_defn, exp->gdbarch);
11191 return value_zero (type, not_lval);
11194 tem = longest_to_int (exp->elts[pc + 1].longconst);
11196 type = ada_index_type (value_type (arg2), tem, "range");
11198 type = value_type (arg1);
11200 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11201 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
11203 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11204 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11205 type = language_bool_type (exp->language_defn, exp->gdbarch);
11207 value_from_longest (type,
11208 (value_less (arg1, arg3)
11209 || value_equal (arg1, arg3))
11210 && (value_less (arg2, arg1)
11211 || value_equal (arg2, arg1)));
11213 case TERNOP_IN_RANGE:
11214 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11215 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11216 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11218 if (noside == EVAL_SKIP)
11221 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11222 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11223 type = language_bool_type (exp->language_defn, exp->gdbarch);
11225 value_from_longest (type,
11226 (value_less (arg1, arg3)
11227 || value_equal (arg1, arg3))
11228 && (value_less (arg2, arg1)
11229 || value_equal (arg2, arg1)));
11233 case OP_ATR_LENGTH:
11235 struct type *type_arg;
11237 if (exp->elts[*pos].opcode == OP_TYPE)
11239 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11241 type_arg = check_typedef (exp->elts[pc + 2].type);
11245 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11249 if (exp->elts[*pos].opcode != OP_LONG)
11250 error (_("Invalid operand to '%s"), ada_attribute_name (op));
11251 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11254 if (noside == EVAL_SKIP)
11257 if (type_arg == NULL)
11259 arg1 = ada_coerce_ref (arg1);
11261 if (ada_is_constrained_packed_array_type (value_type (arg1)))
11262 arg1 = ada_coerce_to_simple_array (arg1);
11264 if (op == OP_ATR_LENGTH)
11265 type = builtin_type (exp->gdbarch)->builtin_int;
11268 type = ada_index_type (value_type (arg1), tem,
11269 ada_attribute_name (op));
11271 type = builtin_type (exp->gdbarch)->builtin_int;
11274 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11275 return allocate_value (type);
11279 default: /* Should never happen. */
11280 error (_("unexpected attribute encountered"));
11282 return value_from_longest
11283 (type, ada_array_bound (arg1, tem, 0));
11285 return value_from_longest
11286 (type, ada_array_bound (arg1, tem, 1));
11287 case OP_ATR_LENGTH:
11288 return value_from_longest
11289 (type, ada_array_length (arg1, tem));
11292 else if (discrete_type_p (type_arg))
11294 struct type *range_type;
11295 const char *name = ada_type_name (type_arg);
11298 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
11299 range_type = to_fixed_range_type (type_arg, NULL);
11300 if (range_type == NULL)
11301 range_type = type_arg;
11305 error (_("unexpected attribute encountered"));
11307 return value_from_longest
11308 (range_type, ada_discrete_type_low_bound (range_type));
11310 return value_from_longest
11311 (range_type, ada_discrete_type_high_bound (range_type));
11312 case OP_ATR_LENGTH:
11313 error (_("the 'length attribute applies only to array types"));
11316 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
11317 error (_("unimplemented type attribute"));
11322 if (ada_is_constrained_packed_array_type (type_arg))
11323 type_arg = decode_constrained_packed_array_type (type_arg);
11325 if (op == OP_ATR_LENGTH)
11326 type = builtin_type (exp->gdbarch)->builtin_int;
11329 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11331 type = builtin_type (exp->gdbarch)->builtin_int;
11334 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11335 return allocate_value (type);
11340 error (_("unexpected attribute encountered"));
11342 low = ada_array_bound_from_type (type_arg, tem, 0);
11343 return value_from_longest (type, low);
11345 high = ada_array_bound_from_type (type_arg, tem, 1);
11346 return value_from_longest (type, high);
11347 case OP_ATR_LENGTH:
11348 low = ada_array_bound_from_type (type_arg, tem, 0);
11349 high = ada_array_bound_from_type (type_arg, tem, 1);
11350 return value_from_longest (type, high - low + 1);
11356 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11357 if (noside == EVAL_SKIP)
11360 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11361 return value_zero (ada_tag_type (arg1), not_lval);
11363 return ada_value_tag (arg1);
11367 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11368 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11369 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11370 if (noside == EVAL_SKIP)
11372 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11373 return value_zero (value_type (arg1), not_lval);
11376 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11377 return value_binop (arg1, arg2,
11378 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11381 case OP_ATR_MODULUS:
11383 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
11385 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11386 if (noside == EVAL_SKIP)
11389 if (!ada_is_modular_type (type_arg))
11390 error (_("'modulus must be applied to modular type"));
11392 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11393 ada_modulus (type_arg));
11398 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11399 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11400 if (noside == EVAL_SKIP)
11402 type = builtin_type (exp->gdbarch)->builtin_int;
11403 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11404 return value_zero (type, not_lval);
11406 return value_pos_atr (type, arg1);
11409 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11410 type = value_type (arg1);
11412 /* If the argument is a reference, then dereference its type, since
11413 the user is really asking for the size of the actual object,
11414 not the size of the pointer. */
11415 if (TYPE_CODE (type) == TYPE_CODE_REF)
11416 type = TYPE_TARGET_TYPE (type);
11418 if (noside == EVAL_SKIP)
11420 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11421 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
11423 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
11424 TARGET_CHAR_BIT * TYPE_LENGTH (type));
11427 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11428 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11429 type = exp->elts[pc + 2].type;
11430 if (noside == EVAL_SKIP)
11432 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11433 return value_zero (type, not_lval);
11435 return value_val_atr (type, arg1);
11438 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11439 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11440 if (noside == EVAL_SKIP)
11442 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11443 return value_zero (value_type (arg1), not_lval);
11446 /* For integer exponentiation operations,
11447 only promote the first argument. */
11448 if (is_integral_type (value_type (arg2)))
11449 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11451 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11453 return value_binop (arg1, arg2, op);
11457 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11458 if (noside == EVAL_SKIP)
11464 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11465 if (noside == EVAL_SKIP)
11467 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11468 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
11469 return value_neg (arg1);
11474 preeval_pos = *pos;
11475 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11476 if (noside == EVAL_SKIP)
11478 type = ada_check_typedef (value_type (arg1));
11479 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11481 if (ada_is_array_descriptor_type (type))
11482 /* GDB allows dereferencing GNAT array descriptors. */
11484 struct type *arrType = ada_type_of_array (arg1, 0);
11486 if (arrType == NULL)
11487 error (_("Attempt to dereference null array pointer."));
11488 return value_at_lazy (arrType, 0);
11490 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11491 || TYPE_CODE (type) == TYPE_CODE_REF
11492 /* In C you can dereference an array to get the 1st elt. */
11493 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
11495 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11496 only be determined by inspecting the object's tag.
11497 This means that we need to evaluate completely the
11498 expression in order to get its type. */
11500 if ((TYPE_CODE (type) == TYPE_CODE_REF
11501 || TYPE_CODE (type) == TYPE_CODE_PTR)
11502 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11504 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11506 type = value_type (ada_value_ind (arg1));
11510 type = to_static_fixed_type
11512 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11514 ada_ensure_varsize_limit (type);
11515 return value_zero (type, lval_memory);
11517 else if (TYPE_CODE (type) == TYPE_CODE_INT)
11519 /* GDB allows dereferencing an int. */
11520 if (expect_type == NULL)
11521 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11526 to_static_fixed_type (ada_aligned_type (expect_type));
11527 return value_zero (expect_type, lval_memory);
11531 error (_("Attempt to take contents of a non-pointer value."));
11533 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
11534 type = ada_check_typedef (value_type (arg1));
11536 if (TYPE_CODE (type) == TYPE_CODE_INT)
11537 /* GDB allows dereferencing an int. If we were given
11538 the expect_type, then use that as the target type.
11539 Otherwise, assume that the target type is an int. */
11541 if (expect_type != NULL)
11542 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11545 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11546 (CORE_ADDR) value_as_address (arg1));
11549 if (ada_is_array_descriptor_type (type))
11550 /* GDB allows dereferencing GNAT array descriptors. */
11551 return ada_coerce_to_simple_array (arg1);
11553 return ada_value_ind (arg1);
11555 case STRUCTOP_STRUCT:
11556 tem = longest_to_int (exp->elts[pc + 1].longconst);
11557 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
11558 preeval_pos = *pos;
11559 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11560 if (noside == EVAL_SKIP)
11562 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11564 struct type *type1 = value_type (arg1);
11566 if (ada_is_tagged_type (type1, 1))
11568 type = ada_lookup_struct_elt_type (type1,
11569 &exp->elts[pc + 2].string,
11572 /* If the field is not found, check if it exists in the
11573 extension of this object's type. This means that we
11574 need to evaluate completely the expression. */
11578 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11580 arg1 = ada_value_struct_elt (arg1,
11581 &exp->elts[pc + 2].string,
11583 arg1 = unwrap_value (arg1);
11584 type = value_type (ada_to_fixed_value (arg1));
11589 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
11592 return value_zero (ada_aligned_type (type), lval_memory);
11596 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11597 arg1 = unwrap_value (arg1);
11598 return ada_to_fixed_value (arg1);
11602 /* The value is not supposed to be used. This is here to make it
11603 easier to accommodate expressions that contain types. */
11605 if (noside == EVAL_SKIP)
11607 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11608 return allocate_value (exp->elts[pc + 1].type);
11610 error (_("Attempt to use a type name as an expression"));
11615 case OP_DISCRETE_RANGE:
11616 case OP_POSITIONAL:
11618 if (noside == EVAL_NORMAL)
11622 error (_("Undefined name, ambiguous name, or renaming used in "
11623 "component association: %s."), &exp->elts[pc+2].string);
11625 error (_("Aggregates only allowed on the right of an assignment"));
11627 internal_error (__FILE__, __LINE__,
11628 _("aggregate apparently mangled"));
11631 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11633 for (tem = 0; tem < nargs; tem += 1)
11634 ada_evaluate_subexp (NULL, exp, pos, noside);
11639 return eval_skip_value (exp);
11645 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11646 type name that encodes the 'small and 'delta information.
11647 Otherwise, return NULL. */
11649 static const char *
11650 fixed_type_info (struct type *type)
11652 const char *name = ada_type_name (type);
11653 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11655 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11657 const char *tail = strstr (name, "___XF_");
11664 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11665 return fixed_type_info (TYPE_TARGET_TYPE (type));
11670 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11673 ada_is_fixed_point_type (struct type *type)
11675 return fixed_type_info (type) != NULL;
11678 /* Return non-zero iff TYPE represents a System.Address type. */
11681 ada_is_system_address_type (struct type *type)
11683 return (TYPE_NAME (type)
11684 && strcmp (TYPE_NAME (type), "system__address") == 0);
11687 /* Assuming that TYPE is the representation of an Ada fixed-point
11688 type, return the target floating-point type to be used to represent
11689 of this type during internal computation. */
11691 static struct type *
11692 ada_scaling_type (struct type *type)
11694 return builtin_type (get_type_arch (type))->builtin_long_double;
11697 /* Assuming that TYPE is the representation of an Ada fixed-point
11698 type, return its delta, or NULL if the type is malformed and the
11699 delta cannot be determined. */
11702 ada_delta (struct type *type)
11704 const char *encoding = fixed_type_info (type);
11705 struct type *scale_type = ada_scaling_type (type);
11707 long long num, den;
11709 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11712 return value_binop (value_from_longest (scale_type, num),
11713 value_from_longest (scale_type, den), BINOP_DIV);
11716 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11717 factor ('SMALL value) associated with the type. */
11720 ada_scaling_factor (struct type *type)
11722 const char *encoding = fixed_type_info (type);
11723 struct type *scale_type = ada_scaling_type (type);
11725 long long num0, den0, num1, den1;
11728 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
11729 &num0, &den0, &num1, &den1);
11732 return value_from_longest (scale_type, 1);
11734 return value_binop (value_from_longest (scale_type, num1),
11735 value_from_longest (scale_type, den1), BINOP_DIV);
11737 return value_binop (value_from_longest (scale_type, num0),
11738 value_from_longest (scale_type, den0), BINOP_DIV);
11745 /* Scan STR beginning at position K for a discriminant name, and
11746 return the value of that discriminant field of DVAL in *PX. If
11747 PNEW_K is not null, put the position of the character beyond the
11748 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11749 not alter *PX and *PNEW_K if unsuccessful. */
11752 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11755 static char *bound_buffer = NULL;
11756 static size_t bound_buffer_len = 0;
11757 const char *pstart, *pend, *bound;
11758 struct value *bound_val;
11760 if (dval == NULL || str == NULL || str[k] == '\0')
11764 pend = strstr (pstart, "__");
11768 k += strlen (bound);
11772 int len = pend - pstart;
11774 /* Strip __ and beyond. */
11775 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11776 strncpy (bound_buffer, pstart, len);
11777 bound_buffer[len] = '\0';
11779 bound = bound_buffer;
11783 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11784 if (bound_val == NULL)
11787 *px = value_as_long (bound_val);
11788 if (pnew_k != NULL)
11793 /* Value of variable named NAME in the current environment. If
11794 no such variable found, then if ERR_MSG is null, returns 0, and
11795 otherwise causes an error with message ERR_MSG. */
11797 static struct value *
11798 get_var_value (const char *name, const char *err_msg)
11800 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
11802 struct block_symbol *syms;
11803 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11804 get_selected_block (0),
11805 VAR_DOMAIN, &syms, 1);
11806 struct cleanup *old_chain = make_cleanup (xfree, syms);
11810 do_cleanups (old_chain);
11811 if (err_msg == NULL)
11814 error (("%s"), err_msg);
11817 struct value *result = value_of_variable (syms[0].symbol, syms[0].block);
11818 do_cleanups (old_chain);
11822 /* Value of integer variable named NAME in the current environment.
11823 If no such variable is found, returns false. Otherwise, sets VALUE
11824 to the variable's value and returns true. */
11827 get_int_var_value (const char *name, LONGEST &value)
11829 struct value *var_val = get_var_value (name, 0);
11834 value = value_as_long (var_val);
11839 /* Return a range type whose base type is that of the range type named
11840 NAME in the current environment, and whose bounds are calculated
11841 from NAME according to the GNAT range encoding conventions.
11842 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11843 corresponding range type from debug information; fall back to using it
11844 if symbol lookup fails. If a new type must be created, allocate it
11845 like ORIG_TYPE was. The bounds information, in general, is encoded
11846 in NAME, the base type given in the named range type. */
11848 static struct type *
11849 to_fixed_range_type (struct type *raw_type, struct value *dval)
11852 struct type *base_type;
11853 const char *subtype_info;
11855 gdb_assert (raw_type != NULL);
11856 gdb_assert (TYPE_NAME (raw_type) != NULL);
11858 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
11859 base_type = TYPE_TARGET_TYPE (raw_type);
11861 base_type = raw_type;
11863 name = TYPE_NAME (raw_type);
11864 subtype_info = strstr (name, "___XD");
11865 if (subtype_info == NULL)
11867 LONGEST L = ada_discrete_type_low_bound (raw_type);
11868 LONGEST U = ada_discrete_type_high_bound (raw_type);
11870 if (L < INT_MIN || U > INT_MAX)
11873 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11878 static char *name_buf = NULL;
11879 static size_t name_len = 0;
11880 int prefix_len = subtype_info - name;
11883 const char *bounds_str;
11886 GROW_VECT (name_buf, name_len, prefix_len + 5);
11887 strncpy (name_buf, name, prefix_len);
11888 name_buf[prefix_len] = '\0';
11891 bounds_str = strchr (subtype_info, '_');
11894 if (*subtype_info == 'L')
11896 if (!ada_scan_number (bounds_str, n, &L, &n)
11897 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11899 if (bounds_str[n] == '_')
11901 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
11907 strcpy (name_buf + prefix_len, "___L");
11908 if (!get_int_var_value (name_buf, L))
11910 lim_warning (_("Unknown lower bound, using 1."));
11915 if (*subtype_info == 'U')
11917 if (!ada_scan_number (bounds_str, n, &U, &n)
11918 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11923 strcpy (name_buf + prefix_len, "___U");
11924 if (!get_int_var_value (name_buf, U))
11926 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11931 type = create_static_range_type (alloc_type_copy (raw_type),
11933 /* create_static_range_type alters the resulting type's length
11934 to match the size of the base_type, which is not what we want.
11935 Set it back to the original range type's length. */
11936 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11937 TYPE_NAME (type) = name;
11942 /* True iff NAME is the name of a range type. */
11945 ada_is_range_type_name (const char *name)
11947 return (name != NULL && strstr (name, "___XD"));
11951 /* Modular types */
11953 /* True iff TYPE is an Ada modular type. */
11956 ada_is_modular_type (struct type *type)
11958 struct type *subranged_type = get_base_type (type);
11960 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
11961 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
11962 && TYPE_UNSIGNED (subranged_type));
11965 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11968 ada_modulus (struct type *type)
11970 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
11974 /* Ada exception catchpoint support:
11975 ---------------------------------
11977 We support 3 kinds of exception catchpoints:
11978 . catchpoints on Ada exceptions
11979 . catchpoints on unhandled Ada exceptions
11980 . catchpoints on failed assertions
11982 Exceptions raised during failed assertions, or unhandled exceptions
11983 could perfectly be caught with the general catchpoint on Ada exceptions.
11984 However, we can easily differentiate these two special cases, and having
11985 the option to distinguish these two cases from the rest can be useful
11986 to zero-in on certain situations.
11988 Exception catchpoints are a specialized form of breakpoint,
11989 since they rely on inserting breakpoints inside known routines
11990 of the GNAT runtime. The implementation therefore uses a standard
11991 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11994 Support in the runtime for exception catchpoints have been changed
11995 a few times already, and these changes affect the implementation
11996 of these catchpoints. In order to be able to support several
11997 variants of the runtime, we use a sniffer that will determine
11998 the runtime variant used by the program being debugged. */
12000 /* Ada's standard exceptions.
12002 The Ada 83 standard also defined Numeric_Error. But there so many
12003 situations where it was unclear from the Ada 83 Reference Manual
12004 (RM) whether Constraint_Error or Numeric_Error should be raised,
12005 that the ARG (Ada Rapporteur Group) eventually issued a Binding
12006 Interpretation saying that anytime the RM says that Numeric_Error
12007 should be raised, the implementation may raise Constraint_Error.
12008 Ada 95 went one step further and pretty much removed Numeric_Error
12009 from the list of standard exceptions (it made it a renaming of
12010 Constraint_Error, to help preserve compatibility when compiling
12011 an Ada83 compiler). As such, we do not include Numeric_Error from
12012 this list of standard exceptions. */
12014 static const char *standard_exc[] = {
12015 "constraint_error",
12021 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
12023 /* A structure that describes how to support exception catchpoints
12024 for a given executable. */
12026 struct exception_support_info
12028 /* The name of the symbol to break on in order to insert
12029 a catchpoint on exceptions. */
12030 const char *catch_exception_sym;
12032 /* The name of the symbol to break on in order to insert
12033 a catchpoint on unhandled exceptions. */
12034 const char *catch_exception_unhandled_sym;
12036 /* The name of the symbol to break on in order to insert
12037 a catchpoint on failed assertions. */
12038 const char *catch_assert_sym;
12040 /* The name of the symbol to break on in order to insert
12041 a catchpoint on exception handling. */
12042 const char *catch_handlers_sym;
12044 /* Assuming that the inferior just triggered an unhandled exception
12045 catchpoint, this function is responsible for returning the address
12046 in inferior memory where the name of that exception is stored.
12047 Return zero if the address could not be computed. */
12048 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
12051 static CORE_ADDR ada_unhandled_exception_name_addr (void);
12052 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
12054 /* The following exception support info structure describes how to
12055 implement exception catchpoints with the latest version of the
12056 Ada runtime (as of 2007-03-06). */
12058 static const struct exception_support_info default_exception_support_info =
12060 "__gnat_debug_raise_exception", /* catch_exception_sym */
12061 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12062 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
12063 "__gnat_begin_handler", /* catch_handlers_sym */
12064 ada_unhandled_exception_name_addr
12067 /* The following exception support info structure describes how to
12068 implement exception catchpoints with a slightly older version
12069 of the Ada runtime. */
12071 static const struct exception_support_info exception_support_info_fallback =
12073 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
12074 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12075 "system__assertions__raise_assert_failure", /* catch_assert_sym */
12076 "__gnat_begin_handler", /* catch_handlers_sym */
12077 ada_unhandled_exception_name_addr_from_raise
12080 /* Return nonzero if we can detect the exception support routines
12081 described in EINFO.
12083 This function errors out if an abnormal situation is detected
12084 (for instance, if we find the exception support routines, but
12085 that support is found to be incomplete). */
12088 ada_has_this_exception_support (const struct exception_support_info *einfo)
12090 struct symbol *sym;
12092 /* The symbol we're looking up is provided by a unit in the GNAT runtime
12093 that should be compiled with debugging information. As a result, we
12094 expect to find that symbol in the symtabs. */
12096 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
12099 /* Perhaps we did not find our symbol because the Ada runtime was
12100 compiled without debugging info, or simply stripped of it.
12101 It happens on some GNU/Linux distributions for instance, where
12102 users have to install a separate debug package in order to get
12103 the runtime's debugging info. In that situation, let the user
12104 know why we cannot insert an Ada exception catchpoint.
12106 Note: Just for the purpose of inserting our Ada exception
12107 catchpoint, we could rely purely on the associated minimal symbol.
12108 But we would be operating in degraded mode anyway, since we are
12109 still lacking the debugging info needed later on to extract
12110 the name of the exception being raised (this name is printed in
12111 the catchpoint message, and is also used when trying to catch
12112 a specific exception). We do not handle this case for now. */
12113 struct bound_minimal_symbol msym
12114 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
12116 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
12117 error (_("Your Ada runtime appears to be missing some debugging "
12118 "information.\nCannot insert Ada exception catchpoint "
12119 "in this configuration."));
12124 /* Make sure that the symbol we found corresponds to a function. */
12126 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12127 error (_("Symbol \"%s\" is not a function (class = %d)"),
12128 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
12133 /* Inspect the Ada runtime and determine which exception info structure
12134 should be used to provide support for exception catchpoints.
12136 This function will always set the per-inferior exception_info,
12137 or raise an error. */
12140 ada_exception_support_info_sniffer (void)
12142 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12144 /* If the exception info is already known, then no need to recompute it. */
12145 if (data->exception_info != NULL)
12148 /* Check the latest (default) exception support info. */
12149 if (ada_has_this_exception_support (&default_exception_support_info))
12151 data->exception_info = &default_exception_support_info;
12155 /* Try our fallback exception suport info. */
12156 if (ada_has_this_exception_support (&exception_support_info_fallback))
12158 data->exception_info = &exception_support_info_fallback;
12162 /* Sometimes, it is normal for us to not be able to find the routine
12163 we are looking for. This happens when the program is linked with
12164 the shared version of the GNAT runtime, and the program has not been
12165 started yet. Inform the user of these two possible causes if
12168 if (ada_update_initial_language (language_unknown) != language_ada)
12169 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
12171 /* If the symbol does not exist, then check that the program is
12172 already started, to make sure that shared libraries have been
12173 loaded. If it is not started, this may mean that the symbol is
12174 in a shared library. */
12176 if (ptid_get_pid (inferior_ptid) == 0)
12177 error (_("Unable to insert catchpoint. Try to start the program first."));
12179 /* At this point, we know that we are debugging an Ada program and
12180 that the inferior has been started, but we still are not able to
12181 find the run-time symbols. That can mean that we are in
12182 configurable run time mode, or that a-except as been optimized
12183 out by the linker... In any case, at this point it is not worth
12184 supporting this feature. */
12186 error (_("Cannot insert Ada exception catchpoints in this configuration."));
12189 /* True iff FRAME is very likely to be that of a function that is
12190 part of the runtime system. This is all very heuristic, but is
12191 intended to be used as advice as to what frames are uninteresting
12195 is_known_support_routine (struct frame_info *frame)
12197 enum language func_lang;
12199 const char *fullname;
12201 /* If this code does not have any debugging information (no symtab),
12202 This cannot be any user code. */
12204 symtab_and_line sal = find_frame_sal (frame);
12205 if (sal.symtab == NULL)
12208 /* If there is a symtab, but the associated source file cannot be
12209 located, then assume this is not user code: Selecting a frame
12210 for which we cannot display the code would not be very helpful
12211 for the user. This should also take care of case such as VxWorks
12212 where the kernel has some debugging info provided for a few units. */
12214 fullname = symtab_to_fullname (sal.symtab);
12215 if (access (fullname, R_OK) != 0)
12218 /* Check the unit filename againt the Ada runtime file naming.
12219 We also check the name of the objfile against the name of some
12220 known system libraries that sometimes come with debugging info
12223 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12225 re_comp (known_runtime_file_name_patterns[i]);
12226 if (re_exec (lbasename (sal.symtab->filename)))
12228 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12229 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
12233 /* Check whether the function is a GNAT-generated entity. */
12235 gdb::unique_xmalloc_ptr<char> func_name
12236 = find_frame_funname (frame, &func_lang, NULL);
12237 if (func_name == NULL)
12240 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12242 re_comp (known_auxiliary_function_name_patterns[i]);
12243 if (re_exec (func_name.get ()))
12250 /* Find the first frame that contains debugging information and that is not
12251 part of the Ada run-time, starting from FI and moving upward. */
12254 ada_find_printable_frame (struct frame_info *fi)
12256 for (; fi != NULL; fi = get_prev_frame (fi))
12258 if (!is_known_support_routine (fi))
12267 /* Assuming that the inferior just triggered an unhandled exception
12268 catchpoint, return the address in inferior memory where the name
12269 of the exception is stored.
12271 Return zero if the address could not be computed. */
12274 ada_unhandled_exception_name_addr (void)
12276 return parse_and_eval_address ("e.full_name");
12279 /* Same as ada_unhandled_exception_name_addr, except that this function
12280 should be used when the inferior uses an older version of the runtime,
12281 where the exception name needs to be extracted from a specific frame
12282 several frames up in the callstack. */
12285 ada_unhandled_exception_name_addr_from_raise (void)
12288 struct frame_info *fi;
12289 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12291 /* To determine the name of this exception, we need to select
12292 the frame corresponding to RAISE_SYM_NAME. This frame is
12293 at least 3 levels up, so we simply skip the first 3 frames
12294 without checking the name of their associated function. */
12295 fi = get_current_frame ();
12296 for (frame_level = 0; frame_level < 3; frame_level += 1)
12298 fi = get_prev_frame (fi);
12302 enum language func_lang;
12304 gdb::unique_xmalloc_ptr<char> func_name
12305 = find_frame_funname (fi, &func_lang, NULL);
12306 if (func_name != NULL)
12308 if (strcmp (func_name.get (),
12309 data->exception_info->catch_exception_sym) == 0)
12310 break; /* We found the frame we were looking for... */
12311 fi = get_prev_frame (fi);
12319 return parse_and_eval_address ("id.full_name");
12322 /* Assuming the inferior just triggered an Ada exception catchpoint
12323 (of any type), return the address in inferior memory where the name
12324 of the exception is stored, if applicable.
12326 Assumes the selected frame is the current frame.
12328 Return zero if the address could not be computed, or if not relevant. */
12331 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
12332 struct breakpoint *b)
12334 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12338 case ada_catch_exception:
12339 return (parse_and_eval_address ("e.full_name"));
12342 case ada_catch_exception_unhandled:
12343 return data->exception_info->unhandled_exception_name_addr ();
12346 case ada_catch_handlers:
12347 return 0; /* The runtimes does not provide access to the exception
12351 case ada_catch_assert:
12352 return 0; /* Exception name is not relevant in this case. */
12356 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12360 return 0; /* Should never be reached. */
12363 /* Assuming the inferior is stopped at an exception catchpoint,
12364 return the message which was associated to the exception, if
12365 available. Return NULL if the message could not be retrieved.
12367 The caller must xfree the string after use.
12369 Note: The exception message can be associated to an exception
12370 either through the use of the Raise_Exception function, or
12371 more simply (Ada 2005 and later), via:
12373 raise Exception_Name with "exception message";
12378 ada_exception_message_1 (void)
12380 struct value *e_msg_val;
12381 char *e_msg = NULL;
12383 struct cleanup *cleanups;
12385 /* For runtimes that support this feature, the exception message
12386 is passed as an unbounded string argument called "message". */
12387 e_msg_val = parse_and_eval ("message");
12388 if (e_msg_val == NULL)
12389 return NULL; /* Exception message not supported. */
12391 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12392 gdb_assert (e_msg_val != NULL);
12393 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12395 /* If the message string is empty, then treat it as if there was
12396 no exception message. */
12397 if (e_msg_len <= 0)
12400 e_msg = (char *) xmalloc (e_msg_len + 1);
12401 cleanups = make_cleanup (xfree, e_msg);
12402 read_memory_string (value_address (e_msg_val), e_msg, e_msg_len + 1);
12403 e_msg[e_msg_len] = '\0';
12405 discard_cleanups (cleanups);
12409 /* Same as ada_exception_message_1, except that all exceptions are
12410 contained here (returning NULL instead). */
12413 ada_exception_message (void)
12415 char *e_msg = NULL; /* Avoid a spurious uninitialized warning. */
12419 e_msg = ada_exception_message_1 ();
12421 CATCH (e, RETURN_MASK_ERROR)
12430 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12431 any error that ada_exception_name_addr_1 might cause to be thrown.
12432 When an error is intercepted, a warning with the error message is printed,
12433 and zero is returned. */
12436 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
12437 struct breakpoint *b)
12439 CORE_ADDR result = 0;
12443 result = ada_exception_name_addr_1 (ex, b);
12446 CATCH (e, RETURN_MASK_ERROR)
12448 warning (_("failed to get exception name: %s"), e.message);
12456 static char *ada_exception_catchpoint_cond_string
12457 (const char *excep_string,
12458 enum ada_exception_catchpoint_kind ex);
12460 /* Ada catchpoints.
12462 In the case of catchpoints on Ada exceptions, the catchpoint will
12463 stop the target on every exception the program throws. When a user
12464 specifies the name of a specific exception, we translate this
12465 request into a condition expression (in text form), and then parse
12466 it into an expression stored in each of the catchpoint's locations.
12467 We then use this condition to check whether the exception that was
12468 raised is the one the user is interested in. If not, then the
12469 target is resumed again. We store the name of the requested
12470 exception, in order to be able to re-set the condition expression
12471 when symbols change. */
12473 /* An instance of this type is used to represent an Ada catchpoint
12474 breakpoint location. */
12476 class ada_catchpoint_location : public bp_location
12479 ada_catchpoint_location (const bp_location_ops *ops, breakpoint *owner)
12480 : bp_location (ops, owner)
12483 /* The condition that checks whether the exception that was raised
12484 is the specific exception the user specified on catchpoint
12486 expression_up excep_cond_expr;
12489 /* Implement the DTOR method in the bp_location_ops structure for all
12490 Ada exception catchpoint kinds. */
12493 ada_catchpoint_location_dtor (struct bp_location *bl)
12495 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12497 al->excep_cond_expr.reset ();
12500 /* The vtable to be used in Ada catchpoint locations. */
12502 static const struct bp_location_ops ada_catchpoint_location_ops =
12504 ada_catchpoint_location_dtor
12507 /* An instance of this type is used to represent an Ada catchpoint. */
12509 struct ada_catchpoint : public breakpoint
12511 ~ada_catchpoint () override;
12513 /* The name of the specific exception the user specified. */
12514 char *excep_string;
12517 /* Parse the exception condition string in the context of each of the
12518 catchpoint's locations, and store them for later evaluation. */
12521 create_excep_cond_exprs (struct ada_catchpoint *c,
12522 enum ada_exception_catchpoint_kind ex)
12524 struct cleanup *old_chain;
12525 struct bp_location *bl;
12528 /* Nothing to do if there's no specific exception to catch. */
12529 if (c->excep_string == NULL)
12532 /* Same if there are no locations... */
12533 if (c->loc == NULL)
12536 /* Compute the condition expression in text form, from the specific
12537 expection we want to catch. */
12538 cond_string = ada_exception_catchpoint_cond_string (c->excep_string, ex);
12539 old_chain = make_cleanup (xfree, cond_string);
12541 /* Iterate over all the catchpoint's locations, and parse an
12542 expression for each. */
12543 for (bl = c->loc; bl != NULL; bl = bl->next)
12545 struct ada_catchpoint_location *ada_loc
12546 = (struct ada_catchpoint_location *) bl;
12549 if (!bl->shlib_disabled)
12556 exp = parse_exp_1 (&s, bl->address,
12557 block_for_pc (bl->address),
12560 CATCH (e, RETURN_MASK_ERROR)
12562 warning (_("failed to reevaluate internal exception condition "
12563 "for catchpoint %d: %s"),
12564 c->number, e.message);
12569 ada_loc->excep_cond_expr = std::move (exp);
12572 do_cleanups (old_chain);
12575 /* ada_catchpoint destructor. */
12577 ada_catchpoint::~ada_catchpoint ()
12579 xfree (this->excep_string);
12582 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12583 structure for all exception catchpoint kinds. */
12585 static struct bp_location *
12586 allocate_location_exception (enum ada_exception_catchpoint_kind ex,
12587 struct breakpoint *self)
12589 return new ada_catchpoint_location (&ada_catchpoint_location_ops, self);
12592 /* Implement the RE_SET method in the breakpoint_ops structure for all
12593 exception catchpoint kinds. */
12596 re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
12598 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12600 /* Call the base class's method. This updates the catchpoint's
12602 bkpt_breakpoint_ops.re_set (b);
12604 /* Reparse the exception conditional expressions. One for each
12606 create_excep_cond_exprs (c, ex);
12609 /* Returns true if we should stop for this breakpoint hit. If the
12610 user specified a specific exception, we only want to cause a stop
12611 if the program thrown that exception. */
12614 should_stop_exception (const struct bp_location *bl)
12616 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12617 const struct ada_catchpoint_location *ada_loc
12618 = (const struct ada_catchpoint_location *) bl;
12621 /* With no specific exception, should always stop. */
12622 if (c->excep_string == NULL)
12625 if (ada_loc->excep_cond_expr == NULL)
12627 /* We will have a NULL expression if back when we were creating
12628 the expressions, this location's had failed to parse. */
12635 struct value *mark;
12637 mark = value_mark ();
12638 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12639 value_free_to_mark (mark);
12641 CATCH (ex, RETURN_MASK_ALL)
12643 exception_fprintf (gdb_stderr, ex,
12644 _("Error in testing exception condition:\n"));
12651 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12652 for all exception catchpoint kinds. */
12655 check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12657 bs->stop = should_stop_exception (bs->bp_location_at);
12660 /* Implement the PRINT_IT method in the breakpoint_ops structure
12661 for all exception catchpoint kinds. */
12663 static enum print_stop_action
12664 print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12666 struct ui_out *uiout = current_uiout;
12667 struct breakpoint *b = bs->breakpoint_at;
12668 char *exception_message;
12670 annotate_catchpoint (b->number);
12672 if (uiout->is_mi_like_p ())
12674 uiout->field_string ("reason",
12675 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12676 uiout->field_string ("disp", bpdisp_text (b->disposition));
12679 uiout->text (b->disposition == disp_del
12680 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12681 uiout->field_int ("bkptno", b->number);
12682 uiout->text (", ");
12684 /* ada_exception_name_addr relies on the selected frame being the
12685 current frame. Need to do this here because this function may be
12686 called more than once when printing a stop, and below, we'll
12687 select the first frame past the Ada run-time (see
12688 ada_find_printable_frame). */
12689 select_frame (get_current_frame ());
12693 case ada_catch_exception:
12694 case ada_catch_exception_unhandled:
12695 case ada_catch_handlers:
12697 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12698 char exception_name[256];
12702 read_memory (addr, (gdb_byte *) exception_name,
12703 sizeof (exception_name) - 1);
12704 exception_name [sizeof (exception_name) - 1] = '\0';
12708 /* For some reason, we were unable to read the exception
12709 name. This could happen if the Runtime was compiled
12710 without debugging info, for instance. In that case,
12711 just replace the exception name by the generic string
12712 "exception" - it will read as "an exception" in the
12713 notification we are about to print. */
12714 memcpy (exception_name, "exception", sizeof ("exception"));
12716 /* In the case of unhandled exception breakpoints, we print
12717 the exception name as "unhandled EXCEPTION_NAME", to make
12718 it clearer to the user which kind of catchpoint just got
12719 hit. We used ui_out_text to make sure that this extra
12720 info does not pollute the exception name in the MI case. */
12721 if (ex == ada_catch_exception_unhandled)
12722 uiout->text ("unhandled ");
12723 uiout->field_string ("exception-name", exception_name);
12726 case ada_catch_assert:
12727 /* In this case, the name of the exception is not really
12728 important. Just print "failed assertion" to make it clearer
12729 that his program just hit an assertion-failure catchpoint.
12730 We used ui_out_text because this info does not belong in
12732 uiout->text ("failed assertion");
12736 exception_message = ada_exception_message ();
12737 if (exception_message != NULL)
12739 struct cleanup *cleanups = make_cleanup (xfree, exception_message);
12741 uiout->text (" (");
12742 uiout->field_string ("exception-message", exception_message);
12745 do_cleanups (cleanups);
12748 uiout->text (" at ");
12749 ada_find_printable_frame (get_current_frame ());
12751 return PRINT_SRC_AND_LOC;
12754 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12755 for all exception catchpoint kinds. */
12758 print_one_exception (enum ada_exception_catchpoint_kind ex,
12759 struct breakpoint *b, struct bp_location **last_loc)
12761 struct ui_out *uiout = current_uiout;
12762 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12763 struct value_print_options opts;
12765 get_user_print_options (&opts);
12766 if (opts.addressprint)
12768 annotate_field (4);
12769 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
12772 annotate_field (5);
12773 *last_loc = b->loc;
12776 case ada_catch_exception:
12777 if (c->excep_string != NULL)
12779 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12781 uiout->field_string ("what", msg);
12785 uiout->field_string ("what", "all Ada exceptions");
12789 case ada_catch_exception_unhandled:
12790 uiout->field_string ("what", "unhandled Ada exceptions");
12793 case ada_catch_handlers:
12794 if (c->excep_string != NULL)
12796 uiout->field_fmt ("what",
12797 _("`%s' Ada exception handlers"),
12801 uiout->field_string ("what", "all Ada exceptions handlers");
12804 case ada_catch_assert:
12805 uiout->field_string ("what", "failed Ada assertions");
12809 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12814 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12815 for all exception catchpoint kinds. */
12818 print_mention_exception (enum ada_exception_catchpoint_kind ex,
12819 struct breakpoint *b)
12821 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12822 struct ui_out *uiout = current_uiout;
12824 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
12825 : _("Catchpoint "));
12826 uiout->field_int ("bkptno", b->number);
12827 uiout->text (": ");
12831 case ada_catch_exception:
12832 if (c->excep_string != NULL)
12834 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12835 struct cleanup *old_chain = make_cleanup (xfree, info);
12837 uiout->text (info);
12838 do_cleanups (old_chain);
12841 uiout->text (_("all Ada exceptions"));
12844 case ada_catch_exception_unhandled:
12845 uiout->text (_("unhandled Ada exceptions"));
12848 case ada_catch_handlers:
12849 if (c->excep_string != NULL)
12852 = string_printf (_("`%s' Ada exception handlers"),
12854 uiout->text (info.c_str ());
12857 uiout->text (_("all Ada exceptions handlers"));
12860 case ada_catch_assert:
12861 uiout->text (_("failed Ada assertions"));
12865 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12870 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12871 for all exception catchpoint kinds. */
12874 print_recreate_exception (enum ada_exception_catchpoint_kind ex,
12875 struct breakpoint *b, struct ui_file *fp)
12877 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12881 case ada_catch_exception:
12882 fprintf_filtered (fp, "catch exception");
12883 if (c->excep_string != NULL)
12884 fprintf_filtered (fp, " %s", c->excep_string);
12887 case ada_catch_exception_unhandled:
12888 fprintf_filtered (fp, "catch exception unhandled");
12891 case ada_catch_handlers:
12892 fprintf_filtered (fp, "catch handlers");
12895 case ada_catch_assert:
12896 fprintf_filtered (fp, "catch assert");
12900 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12902 print_recreate_thread (b, fp);
12905 /* Virtual table for "catch exception" breakpoints. */
12907 static struct bp_location *
12908 allocate_location_catch_exception (struct breakpoint *self)
12910 return allocate_location_exception (ada_catch_exception, self);
12914 re_set_catch_exception (struct breakpoint *b)
12916 re_set_exception (ada_catch_exception, b);
12920 check_status_catch_exception (bpstat bs)
12922 check_status_exception (ada_catch_exception, bs);
12925 static enum print_stop_action
12926 print_it_catch_exception (bpstat bs)
12928 return print_it_exception (ada_catch_exception, bs);
12932 print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
12934 print_one_exception (ada_catch_exception, b, last_loc);
12938 print_mention_catch_exception (struct breakpoint *b)
12940 print_mention_exception (ada_catch_exception, b);
12944 print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12946 print_recreate_exception (ada_catch_exception, b, fp);
12949 static struct breakpoint_ops catch_exception_breakpoint_ops;
12951 /* Virtual table for "catch exception unhandled" breakpoints. */
12953 static struct bp_location *
12954 allocate_location_catch_exception_unhandled (struct breakpoint *self)
12956 return allocate_location_exception (ada_catch_exception_unhandled, self);
12960 re_set_catch_exception_unhandled (struct breakpoint *b)
12962 re_set_exception (ada_catch_exception_unhandled, b);
12966 check_status_catch_exception_unhandled (bpstat bs)
12968 check_status_exception (ada_catch_exception_unhandled, bs);
12971 static enum print_stop_action
12972 print_it_catch_exception_unhandled (bpstat bs)
12974 return print_it_exception (ada_catch_exception_unhandled, bs);
12978 print_one_catch_exception_unhandled (struct breakpoint *b,
12979 struct bp_location **last_loc)
12981 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
12985 print_mention_catch_exception_unhandled (struct breakpoint *b)
12987 print_mention_exception (ada_catch_exception_unhandled, b);
12991 print_recreate_catch_exception_unhandled (struct breakpoint *b,
12992 struct ui_file *fp)
12994 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
12997 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
12999 /* Virtual table for "catch assert" breakpoints. */
13001 static struct bp_location *
13002 allocate_location_catch_assert (struct breakpoint *self)
13004 return allocate_location_exception (ada_catch_assert, self);
13008 re_set_catch_assert (struct breakpoint *b)
13010 re_set_exception (ada_catch_assert, b);
13014 check_status_catch_assert (bpstat bs)
13016 check_status_exception (ada_catch_assert, bs);
13019 static enum print_stop_action
13020 print_it_catch_assert (bpstat bs)
13022 return print_it_exception (ada_catch_assert, bs);
13026 print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
13028 print_one_exception (ada_catch_assert, b, last_loc);
13032 print_mention_catch_assert (struct breakpoint *b)
13034 print_mention_exception (ada_catch_assert, b);
13038 print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
13040 print_recreate_exception (ada_catch_assert, b, fp);
13043 static struct breakpoint_ops catch_assert_breakpoint_ops;
13045 /* Virtual table for "catch handlers" breakpoints. */
13047 static struct bp_location *
13048 allocate_location_catch_handlers (struct breakpoint *self)
13050 return allocate_location_exception (ada_catch_handlers, self);
13054 re_set_catch_handlers (struct breakpoint *b)
13056 re_set_exception (ada_catch_handlers, b);
13060 check_status_catch_handlers (bpstat bs)
13062 check_status_exception (ada_catch_handlers, bs);
13065 static enum print_stop_action
13066 print_it_catch_handlers (bpstat bs)
13068 return print_it_exception (ada_catch_handlers, bs);
13072 print_one_catch_handlers (struct breakpoint *b,
13073 struct bp_location **last_loc)
13075 print_one_exception (ada_catch_handlers, b, last_loc);
13079 print_mention_catch_handlers (struct breakpoint *b)
13081 print_mention_exception (ada_catch_handlers, b);
13085 print_recreate_catch_handlers (struct breakpoint *b,
13086 struct ui_file *fp)
13088 print_recreate_exception (ada_catch_handlers, b, fp);
13091 static struct breakpoint_ops catch_handlers_breakpoint_ops;
13093 /* Return a newly allocated copy of the first space-separated token
13094 in ARGSP, and then adjust ARGSP to point immediately after that
13097 Return NULL if ARGPS does not contain any more tokens. */
13100 ada_get_next_arg (const char **argsp)
13102 const char *args = *argsp;
13106 args = skip_spaces (args);
13107 if (args[0] == '\0')
13108 return NULL; /* No more arguments. */
13110 /* Find the end of the current argument. */
13112 end = skip_to_space (args);
13114 /* Adjust ARGSP to point to the start of the next argument. */
13118 /* Make a copy of the current argument and return it. */
13120 result = (char *) xmalloc (end - args + 1);
13121 strncpy (result, args, end - args);
13122 result[end - args] = '\0';
13127 /* Split the arguments specified in a "catch exception" command.
13128 Set EX to the appropriate catchpoint type.
13129 Set EXCEP_STRING to the name of the specific exception if
13130 specified by the user.
13131 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
13132 "catch handlers" command. False otherwise.
13133 If a condition is found at the end of the arguments, the condition
13134 expression is stored in COND_STRING (memory must be deallocated
13135 after use). Otherwise COND_STRING is set to NULL. */
13138 catch_ada_exception_command_split (const char *args,
13139 bool is_catch_handlers_cmd,
13140 enum ada_exception_catchpoint_kind *ex,
13141 char **excep_string,
13142 std::string &cond_string)
13144 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
13145 char *exception_name;
13148 exception_name = ada_get_next_arg (&args);
13149 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
13151 /* This is not an exception name; this is the start of a condition
13152 expression for a catchpoint on all exceptions. So, "un-get"
13153 this token, and set exception_name to NULL. */
13154 xfree (exception_name);
13155 exception_name = NULL;
13158 make_cleanup (xfree, exception_name);
13160 /* Check to see if we have a condition. */
13162 args = skip_spaces (args);
13163 if (startswith (args, "if")
13164 && (isspace (args[2]) || args[2] == '\0'))
13167 args = skip_spaces (args);
13169 if (args[0] == '\0')
13170 error (_("Condition missing after `if' keyword"));
13171 cond = xstrdup (args);
13172 make_cleanup (xfree, cond);
13174 args += strlen (args);
13177 /* Check that we do not have any more arguments. Anything else
13180 if (args[0] != '\0')
13181 error (_("Junk at end of expression"));
13183 discard_cleanups (old_chain);
13185 if (is_catch_handlers_cmd)
13187 /* Catch handling of exceptions. */
13188 *ex = ada_catch_handlers;
13189 *excep_string = exception_name;
13191 else if (exception_name == NULL)
13193 /* Catch all exceptions. */
13194 *ex = ada_catch_exception;
13195 *excep_string = NULL;
13197 else if (strcmp (exception_name, "unhandled") == 0)
13199 /* Catch unhandled exceptions. */
13200 *ex = ada_catch_exception_unhandled;
13201 *excep_string = NULL;
13205 /* Catch a specific exception. */
13206 *ex = ada_catch_exception;
13207 *excep_string = exception_name;
13210 cond_string.assign (cond);
13213 /* Return the name of the symbol on which we should break in order to
13214 implement a catchpoint of the EX kind. */
13216 static const char *
13217 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
13219 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
13221 gdb_assert (data->exception_info != NULL);
13225 case ada_catch_exception:
13226 return (data->exception_info->catch_exception_sym);
13228 case ada_catch_exception_unhandled:
13229 return (data->exception_info->catch_exception_unhandled_sym);
13231 case ada_catch_assert:
13232 return (data->exception_info->catch_assert_sym);
13234 case ada_catch_handlers:
13235 return (data->exception_info->catch_handlers_sym);
13238 internal_error (__FILE__, __LINE__,
13239 _("unexpected catchpoint kind (%d)"), ex);
13243 /* Return the breakpoint ops "virtual table" used for catchpoints
13246 static const struct breakpoint_ops *
13247 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
13251 case ada_catch_exception:
13252 return (&catch_exception_breakpoint_ops);
13254 case ada_catch_exception_unhandled:
13255 return (&catch_exception_unhandled_breakpoint_ops);
13257 case ada_catch_assert:
13258 return (&catch_assert_breakpoint_ops);
13260 case ada_catch_handlers:
13261 return (&catch_handlers_breakpoint_ops);
13264 internal_error (__FILE__, __LINE__,
13265 _("unexpected catchpoint kind (%d)"), ex);
13269 /* Return the condition that will be used to match the current exception
13270 being raised with the exception that the user wants to catch. This
13271 assumes that this condition is used when the inferior just triggered
13272 an exception catchpoint.
13273 EX: the type of catchpoints used for catching Ada exceptions.
13275 The string returned is a newly allocated string that needs to be
13276 deallocated later. */
13279 ada_exception_catchpoint_cond_string (const char *excep_string,
13280 enum ada_exception_catchpoint_kind ex)
13283 bool is_standard_exc = false;
13284 const char *actual_exc_expr;
13285 char *ref_exc_expr;
13287 if (ex == ada_catch_handlers)
13289 /* For exception handlers catchpoints, the condition string does
13290 not use the same parameter as for the other exceptions. */
13291 actual_exc_expr = ("long_integer (GNAT_GCC_exception_Access"
13292 "(gcc_exception).all.occurrence.id)");
13295 actual_exc_expr = "long_integer (e)";
13297 /* The standard exceptions are a special case. They are defined in
13298 runtime units that have been compiled without debugging info; if
13299 EXCEP_STRING is the not-fully-qualified name of a standard
13300 exception (e.g. "constraint_error") then, during the evaluation
13301 of the condition expression, the symbol lookup on this name would
13302 *not* return this standard exception. The catchpoint condition
13303 may then be set only on user-defined exceptions which have the
13304 same not-fully-qualified name (e.g. my_package.constraint_error).
13306 To avoid this unexcepted behavior, these standard exceptions are
13307 systematically prefixed by "standard". This means that "catch
13308 exception constraint_error" is rewritten into "catch exception
13309 standard.constraint_error".
13311 If an exception named contraint_error is defined in another package of
13312 the inferior program, then the only way to specify this exception as a
13313 breakpoint condition is to use its fully-qualified named:
13314 e.g. my_package.constraint_error. */
13316 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13318 if (strcmp (standard_exc [i], excep_string) == 0)
13320 is_standard_exc = true;
13325 if (is_standard_exc)
13326 ref_exc_expr = xstrprintf ("long_integer (&standard.%s)", excep_string);
13328 ref_exc_expr = xstrprintf ("long_integer (&%s)", excep_string);
13330 char *result = xstrprintf ("%s = %s", actual_exc_expr, ref_exc_expr);
13331 xfree (ref_exc_expr);
13335 /* Return the symtab_and_line that should be used to insert an exception
13336 catchpoint of the TYPE kind.
13338 EXCEP_STRING should contain the name of a specific exception that
13339 the catchpoint should catch, or NULL otherwise.
13341 ADDR_STRING returns the name of the function where the real
13342 breakpoint that implements the catchpoints is set, depending on the
13343 type of catchpoint we need to create. */
13345 static struct symtab_and_line
13346 ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
13347 const char **addr_string, const struct breakpoint_ops **ops)
13349 const char *sym_name;
13350 struct symbol *sym;
13352 /* First, find out which exception support info to use. */
13353 ada_exception_support_info_sniffer ();
13355 /* Then lookup the function on which we will break in order to catch
13356 the Ada exceptions requested by the user. */
13357 sym_name = ada_exception_sym_name (ex);
13358 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13360 /* We can assume that SYM is not NULL at this stage. If the symbol
13361 did not exist, ada_exception_support_info_sniffer would have
13362 raised an exception.
13364 Also, ada_exception_support_info_sniffer should have already
13365 verified that SYM is a function symbol. */
13366 gdb_assert (sym != NULL);
13367 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
13369 /* Set ADDR_STRING. */
13370 *addr_string = xstrdup (sym_name);
13373 *ops = ada_exception_breakpoint_ops (ex);
13375 return find_function_start_sal (sym, 1);
13378 /* Create an Ada exception catchpoint.
13380 EX_KIND is the kind of exception catchpoint to be created.
13382 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
13383 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
13384 of the exception to which this catchpoint applies. When not NULL,
13385 the string must be allocated on the heap, and its deallocation
13386 is no longer the responsibility of the caller.
13388 COND_STRING, if not NULL, is the catchpoint condition. This string
13389 must be allocated on the heap, and its deallocation is no longer
13390 the responsibility of the caller.
13392 TEMPFLAG, if nonzero, means that the underlying breakpoint
13393 should be temporary.
13395 FROM_TTY is the usual argument passed to all commands implementations. */
13398 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
13399 enum ada_exception_catchpoint_kind ex_kind,
13400 char *excep_string,
13401 const std::string &cond_string,
13406 const char *addr_string = NULL;
13407 const struct breakpoint_ops *ops = NULL;
13408 struct symtab_and_line sal
13409 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
13411 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
13412 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string,
13413 ops, tempflag, disabled, from_tty);
13414 c->excep_string = excep_string;
13415 create_excep_cond_exprs (c.get (), ex_kind);
13416 if (!cond_string.empty ())
13417 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty);
13418 install_breakpoint (0, std::move (c), 1);
13421 /* Implement the "catch exception" command. */
13424 catch_ada_exception_command (const char *arg_entry, int from_tty,
13425 struct cmd_list_element *command)
13427 const char *arg = arg_entry;
13428 struct gdbarch *gdbarch = get_current_arch ();
13430 enum ada_exception_catchpoint_kind ex_kind;
13431 char *excep_string = NULL;
13432 std::string cond_string;
13434 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13438 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
13440 create_ada_exception_catchpoint (gdbarch, ex_kind,
13441 excep_string, cond_string,
13442 tempflag, 1 /* enabled */,
13446 /* Implement the "catch handlers" command. */
13449 catch_ada_handlers_command (const char *arg_entry, int from_tty,
13450 struct cmd_list_element *command)
13452 const char *arg = arg_entry;
13453 struct gdbarch *gdbarch = get_current_arch ();
13455 enum ada_exception_catchpoint_kind ex_kind;
13456 char *excep_string = NULL;
13457 std::string cond_string;
13459 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13463 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
13465 create_ada_exception_catchpoint (gdbarch, ex_kind,
13466 excep_string, cond_string,
13467 tempflag, 1 /* enabled */,
13471 /* Split the arguments specified in a "catch assert" command.
13473 ARGS contains the command's arguments (or the empty string if
13474 no arguments were passed).
13476 If ARGS contains a condition, set COND_STRING to that condition
13477 (the memory needs to be deallocated after use). */
13480 catch_ada_assert_command_split (const char *args, std::string &cond_string)
13482 args = skip_spaces (args);
13484 /* Check whether a condition was provided. */
13485 if (startswith (args, "if")
13486 && (isspace (args[2]) || args[2] == '\0'))
13489 args = skip_spaces (args);
13490 if (args[0] == '\0')
13491 error (_("condition missing after `if' keyword"));
13492 cond_string.assign (args);
13495 /* Otherwise, there should be no other argument at the end of
13497 else if (args[0] != '\0')
13498 error (_("Junk at end of arguments."));
13501 /* Implement the "catch assert" command. */
13504 catch_assert_command (const char *arg_entry, int from_tty,
13505 struct cmd_list_element *command)
13507 const char *arg = arg_entry;
13508 struct gdbarch *gdbarch = get_current_arch ();
13510 std::string cond_string;
13512 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13516 catch_ada_assert_command_split (arg, cond_string);
13517 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
13519 tempflag, 1 /* enabled */,
13523 /* Return non-zero if the symbol SYM is an Ada exception object. */
13526 ada_is_exception_sym (struct symbol *sym)
13528 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
13530 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13531 && SYMBOL_CLASS (sym) != LOC_BLOCK
13532 && SYMBOL_CLASS (sym) != LOC_CONST
13533 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13534 && type_name != NULL && strcmp (type_name, "exception") == 0);
13537 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13538 Ada exception object. This matches all exceptions except the ones
13539 defined by the Ada language. */
13542 ada_is_non_standard_exception_sym (struct symbol *sym)
13546 if (!ada_is_exception_sym (sym))
13549 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13550 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13551 return 0; /* A standard exception. */
13553 /* Numeric_Error is also a standard exception, so exclude it.
13554 See the STANDARD_EXC description for more details as to why
13555 this exception is not listed in that array. */
13556 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13562 /* A helper function for std::sort, comparing two struct ada_exc_info
13565 The comparison is determined first by exception name, and then
13566 by exception address. */
13569 ada_exc_info::operator< (const ada_exc_info &other) const
13573 result = strcmp (name, other.name);
13576 if (result == 0 && addr < other.addr)
13582 ada_exc_info::operator== (const ada_exc_info &other) const
13584 return addr == other.addr && strcmp (name, other.name) == 0;
13587 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13588 routine, but keeping the first SKIP elements untouched.
13590 All duplicates are also removed. */
13593 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13596 std::sort (exceptions->begin () + skip, exceptions->end ());
13597 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13598 exceptions->end ());
13601 /* Add all exceptions defined by the Ada standard whose name match
13602 a regular expression.
13604 If PREG is not NULL, then this regexp_t object is used to
13605 perform the symbol name matching. Otherwise, no name-based
13606 filtering is performed.
13608 EXCEPTIONS is a vector of exceptions to which matching exceptions
13612 ada_add_standard_exceptions (compiled_regex *preg,
13613 std::vector<ada_exc_info> *exceptions)
13617 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13620 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
13622 struct bound_minimal_symbol msymbol
13623 = ada_lookup_simple_minsym (standard_exc[i]);
13625 if (msymbol.minsym != NULL)
13627 struct ada_exc_info info
13628 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
13630 exceptions->push_back (info);
13636 /* Add all Ada exceptions defined locally and accessible from the given
13639 If PREG is not NULL, then this regexp_t object is used to
13640 perform the symbol name matching. Otherwise, no name-based
13641 filtering is performed.
13643 EXCEPTIONS is a vector of exceptions to which matching exceptions
13647 ada_add_exceptions_from_frame (compiled_regex *preg,
13648 struct frame_info *frame,
13649 std::vector<ada_exc_info> *exceptions)
13651 const struct block *block = get_frame_block (frame, 0);
13655 struct block_iterator iter;
13656 struct symbol *sym;
13658 ALL_BLOCK_SYMBOLS (block, iter, sym)
13660 switch (SYMBOL_CLASS (sym))
13667 if (ada_is_exception_sym (sym))
13669 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13670 SYMBOL_VALUE_ADDRESS (sym)};
13672 exceptions->push_back (info);
13676 if (BLOCK_FUNCTION (block) != NULL)
13678 block = BLOCK_SUPERBLOCK (block);
13682 /* Return true if NAME matches PREG or if PREG is NULL. */
13685 name_matches_regex (const char *name, compiled_regex *preg)
13687 return (preg == NULL
13688 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
13691 /* Add all exceptions defined globally whose name name match
13692 a regular expression, excluding standard exceptions.
13694 The reason we exclude standard exceptions is that they need
13695 to be handled separately: Standard exceptions are defined inside
13696 a runtime unit which is normally not compiled with debugging info,
13697 and thus usually do not show up in our symbol search. However,
13698 if the unit was in fact built with debugging info, we need to
13699 exclude them because they would duplicate the entry we found
13700 during the special loop that specifically searches for those
13701 standard exceptions.
13703 If PREG is not NULL, then this regexp_t object is used to
13704 perform the symbol name matching. Otherwise, no name-based
13705 filtering is performed.
13707 EXCEPTIONS is a vector of exceptions to which matching exceptions
13711 ada_add_global_exceptions (compiled_regex *preg,
13712 std::vector<ada_exc_info> *exceptions)
13714 struct objfile *objfile;
13715 struct compunit_symtab *s;
13717 /* In Ada, the symbol "search name" is a linkage name, whereas the
13718 regular expression used to do the matching refers to the natural
13719 name. So match against the decoded name. */
13720 expand_symtabs_matching (NULL,
13721 lookup_name_info::match_any (),
13722 [&] (const char *search_name)
13724 const char *decoded = ada_decode (search_name);
13725 return name_matches_regex (decoded, preg);
13730 ALL_COMPUNITS (objfile, s)
13732 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
13735 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13737 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13738 struct block_iterator iter;
13739 struct symbol *sym;
13741 ALL_BLOCK_SYMBOLS (b, iter, sym)
13742 if (ada_is_non_standard_exception_sym (sym)
13743 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
13745 struct ada_exc_info info
13746 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13748 exceptions->push_back (info);
13754 /* Implements ada_exceptions_list with the regular expression passed
13755 as a regex_t, rather than a string.
13757 If not NULL, PREG is used to filter out exceptions whose names
13758 do not match. Otherwise, all exceptions are listed. */
13760 static std::vector<ada_exc_info>
13761 ada_exceptions_list_1 (compiled_regex *preg)
13763 std::vector<ada_exc_info> result;
13766 /* First, list the known standard exceptions. These exceptions
13767 need to be handled separately, as they are usually defined in
13768 runtime units that have been compiled without debugging info. */
13770 ada_add_standard_exceptions (preg, &result);
13772 /* Next, find all exceptions whose scope is local and accessible
13773 from the currently selected frame. */
13775 if (has_stack_frames ())
13777 prev_len = result.size ();
13778 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13780 if (result.size () > prev_len)
13781 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13784 /* Add all exceptions whose scope is global. */
13786 prev_len = result.size ();
13787 ada_add_global_exceptions (preg, &result);
13788 if (result.size () > prev_len)
13789 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13794 /* Return a vector of ada_exc_info.
13796 If REGEXP is NULL, all exceptions are included in the result.
13797 Otherwise, it should contain a valid regular expression,
13798 and only the exceptions whose names match that regular expression
13799 are included in the result.
13801 The exceptions are sorted in the following order:
13802 - Standard exceptions (defined by the Ada language), in
13803 alphabetical order;
13804 - Exceptions only visible from the current frame, in
13805 alphabetical order;
13806 - Exceptions whose scope is global, in alphabetical order. */
13808 std::vector<ada_exc_info>
13809 ada_exceptions_list (const char *regexp)
13811 if (regexp == NULL)
13812 return ada_exceptions_list_1 (NULL);
13814 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13815 return ada_exceptions_list_1 (®);
13818 /* Implement the "info exceptions" command. */
13821 info_exceptions_command (const char *regexp, int from_tty)
13823 struct gdbarch *gdbarch = get_current_arch ();
13825 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13827 if (regexp != NULL)
13829 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13831 printf_filtered (_("All defined Ada exceptions:\n"));
13833 for (const ada_exc_info &info : exceptions)
13834 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13838 /* Information about operators given special treatment in functions
13840 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13842 #define ADA_OPERATORS \
13843 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13844 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13845 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13846 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13847 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13848 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13849 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13850 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13851 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13852 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13853 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13854 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13855 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13856 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13857 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13858 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13859 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13860 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13861 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13864 ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13867 switch (exp->elts[pc - 1].opcode)
13870 operator_length_standard (exp, pc, oplenp, argsp);
13873 #define OP_DEFN(op, len, args, binop) \
13874 case op: *oplenp = len; *argsp = args; break;
13880 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13885 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13890 /* Implementation of the exp_descriptor method operator_check. */
13893 ada_operator_check (struct expression *exp, int pos,
13894 int (*objfile_func) (struct objfile *objfile, void *data),
13897 const union exp_element *const elts = exp->elts;
13898 struct type *type = NULL;
13900 switch (elts[pos].opcode)
13902 case UNOP_IN_RANGE:
13904 type = elts[pos + 1].type;
13908 return operator_check_standard (exp, pos, objfile_func, data);
13911 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13913 if (type && TYPE_OBJFILE (type)
13914 && (*objfile_func) (TYPE_OBJFILE (type), data))
13920 static const char *
13921 ada_op_name (enum exp_opcode opcode)
13926 return op_name_standard (opcode);
13928 #define OP_DEFN(op, len, args, binop) case op: return #op;
13933 return "OP_AGGREGATE";
13935 return "OP_CHOICES";
13941 /* As for operator_length, but assumes PC is pointing at the first
13942 element of the operator, and gives meaningful results only for the
13943 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13946 ada_forward_operator_length (struct expression *exp, int pc,
13947 int *oplenp, int *argsp)
13949 switch (exp->elts[pc].opcode)
13952 *oplenp = *argsp = 0;
13955 #define OP_DEFN(op, len, args, binop) \
13956 case op: *oplenp = len; *argsp = args; break;
13962 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13967 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13973 int len = longest_to_int (exp->elts[pc + 1].longconst);
13975 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13983 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13985 enum exp_opcode op = exp->elts[elt].opcode;
13990 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13994 /* Ada attributes ('Foo). */
13997 case OP_ATR_LENGTH:
14001 case OP_ATR_MODULUS:
14008 case UNOP_IN_RANGE:
14010 /* XXX: gdb_sprint_host_address, type_sprint */
14011 fprintf_filtered (stream, _("Type @"));
14012 gdb_print_host_address (exp->elts[pc + 1].type, stream);
14013 fprintf_filtered (stream, " (");
14014 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
14015 fprintf_filtered (stream, ")");
14017 case BINOP_IN_BOUNDS:
14018 fprintf_filtered (stream, " (%d)",
14019 longest_to_int (exp->elts[pc + 2].longconst));
14021 case TERNOP_IN_RANGE:
14026 case OP_DISCRETE_RANGE:
14027 case OP_POSITIONAL:
14034 char *name = &exp->elts[elt + 2].string;
14035 int len = longest_to_int (exp->elts[elt + 1].longconst);
14037 fprintf_filtered (stream, "Text: `%.*s'", len, name);
14042 return dump_subexp_body_standard (exp, stream, elt);
14046 for (i = 0; i < nargs; i += 1)
14047 elt = dump_subexp (exp, stream, elt);
14052 /* The Ada extension of print_subexp (q.v.). */
14055 ada_print_subexp (struct expression *exp, int *pos,
14056 struct ui_file *stream, enum precedence prec)
14058 int oplen, nargs, i;
14060 enum exp_opcode op = exp->elts[pc].opcode;
14062 ada_forward_operator_length (exp, pc, &oplen, &nargs);
14069 print_subexp_standard (exp, pos, stream, prec);
14073 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
14076 case BINOP_IN_BOUNDS:
14077 /* XXX: sprint_subexp */
14078 print_subexp (exp, pos, stream, PREC_SUFFIX);
14079 fputs_filtered (" in ", stream);
14080 print_subexp (exp, pos, stream, PREC_SUFFIX);
14081 fputs_filtered ("'range", stream);
14082 if (exp->elts[pc + 1].longconst > 1)
14083 fprintf_filtered (stream, "(%ld)",
14084 (long) exp->elts[pc + 1].longconst);
14087 case TERNOP_IN_RANGE:
14088 if (prec >= PREC_EQUAL)
14089 fputs_filtered ("(", stream);
14090 /* XXX: sprint_subexp */
14091 print_subexp (exp, pos, stream, PREC_SUFFIX);
14092 fputs_filtered (" in ", stream);
14093 print_subexp (exp, pos, stream, PREC_EQUAL);
14094 fputs_filtered (" .. ", stream);
14095 print_subexp (exp, pos, stream, PREC_EQUAL);
14096 if (prec >= PREC_EQUAL)
14097 fputs_filtered (")", stream);
14102 case OP_ATR_LENGTH:
14106 case OP_ATR_MODULUS:
14111 if (exp->elts[*pos].opcode == OP_TYPE)
14113 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
14114 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
14115 &type_print_raw_options);
14119 print_subexp (exp, pos, stream, PREC_SUFFIX);
14120 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
14125 for (tem = 1; tem < nargs; tem += 1)
14127 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
14128 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
14130 fputs_filtered (")", stream);
14135 type_print (exp->elts[pc + 1].type, "", stream, 0);
14136 fputs_filtered ("'(", stream);
14137 print_subexp (exp, pos, stream, PREC_PREFIX);
14138 fputs_filtered (")", stream);
14141 case UNOP_IN_RANGE:
14142 /* XXX: sprint_subexp */
14143 print_subexp (exp, pos, stream, PREC_SUFFIX);
14144 fputs_filtered (" in ", stream);
14145 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
14146 &type_print_raw_options);
14149 case OP_DISCRETE_RANGE:
14150 print_subexp (exp, pos, stream, PREC_SUFFIX);
14151 fputs_filtered ("..", stream);
14152 print_subexp (exp, pos, stream, PREC_SUFFIX);
14156 fputs_filtered ("others => ", stream);
14157 print_subexp (exp, pos, stream, PREC_SUFFIX);
14161 for (i = 0; i < nargs-1; i += 1)
14164 fputs_filtered ("|", stream);
14165 print_subexp (exp, pos, stream, PREC_SUFFIX);
14167 fputs_filtered (" => ", stream);
14168 print_subexp (exp, pos, stream, PREC_SUFFIX);
14171 case OP_POSITIONAL:
14172 print_subexp (exp, pos, stream, PREC_SUFFIX);
14176 fputs_filtered ("(", stream);
14177 for (i = 0; i < nargs; i += 1)
14180 fputs_filtered (", ", stream);
14181 print_subexp (exp, pos, stream, PREC_SUFFIX);
14183 fputs_filtered (")", stream);
14188 /* Table mapping opcodes into strings for printing operators
14189 and precedences of the operators. */
14191 static const struct op_print ada_op_print_tab[] = {
14192 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
14193 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
14194 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
14195 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
14196 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
14197 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
14198 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
14199 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
14200 {"<=", BINOP_LEQ, PREC_ORDER, 0},
14201 {">=", BINOP_GEQ, PREC_ORDER, 0},
14202 {">", BINOP_GTR, PREC_ORDER, 0},
14203 {"<", BINOP_LESS, PREC_ORDER, 0},
14204 {">>", BINOP_RSH, PREC_SHIFT, 0},
14205 {"<<", BINOP_LSH, PREC_SHIFT, 0},
14206 {"+", BINOP_ADD, PREC_ADD, 0},
14207 {"-", BINOP_SUB, PREC_ADD, 0},
14208 {"&", BINOP_CONCAT, PREC_ADD, 0},
14209 {"*", BINOP_MUL, PREC_MUL, 0},
14210 {"/", BINOP_DIV, PREC_MUL, 0},
14211 {"rem", BINOP_REM, PREC_MUL, 0},
14212 {"mod", BINOP_MOD, PREC_MUL, 0},
14213 {"**", BINOP_EXP, PREC_REPEAT, 0},
14214 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
14215 {"-", UNOP_NEG, PREC_PREFIX, 0},
14216 {"+", UNOP_PLUS, PREC_PREFIX, 0},
14217 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
14218 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
14219 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
14220 {".all", UNOP_IND, PREC_SUFFIX, 1},
14221 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
14222 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
14223 {NULL, OP_NULL, PREC_SUFFIX, 0}
14226 enum ada_primitive_types {
14227 ada_primitive_type_int,
14228 ada_primitive_type_long,
14229 ada_primitive_type_short,
14230 ada_primitive_type_char,
14231 ada_primitive_type_float,
14232 ada_primitive_type_double,
14233 ada_primitive_type_void,
14234 ada_primitive_type_long_long,
14235 ada_primitive_type_long_double,
14236 ada_primitive_type_natural,
14237 ada_primitive_type_positive,
14238 ada_primitive_type_system_address,
14239 ada_primitive_type_storage_offset,
14240 nr_ada_primitive_types
14244 ada_language_arch_info (struct gdbarch *gdbarch,
14245 struct language_arch_info *lai)
14247 const struct builtin_type *builtin = builtin_type (gdbarch);
14249 lai->primitive_type_vector
14250 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
14253 lai->primitive_type_vector [ada_primitive_type_int]
14254 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14256 lai->primitive_type_vector [ada_primitive_type_long]
14257 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
14258 0, "long_integer");
14259 lai->primitive_type_vector [ada_primitive_type_short]
14260 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
14261 0, "short_integer");
14262 lai->string_char_type
14263 = lai->primitive_type_vector [ada_primitive_type_char]
14264 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
14265 lai->primitive_type_vector [ada_primitive_type_float]
14266 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
14267 "float", gdbarch_float_format (gdbarch));
14268 lai->primitive_type_vector [ada_primitive_type_double]
14269 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
14270 "long_float", gdbarch_double_format (gdbarch));
14271 lai->primitive_type_vector [ada_primitive_type_long_long]
14272 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14273 0, "long_long_integer");
14274 lai->primitive_type_vector [ada_primitive_type_long_double]
14275 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
14276 "long_long_float", gdbarch_long_double_format (gdbarch));
14277 lai->primitive_type_vector [ada_primitive_type_natural]
14278 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14280 lai->primitive_type_vector [ada_primitive_type_positive]
14281 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14283 lai->primitive_type_vector [ada_primitive_type_void]
14284 = builtin->builtin_void;
14286 lai->primitive_type_vector [ada_primitive_type_system_address]
14287 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14289 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14290 = "system__address";
14292 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14293 type. This is a signed integral type whose size is the same as
14294 the size of addresses. */
14296 unsigned int addr_length = TYPE_LENGTH
14297 (lai->primitive_type_vector [ada_primitive_type_system_address]);
14299 lai->primitive_type_vector [ada_primitive_type_storage_offset]
14300 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14304 lai->bool_type_symbol = NULL;
14305 lai->bool_type_default = builtin->builtin_bool;
14308 /* Language vector */
14310 /* Not really used, but needed in the ada_language_defn. */
14313 emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
14315 ada_emit_char (c, type, stream, quoter, 1);
14319 parse (struct parser_state *ps)
14321 warnings_issued = 0;
14322 return ada_parse (ps);
14325 static const struct exp_descriptor ada_exp_descriptor = {
14327 ada_operator_length,
14328 ada_operator_check,
14330 ada_dump_subexp_body,
14331 ada_evaluate_subexp
14334 /* symbol_name_matcher_ftype adapter for wild_match. */
14337 do_wild_match (const char *symbol_search_name,
14338 const lookup_name_info &lookup_name,
14339 completion_match_result *comp_match_res)
14341 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14344 /* symbol_name_matcher_ftype adapter for full_match. */
14347 do_full_match (const char *symbol_search_name,
14348 const lookup_name_info &lookup_name,
14349 completion_match_result *comp_match_res)
14351 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14354 /* Build the Ada lookup name for LOOKUP_NAME. */
14356 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14358 const std::string &user_name = lookup_name.name ();
14360 if (user_name[0] == '<')
14362 if (user_name.back () == '>')
14363 m_encoded_name = user_name.substr (1, user_name.size () - 2);
14365 m_encoded_name = user_name.substr (1, user_name.size () - 1);
14366 m_encoded_p = true;
14367 m_verbatim_p = true;
14368 m_wild_match_p = false;
14369 m_standard_p = false;
14373 m_verbatim_p = false;
14375 m_encoded_p = user_name.find ("__") != std::string::npos;
14379 const char *folded = ada_fold_name (user_name.c_str ());
14380 const char *encoded = ada_encode_1 (folded, false);
14381 if (encoded != NULL)
14382 m_encoded_name = encoded;
14384 m_encoded_name = user_name;
14387 m_encoded_name = user_name;
14389 /* Handle the 'package Standard' special case. See description
14390 of m_standard_p. */
14391 if (startswith (m_encoded_name.c_str (), "standard__"))
14393 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14394 m_standard_p = true;
14397 m_standard_p = false;
14399 /* If the name contains a ".", then the user is entering a fully
14400 qualified entity name, and the match must not be done in wild
14401 mode. Similarly, if the user wants to complete what looks
14402 like an encoded name, the match must not be done in wild
14403 mode. Also, in the standard__ special case always do
14404 non-wild matching. */
14406 = (lookup_name.match_type () != symbol_name_match_type::FULL
14409 && user_name.find ('.') == std::string::npos);
14413 /* symbol_name_matcher_ftype method for Ada. This only handles
14414 completion mode. */
14417 ada_symbol_name_matches (const char *symbol_search_name,
14418 const lookup_name_info &lookup_name,
14419 completion_match_result *comp_match_res)
14421 return lookup_name.ada ().matches (symbol_search_name,
14422 lookup_name.match_type (),
14426 /* A name matcher that matches the symbol name exactly, with
14430 literal_symbol_name_matcher (const char *symbol_search_name,
14431 const lookup_name_info &lookup_name,
14432 completion_match_result *comp_match_res)
14434 const std::string &name = lookup_name.name ();
14436 int cmp = (lookup_name.completion_mode ()
14437 ? strncmp (symbol_search_name, name.c_str (), name.size ())
14438 : strcmp (symbol_search_name, name.c_str ()));
14441 if (comp_match_res != NULL)
14442 comp_match_res->set_match (symbol_search_name);
14449 /* Implement the "la_get_symbol_name_matcher" language_defn method for
14452 static symbol_name_matcher_ftype *
14453 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14455 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14456 return literal_symbol_name_matcher;
14458 if (lookup_name.completion_mode ())
14459 return ada_symbol_name_matches;
14462 if (lookup_name.ada ().wild_match_p ())
14463 return do_wild_match;
14465 return do_full_match;
14469 /* Implement the "la_read_var_value" language_defn method for Ada. */
14471 static struct value *
14472 ada_read_var_value (struct symbol *var, const struct block *var_block,
14473 struct frame_info *frame)
14475 const struct block *frame_block = NULL;
14476 struct symbol *renaming_sym = NULL;
14478 /* The only case where default_read_var_value is not sufficient
14479 is when VAR is a renaming... */
14481 frame_block = get_frame_block (frame, NULL);
14483 renaming_sym = ada_find_renaming_symbol (var, frame_block);
14484 if (renaming_sym != NULL)
14485 return ada_read_renaming_var_value (renaming_sym, frame_block);
14487 /* This is a typical case where we expect the default_read_var_value
14488 function to work. */
14489 return default_read_var_value (var, var_block, frame);
14492 static const char *ada_extensions[] =
14494 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14497 extern const struct language_defn ada_language_defn = {
14498 "ada", /* Language name */
14502 case_sensitive_on, /* Yes, Ada is case-insensitive, but
14503 that's not quite what this means. */
14505 macro_expansion_no,
14507 &ada_exp_descriptor,
14511 ada_printchar, /* Print a character constant */
14512 ada_printstr, /* Function to print string constant */
14513 emit_char, /* Function to print single char (not used) */
14514 ada_print_type, /* Print a type using appropriate syntax */
14515 ada_print_typedef, /* Print a typedef using appropriate syntax */
14516 ada_val_print, /* Print a value using appropriate syntax */
14517 ada_value_print, /* Print a top-level value */
14518 ada_read_var_value, /* la_read_var_value */
14519 NULL, /* Language specific skip_trampoline */
14520 NULL, /* name_of_this */
14521 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14522 basic_lookup_transparent_type, /* lookup_transparent_type */
14523 ada_la_decode, /* Language specific symbol demangler */
14524 ada_sniff_from_mangled_name,
14525 NULL, /* Language specific
14526 class_name_from_physname */
14527 ada_op_print_tab, /* expression operators for printing */
14528 0, /* c-style arrays */
14529 1, /* String lower bound */
14530 ada_get_gdb_completer_word_break_characters,
14531 ada_collect_symbol_completion_matches,
14532 ada_language_arch_info,
14533 ada_print_array_index,
14534 default_pass_by_reference,
14536 c_watch_location_expression,
14537 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
14538 ada_iterate_over_symbols,
14539 default_search_name_hash,
14546 /* Command-list for the "set/show ada" prefix command. */
14547 static struct cmd_list_element *set_ada_list;
14548 static struct cmd_list_element *show_ada_list;
14550 /* Implement the "set ada" prefix command. */
14553 set_ada_command (const char *arg, int from_tty)
14555 printf_unfiltered (_(\
14556 "\"set ada\" must be followed by the name of a setting.\n"));
14557 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
14560 /* Implement the "show ada" prefix command. */
14563 show_ada_command (const char *args, int from_tty)
14565 cmd_show_list (show_ada_list, from_tty, "");
14569 initialize_ada_catchpoint_ops (void)
14571 struct breakpoint_ops *ops;
14573 initialize_breakpoint_ops ();
14575 ops = &catch_exception_breakpoint_ops;
14576 *ops = bkpt_breakpoint_ops;
14577 ops->allocate_location = allocate_location_catch_exception;
14578 ops->re_set = re_set_catch_exception;
14579 ops->check_status = check_status_catch_exception;
14580 ops->print_it = print_it_catch_exception;
14581 ops->print_one = print_one_catch_exception;
14582 ops->print_mention = print_mention_catch_exception;
14583 ops->print_recreate = print_recreate_catch_exception;
14585 ops = &catch_exception_unhandled_breakpoint_ops;
14586 *ops = bkpt_breakpoint_ops;
14587 ops->allocate_location = allocate_location_catch_exception_unhandled;
14588 ops->re_set = re_set_catch_exception_unhandled;
14589 ops->check_status = check_status_catch_exception_unhandled;
14590 ops->print_it = print_it_catch_exception_unhandled;
14591 ops->print_one = print_one_catch_exception_unhandled;
14592 ops->print_mention = print_mention_catch_exception_unhandled;
14593 ops->print_recreate = print_recreate_catch_exception_unhandled;
14595 ops = &catch_assert_breakpoint_ops;
14596 *ops = bkpt_breakpoint_ops;
14597 ops->allocate_location = allocate_location_catch_assert;
14598 ops->re_set = re_set_catch_assert;
14599 ops->check_status = check_status_catch_assert;
14600 ops->print_it = print_it_catch_assert;
14601 ops->print_one = print_one_catch_assert;
14602 ops->print_mention = print_mention_catch_assert;
14603 ops->print_recreate = print_recreate_catch_assert;
14605 ops = &catch_handlers_breakpoint_ops;
14606 *ops = bkpt_breakpoint_ops;
14607 ops->allocate_location = allocate_location_catch_handlers;
14608 ops->re_set = re_set_catch_handlers;
14609 ops->check_status = check_status_catch_handlers;
14610 ops->print_it = print_it_catch_handlers;
14611 ops->print_one = print_one_catch_handlers;
14612 ops->print_mention = print_mention_catch_handlers;
14613 ops->print_recreate = print_recreate_catch_handlers;
14616 /* This module's 'new_objfile' observer. */
14619 ada_new_objfile_observer (struct objfile *objfile)
14621 ada_clear_symbol_cache ();
14624 /* This module's 'free_objfile' observer. */
14627 ada_free_objfile_observer (struct objfile *objfile)
14629 ada_clear_symbol_cache ();
14633 _initialize_ada_language (void)
14635 initialize_ada_catchpoint_ops ();
14637 add_prefix_cmd ("ada", no_class, set_ada_command,
14638 _("Prefix command for changing Ada-specfic settings"),
14639 &set_ada_list, "set ada ", 0, &setlist);
14641 add_prefix_cmd ("ada", no_class, show_ada_command,
14642 _("Generic command for showing Ada-specific settings."),
14643 &show_ada_list, "show ada ", 0, &showlist);
14645 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14646 &trust_pad_over_xvs, _("\
14647 Enable or disable an optimization trusting PAD types over XVS types"), _("\
14648 Show whether an optimization trusting PAD types over XVS types is activated"),
14650 This is related to the encoding used by the GNAT compiler. The debugger\n\
14651 should normally trust the contents of PAD types, but certain older versions\n\
14652 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14653 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14654 work around this bug. It is always safe to turn this option \"off\", but\n\
14655 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14656 this option to \"off\" unless necessary."),
14657 NULL, NULL, &set_ada_list, &show_ada_list);
14659 add_setshow_boolean_cmd ("print-signatures", class_vars,
14660 &print_signatures, _("\
14661 Enable or disable the output of formal and return types for functions in the \
14662 overloads selection menu"), _("\
14663 Show whether the output of formal and return types for functions in the \
14664 overloads selection menu is activated"),
14665 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14667 add_catch_command ("exception", _("\
14668 Catch Ada exceptions, when raised.\n\
14669 With an argument, catch only exceptions with the given name."),
14670 catch_ada_exception_command,
14675 add_catch_command ("handlers", _("\
14676 Catch Ada exceptions, when handled.\n\
14677 With an argument, catch only exceptions with the given name."),
14678 catch_ada_handlers_command,
14682 add_catch_command ("assert", _("\
14683 Catch failed Ada assertions, when raised.\n\
14684 With an argument, catch only exceptions with the given name."),
14685 catch_assert_command,
14690 varsize_limit = 65536;
14692 add_info ("exceptions", info_exceptions_command,
14694 List all Ada exception names.\n\
14695 If a regular expression is passed as an argument, only those matching\n\
14696 the regular expression are listed."));
14698 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14699 _("Set Ada maintenance-related variables."),
14700 &maint_set_ada_cmdlist, "maintenance set ada ",
14701 0/*allow-unknown*/, &maintenance_set_cmdlist);
14703 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14704 _("Show Ada maintenance-related variables"),
14705 &maint_show_ada_cmdlist, "maintenance show ada ",
14706 0/*allow-unknown*/, &maintenance_show_cmdlist);
14708 add_setshow_boolean_cmd
14709 ("ignore-descriptive-types", class_maintenance,
14710 &ada_ignore_descriptive_types_p,
14711 _("Set whether descriptive types generated by GNAT should be ignored."),
14712 _("Show whether descriptive types generated by GNAT should be ignored."),
14714 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14715 DWARF attribute."),
14716 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14718 decoded_names_store = htab_create_alloc
14719 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
14720 NULL, xcalloc, xfree);
14722 /* The ada-lang observers. */
14723 observer_attach_new_objfile (ada_new_objfile_observer);
14724 observer_attach_free_objfile (ada_free_objfile_observer);
14725 observer_attach_inferior_exit (ada_inferior_exit);
14727 /* Setup various context-specific data. */
14729 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
14730 ada_pspace_data_handle
14731 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);