1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2017 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 (struct expression **, int *, int,
130 static void replace_operator_with_call (struct expression **, 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 struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
231 static int ada_resolve_function (struct block_symbol *, int,
232 struct value **, int, const char *,
235 static int ada_is_direct_array_type (struct type *);
237 static void ada_language_arch_info (struct gdbarch *,
238 struct language_arch_info *);
240 static struct value *ada_index_struct_field (int, struct value *, int,
243 static struct value *assign_aggregate (struct value *, struct value *,
247 static void aggregate_assign_from_choices (struct value *, struct value *,
249 int *, LONGEST *, int *,
250 int, LONGEST, LONGEST);
252 static void aggregate_assign_positional (struct value *, struct value *,
254 int *, LONGEST *, int *, int,
258 static void aggregate_assign_others (struct value *, struct value *,
260 int *, LONGEST *, int, LONGEST, LONGEST);
263 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
266 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
269 static void ada_forward_operator_length (struct expression *, int, int *,
272 static struct type *ada_find_any_type (const char *name);
274 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
275 (const lookup_name_info &lookup_name);
279 /* The result of a symbol lookup to be stored in our symbol cache. */
283 /* The name used to perform the lookup. */
285 /* The namespace used during the lookup. */
287 /* The symbol returned by the lookup, or NULL if no matching symbol
290 /* The block where the symbol was found, or NULL if no matching
292 const struct block *block;
293 /* A pointer to the next entry with the same hash. */
294 struct cache_entry *next;
297 /* The Ada symbol cache, used to store the result of Ada-mode symbol
298 lookups in the course of executing the user's commands.
300 The cache is implemented using a simple, fixed-sized hash.
301 The size is fixed on the grounds that there are not likely to be
302 all that many symbols looked up during any given session, regardless
303 of the size of the symbol table. If we decide to go to a resizable
304 table, let's just use the stuff from libiberty instead. */
306 #define HASH_SIZE 1009
308 struct ada_symbol_cache
310 /* An obstack used to store the entries in our cache. */
311 struct obstack cache_space;
313 /* The root of the hash table used to implement our symbol cache. */
314 struct cache_entry *root[HASH_SIZE];
317 static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
319 /* Maximum-sized dynamic type. */
320 static unsigned int varsize_limit;
322 static const char ada_completer_word_break_characters[] =
324 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
326 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
329 /* The name of the symbol to use to get the name of the main subprogram. */
330 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
331 = "__gnat_ada_main_program_name";
333 /* Limit on the number of warnings to raise per expression evaluation. */
334 static int warning_limit = 2;
336 /* Number of warning messages issued; reset to 0 by cleanups after
337 expression evaluation. */
338 static int warnings_issued = 0;
340 static const char *known_runtime_file_name_patterns[] = {
341 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
344 static const char *known_auxiliary_function_name_patterns[] = {
345 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
348 /* Space for allocating results of ada_lookup_symbol_list. */
349 static struct obstack symbol_list_obstack;
351 /* Maintenance-related settings for this module. */
353 static struct cmd_list_element *maint_set_ada_cmdlist;
354 static struct cmd_list_element *maint_show_ada_cmdlist;
356 /* Implement the "maintenance set ada" (prefix) command. */
359 maint_set_ada_cmd (const char *args, int from_tty)
361 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
365 /* Implement the "maintenance show ada" (prefix) command. */
368 maint_show_ada_cmd (const char *args, int from_tty)
370 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
373 /* The "maintenance ada set/show ignore-descriptive-type" value. */
375 static int ada_ignore_descriptive_types_p = 0;
377 /* Inferior-specific data. */
379 /* Per-inferior data for this module. */
381 struct ada_inferior_data
383 /* The ada__tags__type_specific_data type, which is used when decoding
384 tagged types. With older versions of GNAT, this type was directly
385 accessible through a component ("tsd") in the object tag. But this
386 is no longer the case, so we cache it for each inferior. */
387 struct type *tsd_type;
389 /* The exception_support_info data. This data is used to determine
390 how to implement support for Ada exception catchpoints in a given
392 const struct exception_support_info *exception_info;
395 /* Our key to this module's inferior data. */
396 static const struct inferior_data *ada_inferior_data;
398 /* A cleanup routine for our inferior data. */
400 ada_inferior_data_cleanup (struct inferior *inf, void *arg)
402 struct ada_inferior_data *data;
404 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
409 /* Return our inferior data for the given inferior (INF).
411 This function always returns a valid pointer to an allocated
412 ada_inferior_data structure. If INF's inferior data has not
413 been previously set, this functions creates a new one with all
414 fields set to zero, sets INF's inferior to it, and then returns
415 a pointer to that newly allocated ada_inferior_data. */
417 static struct ada_inferior_data *
418 get_ada_inferior_data (struct inferior *inf)
420 struct ada_inferior_data *data;
422 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
425 data = XCNEW (struct ada_inferior_data);
426 set_inferior_data (inf, ada_inferior_data, data);
432 /* Perform all necessary cleanups regarding our module's inferior data
433 that is required after the inferior INF just exited. */
436 ada_inferior_exit (struct inferior *inf)
438 ada_inferior_data_cleanup (inf, NULL);
439 set_inferior_data (inf, ada_inferior_data, NULL);
443 /* program-space-specific data. */
445 /* This module's per-program-space data. */
446 struct ada_pspace_data
448 /* The Ada symbol cache. */
449 struct ada_symbol_cache *sym_cache;
452 /* Key to our per-program-space data. */
453 static const struct program_space_data *ada_pspace_data_handle;
455 /* Return this module's data for the given program space (PSPACE).
456 If not is found, add a zero'ed one now.
458 This function always returns a valid object. */
460 static struct ada_pspace_data *
461 get_ada_pspace_data (struct program_space *pspace)
463 struct ada_pspace_data *data;
465 data = ((struct ada_pspace_data *)
466 program_space_data (pspace, ada_pspace_data_handle));
469 data = XCNEW (struct ada_pspace_data);
470 set_program_space_data (pspace, ada_pspace_data_handle, data);
476 /* The cleanup callback for this module's per-program-space data. */
479 ada_pspace_data_cleanup (struct program_space *pspace, void *data)
481 struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data;
483 if (pspace_data->sym_cache != NULL)
484 ada_free_symbol_cache (pspace_data->sym_cache);
490 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
491 all typedef layers have been peeled. Otherwise, return TYPE.
493 Normally, we really expect a typedef type to only have 1 typedef layer.
494 In other words, we really expect the target type of a typedef type to be
495 a non-typedef type. This is particularly true for Ada units, because
496 the language does not have a typedef vs not-typedef distinction.
497 In that respect, the Ada compiler has been trying to eliminate as many
498 typedef definitions in the debugging information, since they generally
499 do not bring any extra information (we still use typedef under certain
500 circumstances related mostly to the GNAT encoding).
502 Unfortunately, we have seen situations where the debugging information
503 generated by the compiler leads to such multiple typedef layers. For
504 instance, consider the following example with stabs:
506 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
507 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
509 This is an error in the debugging information which causes type
510 pck__float_array___XUP to be defined twice, and the second time,
511 it is defined as a typedef of a typedef.
513 This is on the fringe of legality as far as debugging information is
514 concerned, and certainly unexpected. But it is easy to handle these
515 situations correctly, so we can afford to be lenient in this case. */
518 ada_typedef_target_type (struct type *type)
520 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
521 type = TYPE_TARGET_TYPE (type);
525 /* Given DECODED_NAME a string holding a symbol name in its
526 decoded form (ie using the Ada dotted notation), returns
527 its unqualified name. */
530 ada_unqualified_name (const char *decoded_name)
534 /* If the decoded name starts with '<', it means that the encoded
535 name does not follow standard naming conventions, and thus that
536 it is not your typical Ada symbol name. Trying to unqualify it
537 is therefore pointless and possibly erroneous. */
538 if (decoded_name[0] == '<')
541 result = strrchr (decoded_name, '.');
543 result++; /* Skip the dot... */
545 result = decoded_name;
550 /* Return a string starting with '<', followed by STR, and '>'.
551 The result is good until the next call. */
554 add_angle_brackets (const char *str)
556 static char *result = NULL;
559 result = xstrprintf ("<%s>", str);
564 ada_get_gdb_completer_word_break_characters (void)
566 return ada_completer_word_break_characters;
569 /* Print an array element index using the Ada syntax. */
572 ada_print_array_index (struct value *index_value, struct ui_file *stream,
573 const struct value_print_options *options)
575 LA_VALUE_PRINT (index_value, stream, options);
576 fprintf_filtered (stream, " => ");
579 /* Assuming VECT points to an array of *SIZE objects of size
580 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
581 updating *SIZE as necessary and returning the (new) array. */
584 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
586 if (*size < min_size)
589 if (*size < min_size)
591 vect = xrealloc (vect, *size * element_size);
596 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
597 suffix of FIELD_NAME beginning "___". */
600 field_name_match (const char *field_name, const char *target)
602 int len = strlen (target);
605 (strncmp (field_name, target, len) == 0
606 && (field_name[len] == '\0'
607 || (startswith (field_name + len, "___")
608 && strcmp (field_name + strlen (field_name) - 6,
613 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
614 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
615 and return its index. This function also handles fields whose name
616 have ___ suffixes because the compiler sometimes alters their name
617 by adding such a suffix to represent fields with certain constraints.
618 If the field could not be found, return a negative number if
619 MAYBE_MISSING is set. Otherwise raise an error. */
622 ada_get_field_index (const struct type *type, const char *field_name,
626 struct type *struct_type = check_typedef ((struct type *) type);
628 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
629 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
633 error (_("Unable to find field %s in struct %s. Aborting"),
634 field_name, TYPE_NAME (struct_type));
639 /* The length of the prefix of NAME prior to any "___" suffix. */
642 ada_name_prefix_len (const char *name)
648 const char *p = strstr (name, "___");
651 return strlen (name);
657 /* Return non-zero if SUFFIX is a suffix of STR.
658 Return zero if STR is null. */
661 is_suffix (const char *str, const char *suffix)
668 len2 = strlen (suffix);
669 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
672 /* The contents of value VAL, treated as a value of type TYPE. The
673 result is an lval in memory if VAL is. */
675 static struct value *
676 coerce_unspec_val_to_type (struct value *val, struct type *type)
678 type = ada_check_typedef (type);
679 if (value_type (val) == type)
683 struct value *result;
685 /* Make sure that the object size is not unreasonable before
686 trying to allocate some memory for it. */
687 ada_ensure_varsize_limit (type);
690 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
691 result = allocate_value_lazy (type);
694 result = allocate_value (type);
695 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
697 set_value_component_location (result, val);
698 set_value_bitsize (result, value_bitsize (val));
699 set_value_bitpos (result, value_bitpos (val));
700 set_value_address (result, value_address (val));
705 static const gdb_byte *
706 cond_offset_host (const gdb_byte *valaddr, long offset)
711 return valaddr + offset;
715 cond_offset_target (CORE_ADDR address, long offset)
720 return address + offset;
723 /* Issue a warning (as for the definition of warning in utils.c, but
724 with exactly one argument rather than ...), unless the limit on the
725 number of warnings has passed during the evaluation of the current
728 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
729 provided by "complaint". */
730 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
733 lim_warning (const char *format, ...)
737 va_start (args, format);
738 warnings_issued += 1;
739 if (warnings_issued <= warning_limit)
740 vwarning (format, args);
745 /* Issue an error if the size of an object of type T is unreasonable,
746 i.e. if it would be a bad idea to allocate a value of this type in
750 ada_ensure_varsize_limit (const struct type *type)
752 if (TYPE_LENGTH (type) > varsize_limit)
753 error (_("object size is larger than varsize-limit"));
756 /* Maximum value of a SIZE-byte signed integer type. */
758 max_of_size (int size)
760 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
762 return top_bit | (top_bit - 1);
765 /* Minimum value of a SIZE-byte signed integer type. */
767 min_of_size (int size)
769 return -max_of_size (size) - 1;
772 /* Maximum value of a SIZE-byte unsigned integer type. */
774 umax_of_size (int size)
776 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
778 return top_bit | (top_bit - 1);
781 /* Maximum value of integral type T, as a signed quantity. */
783 max_of_type (struct type *t)
785 if (TYPE_UNSIGNED (t))
786 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
788 return max_of_size (TYPE_LENGTH (t));
791 /* Minimum value of integral type T, as a signed quantity. */
793 min_of_type (struct type *t)
795 if (TYPE_UNSIGNED (t))
798 return min_of_size (TYPE_LENGTH (t));
801 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
803 ada_discrete_type_high_bound (struct type *type)
805 type = resolve_dynamic_type (type, NULL, 0);
806 switch (TYPE_CODE (type))
808 case TYPE_CODE_RANGE:
809 return TYPE_HIGH_BOUND (type);
811 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
816 return max_of_type (type);
818 error (_("Unexpected type in ada_discrete_type_high_bound."));
822 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
824 ada_discrete_type_low_bound (struct type *type)
826 type = resolve_dynamic_type (type, NULL, 0);
827 switch (TYPE_CODE (type))
829 case TYPE_CODE_RANGE:
830 return TYPE_LOW_BOUND (type);
832 return TYPE_FIELD_ENUMVAL (type, 0);
837 return min_of_type (type);
839 error (_("Unexpected type in ada_discrete_type_low_bound."));
843 /* The identity on non-range types. For range types, the underlying
844 non-range scalar type. */
847 get_base_type (struct type *type)
849 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
851 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
853 type = TYPE_TARGET_TYPE (type);
858 /* Return a decoded version of the given VALUE. This means returning
859 a value whose type is obtained by applying all the GNAT-specific
860 encondings, making the resulting type a static but standard description
861 of the initial type. */
864 ada_get_decoded_value (struct value *value)
866 struct type *type = ada_check_typedef (value_type (value));
868 if (ada_is_array_descriptor_type (type)
869 || (ada_is_constrained_packed_array_type (type)
870 && TYPE_CODE (type) != TYPE_CODE_PTR))
872 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
873 value = ada_coerce_to_simple_array_ptr (value);
875 value = ada_coerce_to_simple_array (value);
878 value = ada_to_fixed_value (value);
883 /* Same as ada_get_decoded_value, but with the given TYPE.
884 Because there is no associated actual value for this type,
885 the resulting type might be a best-effort approximation in
886 the case of dynamic types. */
889 ada_get_decoded_type (struct type *type)
891 type = to_static_fixed_type (type);
892 if (ada_is_constrained_packed_array_type (type))
893 type = ada_coerce_to_simple_array_type (type);
899 /* Language Selection */
901 /* If the main program is in Ada, return language_ada, otherwise return LANG
902 (the main program is in Ada iif the adainit symbol is found). */
905 ada_update_initial_language (enum language lang)
907 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
908 (struct objfile *) NULL).minsym != NULL)
914 /* If the main procedure is written in Ada, then return its name.
915 The result is good until the next call. Return NULL if the main
916 procedure doesn't appear to be in Ada. */
921 struct bound_minimal_symbol msym;
922 static char *main_program_name = NULL;
924 /* For Ada, the name of the main procedure is stored in a specific
925 string constant, generated by the binder. Look for that symbol,
926 extract its address, and then read that string. If we didn't find
927 that string, then most probably the main procedure is not written
929 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
931 if (msym.minsym != NULL)
933 CORE_ADDR main_program_name_addr;
936 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
937 if (main_program_name_addr == 0)
938 error (_("Invalid address for Ada main program name."));
940 xfree (main_program_name);
941 target_read_string (main_program_name_addr, &main_program_name,
946 return main_program_name;
949 /* The main procedure doesn't seem to be in Ada. */
955 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
958 const struct ada_opname_map ada_opname_table[] = {
959 {"Oadd", "\"+\"", BINOP_ADD},
960 {"Osubtract", "\"-\"", BINOP_SUB},
961 {"Omultiply", "\"*\"", BINOP_MUL},
962 {"Odivide", "\"/\"", BINOP_DIV},
963 {"Omod", "\"mod\"", BINOP_MOD},
964 {"Orem", "\"rem\"", BINOP_REM},
965 {"Oexpon", "\"**\"", BINOP_EXP},
966 {"Olt", "\"<\"", BINOP_LESS},
967 {"Ole", "\"<=\"", BINOP_LEQ},
968 {"Ogt", "\">\"", BINOP_GTR},
969 {"Oge", "\">=\"", BINOP_GEQ},
970 {"Oeq", "\"=\"", BINOP_EQUAL},
971 {"One", "\"/=\"", BINOP_NOTEQUAL},
972 {"Oand", "\"and\"", BINOP_BITWISE_AND},
973 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
974 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
975 {"Oconcat", "\"&\"", BINOP_CONCAT},
976 {"Oabs", "\"abs\"", UNOP_ABS},
977 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
978 {"Oadd", "\"+\"", UNOP_PLUS},
979 {"Osubtract", "\"-\"", UNOP_NEG},
983 /* The "encoded" form of DECODED, according to GNAT conventions. The
984 result is valid until the next call to ada_encode. If
985 THROW_ERRORS, throw an error if invalid operator name is found.
986 Otherwise, return NULL in that case. */
989 ada_encode_1 (const char *decoded, bool throw_errors)
991 static char *encoding_buffer = NULL;
992 static size_t encoding_buffer_size = 0;
999 GROW_VECT (encoding_buffer, encoding_buffer_size,
1000 2 * strlen (decoded) + 10);
1003 for (p = decoded; *p != '\0'; p += 1)
1007 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
1012 const struct ada_opname_map *mapping;
1014 for (mapping = ada_opname_table;
1015 mapping->encoded != NULL
1016 && !startswith (p, mapping->decoded); mapping += 1)
1018 if (mapping->encoded == NULL)
1021 error (_("invalid Ada operator name: %s"), p);
1025 strcpy (encoding_buffer + k, mapping->encoded);
1026 k += strlen (mapping->encoded);
1031 encoding_buffer[k] = *p;
1036 encoding_buffer[k] = '\0';
1037 return encoding_buffer;
1040 /* The "encoded" form of DECODED, according to GNAT conventions.
1041 The result is valid until the next call to ada_encode. */
1044 ada_encode (const char *decoded)
1046 return ada_encode_1 (decoded, true);
1049 /* Return NAME folded to lower case, or, if surrounded by single
1050 quotes, unfolded, but with the quotes stripped away. Result good
1054 ada_fold_name (const char *name)
1056 static char *fold_buffer = NULL;
1057 static size_t fold_buffer_size = 0;
1059 int len = strlen (name);
1060 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
1062 if (name[0] == '\'')
1064 strncpy (fold_buffer, name + 1, len - 2);
1065 fold_buffer[len - 2] = '\000';
1071 for (i = 0; i <= len; i += 1)
1072 fold_buffer[i] = tolower (name[i]);
1078 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1081 is_lower_alphanum (const char c)
1083 return (isdigit (c) || (isalpha (c) && islower (c)));
1086 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1087 This function saves in LEN the length of that same symbol name but
1088 without either of these suffixes:
1094 These are suffixes introduced by the compiler for entities such as
1095 nested subprogram for instance, in order to avoid name clashes.
1096 They do not serve any purpose for the debugger. */
1099 ada_remove_trailing_digits (const char *encoded, int *len)
1101 if (*len > 1 && isdigit (encoded[*len - 1]))
1105 while (i > 0 && isdigit (encoded[i]))
1107 if (i >= 0 && encoded[i] == '.')
1109 else if (i >= 0 && encoded[i] == '$')
1111 else if (i >= 2 && startswith (encoded + i - 2, "___"))
1113 else if (i >= 1 && startswith (encoded + i - 1, "__"))
1118 /* Remove the suffix introduced by the compiler for protected object
1122 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1124 /* Remove trailing N. */
1126 /* Protected entry subprograms are broken into two
1127 separate subprograms: The first one is unprotected, and has
1128 a 'N' suffix; the second is the protected version, and has
1129 the 'P' suffix. The second calls the first one after handling
1130 the protection. Since the P subprograms are internally generated,
1131 we leave these names undecoded, giving the user a clue that this
1132 entity is internal. */
1135 && encoded[*len - 1] == 'N'
1136 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1140 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1143 ada_remove_Xbn_suffix (const char *encoded, int *len)
1147 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1150 if (encoded[i] != 'X')
1156 if (isalnum (encoded[i-1]))
1160 /* If ENCODED follows the GNAT entity encoding conventions, then return
1161 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1162 replaced by ENCODED.
1164 The resulting string is valid until the next call of ada_decode.
1165 If the string is unchanged by decoding, the original string pointer
1169 ada_decode (const char *encoded)
1176 static char *decoding_buffer = NULL;
1177 static size_t decoding_buffer_size = 0;
1179 /* The name of the Ada main procedure starts with "_ada_".
1180 This prefix is not part of the decoded name, so skip this part
1181 if we see this prefix. */
1182 if (startswith (encoded, "_ada_"))
1185 /* If the name starts with '_', then it is not a properly encoded
1186 name, so do not attempt to decode it. Similarly, if the name
1187 starts with '<', the name should not be decoded. */
1188 if (encoded[0] == '_' || encoded[0] == '<')
1191 len0 = strlen (encoded);
1193 ada_remove_trailing_digits (encoded, &len0);
1194 ada_remove_po_subprogram_suffix (encoded, &len0);
1196 /* Remove the ___X.* suffix if present. Do not forget to verify that
1197 the suffix is located before the current "end" of ENCODED. We want
1198 to avoid re-matching parts of ENCODED that have previously been
1199 marked as discarded (by decrementing LEN0). */
1200 p = strstr (encoded, "___");
1201 if (p != NULL && p - encoded < len0 - 3)
1209 /* Remove any trailing TKB suffix. It tells us that this symbol
1210 is for the body of a task, but that information does not actually
1211 appear in the decoded name. */
1213 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1216 /* Remove any trailing TB suffix. The TB suffix is slightly different
1217 from the TKB suffix because it is used for non-anonymous task
1220 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1223 /* Remove trailing "B" suffixes. */
1224 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1226 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1229 /* Make decoded big enough for possible expansion by operator name. */
1231 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1232 decoded = decoding_buffer;
1234 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1236 if (len0 > 1 && isdigit (encoded[len0 - 1]))
1239 while ((i >= 0 && isdigit (encoded[i]))
1240 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1242 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1244 else if (encoded[i] == '$')
1248 /* The first few characters that are not alphabetic are not part
1249 of any encoding we use, so we can copy them over verbatim. */
1251 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1252 decoded[j] = encoded[i];
1257 /* Is this a symbol function? */
1258 if (at_start_name && encoded[i] == 'O')
1262 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1264 int op_len = strlen (ada_opname_table[k].encoded);
1265 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1267 && !isalnum (encoded[i + op_len]))
1269 strcpy (decoded + j, ada_opname_table[k].decoded);
1272 j += strlen (ada_opname_table[k].decoded);
1276 if (ada_opname_table[k].encoded != NULL)
1281 /* Replace "TK__" with "__", which will eventually be translated
1282 into "." (just below). */
1284 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1287 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1288 be translated into "." (just below). These are internal names
1289 generated for anonymous blocks inside which our symbol is nested. */
1291 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1292 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1293 && isdigit (encoded [i+4]))
1297 while (k < len0 && isdigit (encoded[k]))
1298 k++; /* Skip any extra digit. */
1300 /* Double-check that the "__B_{DIGITS}+" sequence we found
1301 is indeed followed by "__". */
1302 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1306 /* Remove _E{DIGITS}+[sb] */
1308 /* Just as for protected object subprograms, there are 2 categories
1309 of subprograms created by the compiler for each entry. The first
1310 one implements the actual entry code, and has a suffix following
1311 the convention above; the second one implements the barrier and
1312 uses the same convention as above, except that the 'E' is replaced
1315 Just as above, we do not decode the name of barrier functions
1316 to give the user a clue that the code he is debugging has been
1317 internally generated. */
1319 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1320 && isdigit (encoded[i+2]))
1324 while (k < len0 && isdigit (encoded[k]))
1328 && (encoded[k] == 'b' || encoded[k] == 's'))
1331 /* Just as an extra precaution, make sure that if this
1332 suffix is followed by anything else, it is a '_'.
1333 Otherwise, we matched this sequence by accident. */
1335 || (k < len0 && encoded[k] == '_'))
1340 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1341 the GNAT front-end in protected object subprograms. */
1344 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1346 /* Backtrack a bit up until we reach either the begining of
1347 the encoded name, or "__". Make sure that we only find
1348 digits or lowercase characters. */
1349 const char *ptr = encoded + i - 1;
1351 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1354 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1358 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1360 /* This is a X[bn]* sequence not separated from the previous
1361 part of the name with a non-alpha-numeric character (in other
1362 words, immediately following an alpha-numeric character), then
1363 verify that it is placed at the end of the encoded name. If
1364 not, then the encoding is not valid and we should abort the
1365 decoding. Otherwise, just skip it, it is used in body-nested
1369 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1373 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1375 /* Replace '__' by '.'. */
1383 /* It's a character part of the decoded name, so just copy it
1385 decoded[j] = encoded[i];
1390 decoded[j] = '\000';
1392 /* Decoded names should never contain any uppercase character.
1393 Double-check this, and abort the decoding if we find one. */
1395 for (i = 0; decoded[i] != '\0'; i += 1)
1396 if (isupper (decoded[i]) || decoded[i] == ' ')
1399 if (strcmp (decoded, encoded) == 0)
1405 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1406 decoded = decoding_buffer;
1407 if (encoded[0] == '<')
1408 strcpy (decoded, encoded);
1410 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
1415 /* Table for keeping permanent unique copies of decoded names. Once
1416 allocated, names in this table are never released. While this is a
1417 storage leak, it should not be significant unless there are massive
1418 changes in the set of decoded names in successive versions of a
1419 symbol table loaded during a single session. */
1420 static struct htab *decoded_names_store;
1422 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1423 in the language-specific part of GSYMBOL, if it has not been
1424 previously computed. Tries to save the decoded name in the same
1425 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1426 in any case, the decoded symbol has a lifetime at least that of
1428 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1429 const, but nevertheless modified to a semantically equivalent form
1430 when a decoded name is cached in it. */
1433 ada_decode_symbol (const struct general_symbol_info *arg)
1435 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1436 const char **resultp =
1437 &gsymbol->language_specific.demangled_name;
1439 if (!gsymbol->ada_mangled)
1441 const char *decoded = ada_decode (gsymbol->name);
1442 struct obstack *obstack = gsymbol->language_specific.obstack;
1444 gsymbol->ada_mangled = 1;
1446 if (obstack != NULL)
1448 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
1451 /* Sometimes, we can't find a corresponding objfile, in
1452 which case, we put the result on the heap. Since we only
1453 decode when needed, we hope this usually does not cause a
1454 significant memory leak (FIXME). */
1456 char **slot = (char **) htab_find_slot (decoded_names_store,
1460 *slot = xstrdup (decoded);
1469 ada_la_decode (const char *encoded, int options)
1471 return xstrdup (ada_decode (encoded));
1474 /* Implement la_sniff_from_mangled_name for Ada. */
1477 ada_sniff_from_mangled_name (const char *mangled, char **out)
1479 const char *demangled = ada_decode (mangled);
1483 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1485 /* Set the gsymbol language to Ada, but still return 0.
1486 Two reasons for that:
1488 1. For Ada, we prefer computing the symbol's decoded name
1489 on the fly rather than pre-compute it, in order to save
1490 memory (Ada projects are typically very large).
1492 2. There are some areas in the definition of the GNAT
1493 encoding where, with a bit of bad luck, we might be able
1494 to decode a non-Ada symbol, generating an incorrect
1495 demangled name (Eg: names ending with "TB" for instance
1496 are identified as task bodies and so stripped from
1497 the decoded name returned).
1499 Returning 1, here, but not setting *DEMANGLED, helps us get a
1500 little bit of the best of both worlds. Because we're last,
1501 we should not affect any of the other languages that were
1502 able to demangle the symbol before us; we get to correctly
1503 tag Ada symbols as such; and even if we incorrectly tagged a
1504 non-Ada symbol, which should be rare, any routing through the
1505 Ada language should be transparent (Ada tries to behave much
1506 like C/C++ with non-Ada symbols). */
1517 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1518 generated by the GNAT compiler to describe the index type used
1519 for each dimension of an array, check whether it follows the latest
1520 known encoding. If not, fix it up to conform to the latest encoding.
1521 Otherwise, do nothing. This function also does nothing if
1522 INDEX_DESC_TYPE is NULL.
1524 The GNAT encoding used to describle the array index type evolved a bit.
1525 Initially, the information would be provided through the name of each
1526 field of the structure type only, while the type of these fields was
1527 described as unspecified and irrelevant. The debugger was then expected
1528 to perform a global type lookup using the name of that field in order
1529 to get access to the full index type description. Because these global
1530 lookups can be very expensive, the encoding was later enhanced to make
1531 the global lookup unnecessary by defining the field type as being
1532 the full index type description.
1534 The purpose of this routine is to allow us to support older versions
1535 of the compiler by detecting the use of the older encoding, and by
1536 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1537 we essentially replace each field's meaningless type by the associated
1541 ada_fixup_array_indexes_type (struct type *index_desc_type)
1545 if (index_desc_type == NULL)
1547 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1549 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1550 to check one field only, no need to check them all). If not, return
1553 If our INDEX_DESC_TYPE was generated using the older encoding,
1554 the field type should be a meaningless integer type whose name
1555 is not equal to the field name. */
1556 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1557 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1558 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1561 /* Fixup each field of INDEX_DESC_TYPE. */
1562 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1564 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1565 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1568 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1572 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1574 static const char *bound_name[] = {
1575 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1576 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1579 /* Maximum number of array dimensions we are prepared to handle. */
1581 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1584 /* The desc_* routines return primitive portions of array descriptors
1587 /* The descriptor or array type, if any, indicated by TYPE; removes
1588 level of indirection, if needed. */
1590 static struct type *
1591 desc_base_type (struct type *type)
1595 type = ada_check_typedef (type);
1596 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1597 type = ada_typedef_target_type (type);
1600 && (TYPE_CODE (type) == TYPE_CODE_PTR
1601 || TYPE_CODE (type) == TYPE_CODE_REF))
1602 return ada_check_typedef (TYPE_TARGET_TYPE (type));
1607 /* True iff TYPE indicates a "thin" array pointer type. */
1610 is_thin_pntr (struct type *type)
1613 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1614 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1617 /* The descriptor type for thin pointer type TYPE. */
1619 static struct type *
1620 thin_descriptor_type (struct type *type)
1622 struct type *base_type = desc_base_type (type);
1624 if (base_type == NULL)
1626 if (is_suffix (ada_type_name (base_type), "___XVE"))
1630 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1632 if (alt_type == NULL)
1639 /* A pointer to the array data for thin-pointer value VAL. */
1641 static struct value *
1642 thin_data_pntr (struct value *val)
1644 struct type *type = ada_check_typedef (value_type (val));
1645 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1647 data_type = lookup_pointer_type (data_type);
1649 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1650 return value_cast (data_type, value_copy (val));
1652 return value_from_longest (data_type, value_address (val));
1655 /* True iff TYPE indicates a "thick" array pointer type. */
1658 is_thick_pntr (struct type *type)
1660 type = desc_base_type (type);
1661 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1662 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1665 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1666 pointer to one, the type of its bounds data; otherwise, NULL. */
1668 static struct type *
1669 desc_bounds_type (struct type *type)
1673 type = desc_base_type (type);
1677 else if (is_thin_pntr (type))
1679 type = thin_descriptor_type (type);
1682 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1684 return ada_check_typedef (r);
1686 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1688 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1690 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1695 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1696 one, a pointer to its bounds data. Otherwise NULL. */
1698 static struct value *
1699 desc_bounds (struct value *arr)
1701 struct type *type = ada_check_typedef (value_type (arr));
1703 if (is_thin_pntr (type))
1705 struct type *bounds_type =
1706 desc_bounds_type (thin_descriptor_type (type));
1709 if (bounds_type == NULL)
1710 error (_("Bad GNAT array descriptor"));
1712 /* NOTE: The following calculation is not really kosher, but
1713 since desc_type is an XVE-encoded type (and shouldn't be),
1714 the correct calculation is a real pain. FIXME (and fix GCC). */
1715 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1716 addr = value_as_long (arr);
1718 addr = value_address (arr);
1721 value_from_longest (lookup_pointer_type (bounds_type),
1722 addr - TYPE_LENGTH (bounds_type));
1725 else if (is_thick_pntr (type))
1727 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1728 _("Bad GNAT array descriptor"));
1729 struct type *p_bounds_type = value_type (p_bounds);
1732 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1734 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1736 if (TYPE_STUB (target_type))
1737 p_bounds = value_cast (lookup_pointer_type
1738 (ada_check_typedef (target_type)),
1742 error (_("Bad GNAT array descriptor"));
1750 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1751 position of the field containing the address of the bounds data. */
1754 fat_pntr_bounds_bitpos (struct type *type)
1756 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1759 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1760 size of the field containing the address of the bounds data. */
1763 fat_pntr_bounds_bitsize (struct type *type)
1765 type = desc_base_type (type);
1767 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1768 return TYPE_FIELD_BITSIZE (type, 1);
1770 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1773 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1774 pointer to one, the type of its array data (a array-with-no-bounds type);
1775 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1778 static struct type *
1779 desc_data_target_type (struct type *type)
1781 type = desc_base_type (type);
1783 /* NOTE: The following is bogus; see comment in desc_bounds. */
1784 if (is_thin_pntr (type))
1785 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
1786 else if (is_thick_pntr (type))
1788 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1791 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
1792 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1798 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1801 static struct value *
1802 desc_data (struct value *arr)
1804 struct type *type = value_type (arr);
1806 if (is_thin_pntr (type))
1807 return thin_data_pntr (arr);
1808 else if (is_thick_pntr (type))
1809 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1810 _("Bad GNAT array descriptor"));
1816 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1817 position of the field containing the address of the data. */
1820 fat_pntr_data_bitpos (struct type *type)
1822 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1825 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1826 size of the field containing the address of the data. */
1829 fat_pntr_data_bitsize (struct type *type)
1831 type = desc_base_type (type);
1833 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1834 return TYPE_FIELD_BITSIZE (type, 0);
1836 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1839 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1840 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1841 bound, if WHICH is 1. The first bound is I=1. */
1843 static struct value *
1844 desc_one_bound (struct value *bounds, int i, int which)
1846 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1847 _("Bad GNAT array descriptor bounds"));
1850 /* If BOUNDS is an array-bounds structure type, return the bit position
1851 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1852 bound, if WHICH is 1. The first bound is I=1. */
1855 desc_bound_bitpos (struct type *type, int i, int which)
1857 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1860 /* If BOUNDS is an array-bounds structure type, return the bit field size
1861 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1862 bound, if WHICH is 1. The first bound is I=1. */
1865 desc_bound_bitsize (struct type *type, int i, int which)
1867 type = desc_base_type (type);
1869 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1870 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1872 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1875 /* If TYPE is the type of an array-bounds structure, the type of its
1876 Ith bound (numbering from 1). Otherwise, NULL. */
1878 static struct type *
1879 desc_index_type (struct type *type, int i)
1881 type = desc_base_type (type);
1883 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1884 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1889 /* The number of index positions in the array-bounds type TYPE.
1890 Return 0 if TYPE is NULL. */
1893 desc_arity (struct type *type)
1895 type = desc_base_type (type);
1898 return TYPE_NFIELDS (type) / 2;
1902 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1903 an array descriptor type (representing an unconstrained array
1907 ada_is_direct_array_type (struct type *type)
1911 type = ada_check_typedef (type);
1912 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1913 || ada_is_array_descriptor_type (type));
1916 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1920 ada_is_array_type (struct type *type)
1923 && (TYPE_CODE (type) == TYPE_CODE_PTR
1924 || TYPE_CODE (type) == TYPE_CODE_REF))
1925 type = TYPE_TARGET_TYPE (type);
1926 return ada_is_direct_array_type (type);
1929 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1932 ada_is_simple_array_type (struct type *type)
1936 type = ada_check_typedef (type);
1937 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1938 || (TYPE_CODE (type) == TYPE_CODE_PTR
1939 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1940 == TYPE_CODE_ARRAY));
1943 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1946 ada_is_array_descriptor_type (struct type *type)
1948 struct type *data_type = desc_data_target_type (type);
1952 type = ada_check_typedef (type);
1953 return (data_type != NULL
1954 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1955 && desc_arity (desc_bounds_type (type)) > 0);
1958 /* Non-zero iff type is a partially mal-formed GNAT array
1959 descriptor. FIXME: This is to compensate for some problems with
1960 debugging output from GNAT. Re-examine periodically to see if it
1964 ada_is_bogus_array_descriptor (struct type *type)
1968 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1969 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1970 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1971 && !ada_is_array_descriptor_type (type);
1975 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1976 (fat pointer) returns the type of the array data described---specifically,
1977 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1978 in from the descriptor; otherwise, they are left unspecified. If
1979 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1980 returns NULL. The result is simply the type of ARR if ARR is not
1983 ada_type_of_array (struct value *arr, int bounds)
1985 if (ada_is_constrained_packed_array_type (value_type (arr)))
1986 return decode_constrained_packed_array_type (value_type (arr));
1988 if (!ada_is_array_descriptor_type (value_type (arr)))
1989 return value_type (arr);
1993 struct type *array_type =
1994 ada_check_typedef (desc_data_target_type (value_type (arr)));
1996 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1997 TYPE_FIELD_BITSIZE (array_type, 0) =
1998 decode_packed_array_bitsize (value_type (arr));
2004 struct type *elt_type;
2006 struct value *descriptor;
2008 elt_type = ada_array_element_type (value_type (arr), -1);
2009 arity = ada_array_arity (value_type (arr));
2011 if (elt_type == NULL || arity == 0)
2012 return ada_check_typedef (value_type (arr));
2014 descriptor = desc_bounds (arr);
2015 if (value_as_long (descriptor) == 0)
2019 struct type *range_type = alloc_type_copy (value_type (arr));
2020 struct type *array_type = alloc_type_copy (value_type (arr));
2021 struct value *low = desc_one_bound (descriptor, arity, 0);
2022 struct value *high = desc_one_bound (descriptor, arity, 1);
2025 create_static_range_type (range_type, value_type (low),
2026 longest_to_int (value_as_long (low)),
2027 longest_to_int (value_as_long (high)));
2028 elt_type = create_array_type (array_type, elt_type, range_type);
2030 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2032 /* We need to store the element packed bitsize, as well as
2033 recompute the array size, because it was previously
2034 computed based on the unpacked element size. */
2035 LONGEST lo = value_as_long (low);
2036 LONGEST hi = value_as_long (high);
2038 TYPE_FIELD_BITSIZE (elt_type, 0) =
2039 decode_packed_array_bitsize (value_type (arr));
2040 /* If the array has no element, then the size is already
2041 zero, and does not need to be recomputed. */
2045 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2047 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2052 return lookup_pointer_type (elt_type);
2056 /* If ARR does not represent an array, returns ARR unchanged.
2057 Otherwise, returns either a standard GDB array with bounds set
2058 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2059 GDB array. Returns NULL if ARR is a null fat pointer. */
2062 ada_coerce_to_simple_array_ptr (struct value *arr)
2064 if (ada_is_array_descriptor_type (value_type (arr)))
2066 struct type *arrType = ada_type_of_array (arr, 1);
2068 if (arrType == NULL)
2070 return value_cast (arrType, value_copy (desc_data (arr)));
2072 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2073 return decode_constrained_packed_array (arr);
2078 /* If ARR does not represent an array, returns ARR unchanged.
2079 Otherwise, returns a standard GDB array describing ARR (which may
2080 be ARR itself if it already is in the proper form). */
2083 ada_coerce_to_simple_array (struct value *arr)
2085 if (ada_is_array_descriptor_type (value_type (arr)))
2087 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2090 error (_("Bounds unavailable for null array pointer."));
2091 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
2092 return value_ind (arrVal);
2094 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2095 return decode_constrained_packed_array (arr);
2100 /* If TYPE represents a GNAT array type, return it translated to an
2101 ordinary GDB array type (possibly with BITSIZE fields indicating
2102 packing). For other types, is the identity. */
2105 ada_coerce_to_simple_array_type (struct type *type)
2107 if (ada_is_constrained_packed_array_type (type))
2108 return decode_constrained_packed_array_type (type);
2110 if (ada_is_array_descriptor_type (type))
2111 return ada_check_typedef (desc_data_target_type (type));
2116 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2119 ada_is_packed_array_type (struct type *type)
2123 type = desc_base_type (type);
2124 type = ada_check_typedef (type);
2126 ada_type_name (type) != NULL
2127 && strstr (ada_type_name (type), "___XP") != NULL;
2130 /* Non-zero iff TYPE represents a standard GNAT constrained
2131 packed-array type. */
2134 ada_is_constrained_packed_array_type (struct type *type)
2136 return ada_is_packed_array_type (type)
2137 && !ada_is_array_descriptor_type (type);
2140 /* Non-zero iff TYPE represents an array descriptor for a
2141 unconstrained packed-array type. */
2144 ada_is_unconstrained_packed_array_type (struct type *type)
2146 return ada_is_packed_array_type (type)
2147 && ada_is_array_descriptor_type (type);
2150 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2151 return the size of its elements in bits. */
2154 decode_packed_array_bitsize (struct type *type)
2156 const char *raw_name;
2160 /* Access to arrays implemented as fat pointers are encoded as a typedef
2161 of the fat pointer type. We need the name of the fat pointer type
2162 to do the decoding, so strip the typedef layer. */
2163 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2164 type = ada_typedef_target_type (type);
2166 raw_name = ada_type_name (ada_check_typedef (type));
2168 raw_name = ada_type_name (desc_base_type (type));
2173 tail = strstr (raw_name, "___XP");
2174 gdb_assert (tail != NULL);
2176 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2179 (_("could not understand bit size information on packed array"));
2186 /* Given that TYPE is a standard GDB array type with all bounds filled
2187 in, and that the element size of its ultimate scalar constituents
2188 (that is, either its elements, or, if it is an array of arrays, its
2189 elements' elements, etc.) is *ELT_BITS, return an identical type,
2190 but with the bit sizes of its elements (and those of any
2191 constituent arrays) recorded in the BITSIZE components of its
2192 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2195 Note that, for arrays whose index type has an XA encoding where
2196 a bound references a record discriminant, getting that discriminant,
2197 and therefore the actual value of that bound, is not possible
2198 because none of the given parameters gives us access to the record.
2199 This function assumes that it is OK in the context where it is being
2200 used to return an array whose bounds are still dynamic and where
2201 the length is arbitrary. */
2203 static struct type *
2204 constrained_packed_array_type (struct type *type, long *elt_bits)
2206 struct type *new_elt_type;
2207 struct type *new_type;
2208 struct type *index_type_desc;
2209 struct type *index_type;
2210 LONGEST low_bound, high_bound;
2212 type = ada_check_typedef (type);
2213 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2216 index_type_desc = ada_find_parallel_type (type, "___XA");
2217 if (index_type_desc)
2218 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2221 index_type = TYPE_INDEX_TYPE (type);
2223 new_type = alloc_type_copy (type);
2225 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2227 create_array_type (new_type, new_elt_type, index_type);
2228 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2229 TYPE_NAME (new_type) = ada_type_name (type);
2231 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2232 && is_dynamic_type (check_typedef (index_type)))
2233 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
2234 low_bound = high_bound = 0;
2235 if (high_bound < low_bound)
2236 *elt_bits = TYPE_LENGTH (new_type) = 0;
2239 *elt_bits *= (high_bound - low_bound + 1);
2240 TYPE_LENGTH (new_type) =
2241 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2244 TYPE_FIXED_INSTANCE (new_type) = 1;
2248 /* The array type encoded by TYPE, where
2249 ada_is_constrained_packed_array_type (TYPE). */
2251 static struct type *
2252 decode_constrained_packed_array_type (struct type *type)
2254 const char *raw_name = ada_type_name (ada_check_typedef (type));
2257 struct type *shadow_type;
2261 raw_name = ada_type_name (desc_base_type (type));
2266 name = (char *) alloca (strlen (raw_name) + 1);
2267 tail = strstr (raw_name, "___XP");
2268 type = desc_base_type (type);
2270 memcpy (name, raw_name, tail - raw_name);
2271 name[tail - raw_name] = '\000';
2273 shadow_type = ada_find_parallel_type_with_name (type, name);
2275 if (shadow_type == NULL)
2277 lim_warning (_("could not find bounds information on packed array"));
2280 shadow_type = check_typedef (shadow_type);
2282 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2284 lim_warning (_("could not understand bounds "
2285 "information on packed array"));
2289 bits = decode_packed_array_bitsize (type);
2290 return constrained_packed_array_type (shadow_type, &bits);
2293 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2294 array, returns a simple array that denotes that array. Its type is a
2295 standard GDB array type except that the BITSIZEs of the array
2296 target types are set to the number of bits in each element, and the
2297 type length is set appropriately. */
2299 static struct value *
2300 decode_constrained_packed_array (struct value *arr)
2304 /* If our value is a pointer, then dereference it. Likewise if
2305 the value is a reference. Make sure that this operation does not
2306 cause the target type to be fixed, as this would indirectly cause
2307 this array to be decoded. The rest of the routine assumes that
2308 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2309 and "value_ind" routines to perform the dereferencing, as opposed
2310 to using "ada_coerce_ref" or "ada_value_ind". */
2311 arr = coerce_ref (arr);
2312 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
2313 arr = value_ind (arr);
2315 type = decode_constrained_packed_array_type (value_type (arr));
2318 error (_("can't unpack array"));
2322 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
2323 && ada_is_modular_type (value_type (arr)))
2325 /* This is a (right-justified) modular type representing a packed
2326 array with no wrapper. In order to interpret the value through
2327 the (left-justified) packed array type we just built, we must
2328 first left-justify it. */
2329 int bit_size, bit_pos;
2332 mod = ada_modulus (value_type (arr)) - 1;
2339 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2340 arr = ada_value_primitive_packed_val (arr, NULL,
2341 bit_pos / HOST_CHAR_BIT,
2342 bit_pos % HOST_CHAR_BIT,
2347 return coerce_unspec_val_to_type (arr, type);
2351 /* The value of the element of packed array ARR at the ARITY indices
2352 given in IND. ARR must be a simple array. */
2354 static struct value *
2355 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2358 int bits, elt_off, bit_off;
2359 long elt_total_bit_offset;
2360 struct type *elt_type;
2364 elt_total_bit_offset = 0;
2365 elt_type = ada_check_typedef (value_type (arr));
2366 for (i = 0; i < arity; i += 1)
2368 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
2369 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2371 (_("attempt to do packed indexing of "
2372 "something other than a packed array"));
2375 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2376 LONGEST lowerbound, upperbound;
2379 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2381 lim_warning (_("don't know bounds of array"));
2382 lowerbound = upperbound = 0;
2385 idx = pos_atr (ind[i]);
2386 if (idx < lowerbound || idx > upperbound)
2387 lim_warning (_("packed array index %ld out of bounds"),
2389 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2390 elt_total_bit_offset += (idx - lowerbound) * bits;
2391 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2394 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2395 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2397 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2402 /* Non-zero iff TYPE includes negative integer values. */
2405 has_negatives (struct type *type)
2407 switch (TYPE_CODE (type))
2412 return !TYPE_UNSIGNED (type);
2413 case TYPE_CODE_RANGE:
2414 return TYPE_LOW_BOUND (type) < 0;
2418 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2419 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2420 the unpacked buffer.
2422 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2423 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2425 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2428 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2430 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2433 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2434 gdb_byte *unpacked, int unpacked_len,
2435 int is_big_endian, int is_signed_type,
2438 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2439 int src_idx; /* Index into the source area */
2440 int src_bytes_left; /* Number of source bytes left to process. */
2441 int srcBitsLeft; /* Number of source bits left to move */
2442 int unusedLS; /* Number of bits in next significant
2443 byte of source that are unused */
2445 int unpacked_idx; /* Index into the unpacked buffer */
2446 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2448 unsigned long accum; /* Staging area for bits being transferred */
2449 int accumSize; /* Number of meaningful bits in accum */
2452 /* Transmit bytes from least to most significant; delta is the direction
2453 the indices move. */
2454 int delta = is_big_endian ? -1 : 1;
2456 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2458 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2459 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2460 bit_size, unpacked_len);
2462 srcBitsLeft = bit_size;
2463 src_bytes_left = src_len;
2464 unpacked_bytes_left = unpacked_len;
2469 src_idx = src_len - 1;
2471 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2475 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2481 unpacked_idx = unpacked_len - 1;
2485 /* Non-scalar values must be aligned at a byte boundary... */
2487 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2488 /* ... And are placed at the beginning (most-significant) bytes
2490 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2491 unpacked_bytes_left = unpacked_idx + 1;
2496 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2498 src_idx = unpacked_idx = 0;
2499 unusedLS = bit_offset;
2502 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2507 while (src_bytes_left > 0)
2509 /* Mask for removing bits of the next source byte that are not
2510 part of the value. */
2511 unsigned int unusedMSMask =
2512 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2514 /* Sign-extend bits for this byte. */
2515 unsigned int signMask = sign & ~unusedMSMask;
2518 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2519 accumSize += HOST_CHAR_BIT - unusedLS;
2520 if (accumSize >= HOST_CHAR_BIT)
2522 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2523 accumSize -= HOST_CHAR_BIT;
2524 accum >>= HOST_CHAR_BIT;
2525 unpacked_bytes_left -= 1;
2526 unpacked_idx += delta;
2528 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2530 src_bytes_left -= 1;
2533 while (unpacked_bytes_left > 0)
2535 accum |= sign << accumSize;
2536 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2537 accumSize -= HOST_CHAR_BIT;
2540 accum >>= HOST_CHAR_BIT;
2541 unpacked_bytes_left -= 1;
2542 unpacked_idx += delta;
2546 /* Create a new value of type TYPE from the contents of OBJ starting
2547 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2548 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2549 assigning through the result will set the field fetched from.
2550 VALADDR is ignored unless OBJ is NULL, in which case,
2551 VALADDR+OFFSET must address the start of storage containing the
2552 packed value. The value returned in this case is never an lval.
2553 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2556 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2557 long offset, int bit_offset, int bit_size,
2561 const gdb_byte *src; /* First byte containing data to unpack */
2563 const int is_scalar = is_scalar_type (type);
2564 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
2565 gdb::byte_vector staging;
2567 type = ada_check_typedef (type);
2570 src = valaddr + offset;
2572 src = value_contents (obj) + offset;
2574 if (is_dynamic_type (type))
2576 /* The length of TYPE might by dynamic, so we need to resolve
2577 TYPE in order to know its actual size, which we then use
2578 to create the contents buffer of the value we return.
2579 The difficulty is that the data containing our object is
2580 packed, and therefore maybe not at a byte boundary. So, what
2581 we do, is unpack the data into a byte-aligned buffer, and then
2582 use that buffer as our object's value for resolving the type. */
2583 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2584 staging.resize (staging_len);
2586 ada_unpack_from_contents (src, bit_offset, bit_size,
2587 staging.data (), staging.size (),
2588 is_big_endian, has_negatives (type),
2590 type = resolve_dynamic_type (type, staging.data (), 0);
2591 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2593 /* This happens when the length of the object is dynamic,
2594 and is actually smaller than the space reserved for it.
2595 For instance, in an array of variant records, the bit_size
2596 we're given is the array stride, which is constant and
2597 normally equal to the maximum size of its element.
2598 But, in reality, each element only actually spans a portion
2600 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2606 v = allocate_value (type);
2607 src = valaddr + offset;
2609 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2611 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2614 v = value_at (type, value_address (obj) + offset);
2615 buf = (gdb_byte *) alloca (src_len);
2616 read_memory (value_address (v), buf, src_len);
2621 v = allocate_value (type);
2622 src = value_contents (obj) + offset;
2627 long new_offset = offset;
2629 set_value_component_location (v, obj);
2630 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2631 set_value_bitsize (v, bit_size);
2632 if (value_bitpos (v) >= HOST_CHAR_BIT)
2635 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2637 set_value_offset (v, new_offset);
2639 /* Also set the parent value. This is needed when trying to
2640 assign a new value (in inferior memory). */
2641 set_value_parent (v, obj);
2644 set_value_bitsize (v, bit_size);
2645 unpacked = value_contents_writeable (v);
2649 memset (unpacked, 0, TYPE_LENGTH (type));
2653 if (staging.size () == TYPE_LENGTH (type))
2655 /* Small short-cut: If we've unpacked the data into a buffer
2656 of the same size as TYPE's length, then we can reuse that,
2657 instead of doing the unpacking again. */
2658 memcpy (unpacked, staging.data (), staging.size ());
2661 ada_unpack_from_contents (src, bit_offset, bit_size,
2662 unpacked, TYPE_LENGTH (type),
2663 is_big_endian, has_negatives (type), is_scalar);
2668 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2669 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2672 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2673 int src_offset, int n, int bits_big_endian_p)
2675 unsigned int accum, mask;
2676 int accum_bits, chunk_size;
2678 target += targ_offset / HOST_CHAR_BIT;
2679 targ_offset %= HOST_CHAR_BIT;
2680 source += src_offset / HOST_CHAR_BIT;
2681 src_offset %= HOST_CHAR_BIT;
2682 if (bits_big_endian_p)
2684 accum = (unsigned char) *source;
2686 accum_bits = HOST_CHAR_BIT - src_offset;
2692 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2693 accum_bits += HOST_CHAR_BIT;
2695 chunk_size = HOST_CHAR_BIT - targ_offset;
2698 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2699 mask = ((1 << chunk_size) - 1) << unused_right;
2702 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2704 accum_bits -= chunk_size;
2711 accum = (unsigned char) *source >> src_offset;
2713 accum_bits = HOST_CHAR_BIT - src_offset;
2717 accum = accum + ((unsigned char) *source << accum_bits);
2718 accum_bits += HOST_CHAR_BIT;
2720 chunk_size = HOST_CHAR_BIT - targ_offset;
2723 mask = ((1 << chunk_size) - 1) << targ_offset;
2724 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2726 accum_bits -= chunk_size;
2727 accum >>= chunk_size;
2734 /* Store the contents of FROMVAL into the location of TOVAL.
2735 Return a new value with the location of TOVAL and contents of
2736 FROMVAL. Handles assignment into packed fields that have
2737 floating-point or non-scalar types. */
2739 static struct value *
2740 ada_value_assign (struct value *toval, struct value *fromval)
2742 struct type *type = value_type (toval);
2743 int bits = value_bitsize (toval);
2745 toval = ada_coerce_ref (toval);
2746 fromval = ada_coerce_ref (fromval);
2748 if (ada_is_direct_array_type (value_type (toval)))
2749 toval = ada_coerce_to_simple_array (toval);
2750 if (ada_is_direct_array_type (value_type (fromval)))
2751 fromval = ada_coerce_to_simple_array (fromval);
2753 if (!deprecated_value_modifiable (toval))
2754 error (_("Left operand of assignment is not a modifiable lvalue."));
2756 if (VALUE_LVAL (toval) == lval_memory
2758 && (TYPE_CODE (type) == TYPE_CODE_FLT
2759 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2761 int len = (value_bitpos (toval)
2762 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2764 gdb_byte *buffer = (gdb_byte *) alloca (len);
2766 CORE_ADDR to_addr = value_address (toval);
2768 if (TYPE_CODE (type) == TYPE_CODE_FLT)
2769 fromval = value_cast (type, fromval);
2771 read_memory (to_addr, buffer, len);
2772 from_size = value_bitsize (fromval);
2774 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2775 if (gdbarch_bits_big_endian (get_type_arch (type)))
2776 move_bits (buffer, value_bitpos (toval),
2777 value_contents (fromval), from_size - bits, bits, 1);
2779 move_bits (buffer, value_bitpos (toval),
2780 value_contents (fromval), 0, bits, 0);
2781 write_memory_with_notification (to_addr, buffer, len);
2783 val = value_copy (toval);
2784 memcpy (value_contents_raw (val), value_contents (fromval),
2785 TYPE_LENGTH (type));
2786 deprecated_set_value_type (val, type);
2791 return value_assign (toval, fromval);
2795 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2796 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2797 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2798 COMPONENT, and not the inferior's memory. The current contents
2799 of COMPONENT are ignored.
2801 Although not part of the initial design, this function also works
2802 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2803 had a null address, and COMPONENT had an address which is equal to
2804 its offset inside CONTAINER. */
2807 value_assign_to_component (struct value *container, struct value *component,
2810 LONGEST offset_in_container =
2811 (LONGEST) (value_address (component) - value_address (container));
2812 int bit_offset_in_container =
2813 value_bitpos (component) - value_bitpos (container);
2816 val = value_cast (value_type (component), val);
2818 if (value_bitsize (component) == 0)
2819 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2821 bits = value_bitsize (component);
2823 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2824 move_bits (value_contents_writeable (container) + offset_in_container,
2825 value_bitpos (container) + bit_offset_in_container,
2826 value_contents (val),
2827 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2830 move_bits (value_contents_writeable (container) + offset_in_container,
2831 value_bitpos (container) + bit_offset_in_container,
2832 value_contents (val), 0, bits, 0);
2835 /* The value of the element of array ARR at the ARITY indices given in IND.
2836 ARR may be either a simple array, GNAT array descriptor, or pointer
2840 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2844 struct type *elt_type;
2846 elt = ada_coerce_to_simple_array (arr);
2848 elt_type = ada_check_typedef (value_type (elt));
2849 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2850 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2851 return value_subscript_packed (elt, arity, ind);
2853 for (k = 0; k < arity; k += 1)
2855 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2856 error (_("too many subscripts (%d expected)"), k);
2857 elt = value_subscript (elt, pos_atr (ind[k]));
2862 /* Assuming ARR is a pointer to a GDB array, the value of the element
2863 of *ARR at the ARITY indices given in IND.
2864 Does not read the entire array into memory.
2866 Note: Unlike what one would expect, this function is used instead of
2867 ada_value_subscript for basically all non-packed array types. The reason
2868 for this is that a side effect of doing our own pointer arithmetics instead
2869 of relying on value_subscript is that there is no implicit typedef peeling.
2870 This is important for arrays of array accesses, where it allows us to
2871 preserve the fact that the array's element is an array access, where the
2872 access part os encoded in a typedef layer. */
2874 static struct value *
2875 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2878 struct value *array_ind = ada_value_ind (arr);
2880 = check_typedef (value_enclosing_type (array_ind));
2882 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2883 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2884 return value_subscript_packed (array_ind, arity, ind);
2886 for (k = 0; k < arity; k += 1)
2889 struct value *lwb_value;
2891 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2892 error (_("too many subscripts (%d expected)"), k);
2893 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2895 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2896 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2897 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
2898 type = TYPE_TARGET_TYPE (type);
2901 return value_ind (arr);
2904 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2905 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2906 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2907 this array is LOW, as per Ada rules. */
2908 static struct value *
2909 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2912 struct type *type0 = ada_check_typedef (type);
2913 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
2914 struct type *index_type
2915 = create_static_range_type (NULL, base_index_type, low, high);
2916 struct type *slice_type =
2917 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
2918 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2919 LONGEST base_low_pos, low_pos;
2922 if (!discrete_position (base_index_type, low, &low_pos)
2923 || !discrete_position (base_index_type, base_low, &base_low_pos))
2925 warning (_("unable to get positions in slice, use bounds instead"));
2927 base_low_pos = base_low;
2930 base = value_as_address (array_ptr)
2931 + ((low_pos - base_low_pos)
2932 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
2933 return value_at_lazy (slice_type, base);
2937 static struct value *
2938 ada_value_slice (struct value *array, int low, int high)
2940 struct type *type = ada_check_typedef (value_type (array));
2941 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2942 struct type *index_type
2943 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2944 struct type *slice_type =
2945 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2946 LONGEST low_pos, high_pos;
2948 if (!discrete_position (base_index_type, low, &low_pos)
2949 || !discrete_position (base_index_type, high, &high_pos))
2951 warning (_("unable to get positions in slice, use bounds instead"));
2956 return value_cast (slice_type,
2957 value_slice (array, low, high_pos - low_pos + 1));
2960 /* If type is a record type in the form of a standard GNAT array
2961 descriptor, returns the number of dimensions for type. If arr is a
2962 simple array, returns the number of "array of"s that prefix its
2963 type designation. Otherwise, returns 0. */
2966 ada_array_arity (struct type *type)
2973 type = desc_base_type (type);
2976 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2977 return desc_arity (desc_bounds_type (type));
2979 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2982 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2988 /* If TYPE is a record type in the form of a standard GNAT array
2989 descriptor or a simple array type, returns the element type for
2990 TYPE after indexing by NINDICES indices, or by all indices if
2991 NINDICES is -1. Otherwise, returns NULL. */
2994 ada_array_element_type (struct type *type, int nindices)
2996 type = desc_base_type (type);
2998 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
3001 struct type *p_array_type;
3003 p_array_type = desc_data_target_type (type);
3005 k = ada_array_arity (type);
3009 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
3010 if (nindices >= 0 && k > nindices)
3012 while (k > 0 && p_array_type != NULL)
3014 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
3017 return p_array_type;
3019 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
3021 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
3023 type = TYPE_TARGET_TYPE (type);
3032 /* The type of nth index in arrays of given type (n numbering from 1).
3033 Does not examine memory. Throws an error if N is invalid or TYPE
3034 is not an array type. NAME is the name of the Ada attribute being
3035 evaluated ('range, 'first, 'last, or 'length); it is used in building
3036 the error message. */
3038 static struct type *
3039 ada_index_type (struct type *type, int n, const char *name)
3041 struct type *result_type;
3043 type = desc_base_type (type);
3045 if (n < 0 || n > ada_array_arity (type))
3046 error (_("invalid dimension number to '%s"), name);
3048 if (ada_is_simple_array_type (type))
3052 for (i = 1; i < n; i += 1)
3053 type = TYPE_TARGET_TYPE (type);
3054 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
3055 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3056 has a target type of TYPE_CODE_UNDEF. We compensate here, but
3057 perhaps stabsread.c would make more sense. */
3058 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
3063 result_type = desc_index_type (desc_bounds_type (type), n);
3064 if (result_type == NULL)
3065 error (_("attempt to take bound of something that is not an array"));
3071 /* Given that arr is an array type, returns the lower bound of the
3072 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3073 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
3074 array-descriptor type. It works for other arrays with bounds supplied
3075 by run-time quantities other than discriminants. */
3078 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3080 struct type *type, *index_type_desc, *index_type;
3083 gdb_assert (which == 0 || which == 1);
3085 if (ada_is_constrained_packed_array_type (arr_type))
3086 arr_type = decode_constrained_packed_array_type (arr_type);
3088 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3089 return (LONGEST) - which;
3091 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3092 type = TYPE_TARGET_TYPE (arr_type);
3096 if (TYPE_FIXED_INSTANCE (type))
3098 /* The array has already been fixed, so we do not need to
3099 check the parallel ___XA type again. That encoding has
3100 already been applied, so ignore it now. */
3101 index_type_desc = NULL;
3105 index_type_desc = ada_find_parallel_type (type, "___XA");
3106 ada_fixup_array_indexes_type (index_type_desc);
3109 if (index_type_desc != NULL)
3110 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3114 struct type *elt_type = check_typedef (type);
3116 for (i = 1; i < n; i++)
3117 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3119 index_type = TYPE_INDEX_TYPE (elt_type);
3123 (LONGEST) (which == 0
3124 ? ada_discrete_type_low_bound (index_type)
3125 : ada_discrete_type_high_bound (index_type));
3128 /* Given that arr is an array value, returns the lower bound of the
3129 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3130 WHICH is 1. This routine will also work for arrays with bounds
3131 supplied by run-time quantities other than discriminants. */
3134 ada_array_bound (struct value *arr, int n, int which)
3136 struct type *arr_type;
3138 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3139 arr = value_ind (arr);
3140 arr_type = value_enclosing_type (arr);
3142 if (ada_is_constrained_packed_array_type (arr_type))
3143 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3144 else if (ada_is_simple_array_type (arr_type))
3145 return ada_array_bound_from_type (arr_type, n, which);
3147 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3150 /* Given that arr is an array value, returns the length of the
3151 nth index. This routine will also work for arrays with bounds
3152 supplied by run-time quantities other than discriminants.
3153 Does not work for arrays indexed by enumeration types with representation
3154 clauses at the moment. */
3157 ada_array_length (struct value *arr, int n)
3159 struct type *arr_type, *index_type;
3162 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3163 arr = value_ind (arr);
3164 arr_type = value_enclosing_type (arr);
3166 if (ada_is_constrained_packed_array_type (arr_type))
3167 return ada_array_length (decode_constrained_packed_array (arr), n);
3169 if (ada_is_simple_array_type (arr_type))
3171 low = ada_array_bound_from_type (arr_type, n, 0);
3172 high = ada_array_bound_from_type (arr_type, n, 1);
3176 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3177 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3180 arr_type = check_typedef (arr_type);
3181 index_type = TYPE_INDEX_TYPE (arr_type);
3182 if (index_type != NULL)
3184 struct type *base_type;
3185 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3186 base_type = TYPE_TARGET_TYPE (index_type);
3188 base_type = index_type;
3190 low = pos_atr (value_from_longest (base_type, low));
3191 high = pos_atr (value_from_longest (base_type, high));
3193 return high - low + 1;
3196 /* An empty array whose type is that of ARR_TYPE (an array type),
3197 with bounds LOW to LOW-1. */
3199 static struct value *
3200 empty_array (struct type *arr_type, int low)
3202 struct type *arr_type0 = ada_check_typedef (arr_type);
3203 struct type *index_type
3204 = create_static_range_type
3205 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
3206 struct type *elt_type = ada_array_element_type (arr_type0, 1);
3208 return allocate_value (create_array_type (NULL, elt_type, index_type));
3212 /* Name resolution */
3214 /* The "decoded" name for the user-definable Ada operator corresponding
3218 ada_decoded_op_name (enum exp_opcode op)
3222 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3224 if (ada_opname_table[i].op == op)
3225 return ada_opname_table[i].decoded;
3227 error (_("Could not find operator name for opcode"));
3231 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3232 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3233 undefined namespace) and converts operators that are
3234 user-defined into appropriate function calls. If CONTEXT_TYPE is
3235 non-null, it provides a preferred result type [at the moment, only
3236 type void has any effect---causing procedures to be preferred over
3237 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3238 return type is preferred. May change (expand) *EXP. */
3241 resolve (struct expression **expp, int void_context_p)
3243 struct type *context_type = NULL;
3247 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3249 resolve_subexp (expp, &pc, 1, context_type);
3252 /* Resolve the operator of the subexpression beginning at
3253 position *POS of *EXPP. "Resolving" consists of replacing
3254 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3255 with their resolutions, replacing built-in operators with
3256 function calls to user-defined operators, where appropriate, and,
3257 when DEPROCEDURE_P is non-zero, converting function-valued variables
3258 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3259 are as in ada_resolve, above. */
3261 static struct value *
3262 resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
3263 struct type *context_type)
3267 struct expression *exp; /* Convenience: == *expp. */
3268 enum exp_opcode op = (*expp)->elts[pc].opcode;
3269 struct value **argvec; /* Vector of operand types (alloca'ed). */
3270 int nargs; /* Number of operands. */
3277 /* Pass one: resolve operands, saving their types and updating *pos,
3282 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3283 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3288 resolve_subexp (expp, pos, 0, NULL);
3290 nargs = longest_to_int (exp->elts[pc + 1].longconst);
3295 resolve_subexp (expp, pos, 0, NULL);
3300 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
3303 case OP_ATR_MODULUS:
3313 case TERNOP_IN_RANGE:
3314 case BINOP_IN_BOUNDS:
3320 case OP_DISCRETE_RANGE:
3322 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3331 arg1 = resolve_subexp (expp, pos, 0, NULL);
3333 resolve_subexp (expp, pos, 1, NULL);
3335 resolve_subexp (expp, pos, 1, value_type (arg1));
3352 case BINOP_LOGICAL_AND:
3353 case BINOP_LOGICAL_OR:
3354 case BINOP_BITWISE_AND:
3355 case BINOP_BITWISE_IOR:
3356 case BINOP_BITWISE_XOR:
3359 case BINOP_NOTEQUAL:
3366 case BINOP_SUBSCRIPT:
3374 case UNOP_LOGICAL_NOT:
3384 case OP_VAR_MSYM_VALUE:
3391 case OP_INTERNALVAR:
3401 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3404 case STRUCTOP_STRUCT:
3405 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3418 error (_("Unexpected operator during name resolution"));
3421 argvec = XALLOCAVEC (struct value *, nargs + 1);
3422 for (i = 0; i < nargs; i += 1)
3423 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3427 /* Pass two: perform any resolution on principal operator. */
3434 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
3436 struct block_symbol *candidates;
3440 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3441 (exp->elts[pc + 2].symbol),
3442 exp->elts[pc + 1].block, VAR_DOMAIN,
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 if (innermost_block == NULL
3508 || contained_in (candidates[i].block, innermost_block))
3509 innermost_block = candidates[i].block;
3513 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3516 replace_operator_with_call (expp, pc, 0, 0,
3517 exp->elts[pc + 2].symbol,
3518 exp->elts[pc + 1].block);
3525 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3526 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3528 struct block_symbol *candidates;
3532 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3533 (exp->elts[pc + 5].symbol),
3534 exp->elts[pc + 4].block, VAR_DOMAIN,
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 if (innermost_block == NULL
3553 || contained_in (candidates[i].block, innermost_block))
3554 innermost_block = candidates[i].block;
3565 case BINOP_BITWISE_AND:
3566 case BINOP_BITWISE_IOR:
3567 case BINOP_BITWISE_XOR:
3569 case BINOP_NOTEQUAL:
3577 case UNOP_LOGICAL_NOT:
3579 if (possible_user_operator_p (op, argvec))
3581 struct block_symbol *candidates;
3585 ada_lookup_symbol_list (ada_decoded_op_name (op),
3586 (struct block *) NULL, VAR_DOMAIN,
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);
3606 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3607 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3608 exp->elts[pc + 1].objfile,
3609 exp->elts[pc + 2].msymbol);
3611 return evaluate_subexp_type (exp, pos);
3614 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3615 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3617 /* The term "match" here is rather loose. The match is heuristic and
3621 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3623 ftype = ada_check_typedef (ftype);
3624 atype = ada_check_typedef (atype);
3626 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3627 ftype = TYPE_TARGET_TYPE (ftype);
3628 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3629 atype = TYPE_TARGET_TYPE (atype);
3631 switch (TYPE_CODE (ftype))
3634 return TYPE_CODE (ftype) == TYPE_CODE (atype);
3636 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3637 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3638 TYPE_TARGET_TYPE (atype), 0);
3641 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3643 case TYPE_CODE_ENUM:
3644 case TYPE_CODE_RANGE:
3645 switch (TYPE_CODE (atype))
3648 case TYPE_CODE_ENUM:
3649 case TYPE_CODE_RANGE:
3655 case TYPE_CODE_ARRAY:
3656 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3657 || ada_is_array_descriptor_type (atype));
3659 case TYPE_CODE_STRUCT:
3660 if (ada_is_array_descriptor_type (ftype))
3661 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3662 || ada_is_array_descriptor_type (atype));
3664 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3665 && !ada_is_array_descriptor_type (atype));
3667 case TYPE_CODE_UNION:
3669 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3673 /* Return non-zero if the formals of FUNC "sufficiently match" the
3674 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3675 may also be an enumeral, in which case it is treated as a 0-
3676 argument function. */
3679 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3682 struct type *func_type = SYMBOL_TYPE (func);
3684 if (SYMBOL_CLASS (func) == LOC_CONST
3685 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3686 return (n_actuals == 0);
3687 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3690 if (TYPE_NFIELDS (func_type) != n_actuals)
3693 for (i = 0; i < n_actuals; i += 1)
3695 if (actuals[i] == NULL)
3699 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3701 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3703 if (!ada_type_match (ftype, atype, 1))
3710 /* False iff function type FUNC_TYPE definitely does not produce a value
3711 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3712 FUNC_TYPE is not a valid function type with a non-null return type
3713 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3716 return_match (struct type *func_type, struct type *context_type)
3718 struct type *return_type;
3720 if (func_type == NULL)
3723 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3724 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3726 return_type = get_base_type (func_type);
3727 if (return_type == NULL)
3730 context_type = get_base_type (context_type);
3732 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3733 return context_type == NULL || return_type == context_type;
3734 else if (context_type == NULL)
3735 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3737 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3741 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3742 function (if any) that matches the types of the NARGS arguments in
3743 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3744 that returns that type, then eliminate matches that don't. If
3745 CONTEXT_TYPE is void and there is at least one match that does not
3746 return void, eliminate all matches that do.
3748 Asks the user if there is more than one match remaining. Returns -1
3749 if there is no such symbol or none is selected. NAME is used
3750 solely for messages. May re-arrange and modify SYMS in
3751 the process; the index returned is for the modified vector. */
3754 ada_resolve_function (struct block_symbol syms[],
3755 int nsyms, struct value **args, int nargs,
3756 const char *name, struct type *context_type)
3760 int m; /* Number of hits */
3763 /* In the first pass of the loop, we only accept functions matching
3764 context_type. If none are found, we add a second pass of the loop
3765 where every function is accepted. */
3766 for (fallback = 0; m == 0 && fallback < 2; fallback++)
3768 for (k = 0; k < nsyms; k += 1)
3770 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
3772 if (ada_args_match (syms[k].symbol, args, nargs)
3773 && (fallback || return_match (type, context_type)))
3781 /* If we got multiple matches, ask the user which one to use. Don't do this
3782 interactive thing during completion, though, as the purpose of the
3783 completion is providing a list of all possible matches. Prompting the
3784 user to filter it down would be completely unexpected in this case. */
3787 else if (m > 1 && !parse_completion)
3789 printf_filtered (_("Multiple matches for %s\n"), name);
3790 user_select_syms (syms, m, 1);
3796 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3797 in a listing of choices during disambiguation (see sort_choices, below).
3798 The idea is that overloadings of a subprogram name from the
3799 same package should sort in their source order. We settle for ordering
3800 such symbols by their trailing number (__N or $N). */
3803 encoded_ordered_before (const char *N0, const char *N1)
3807 else if (N0 == NULL)
3813 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3815 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3817 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3818 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3823 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3826 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3828 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3829 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3831 return (strcmp (N0, N1) < 0);
3835 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3839 sort_choices (struct block_symbol syms[], int nsyms)
3843 for (i = 1; i < nsyms; i += 1)
3845 struct block_symbol sym = syms[i];
3848 for (j = i - 1; j >= 0; j -= 1)
3850 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3851 SYMBOL_LINKAGE_NAME (sym.symbol)))
3853 syms[j + 1] = syms[j];
3859 /* Whether GDB should display formals and return types for functions in the
3860 overloads selection menu. */
3861 static int print_signatures = 1;
3863 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3864 all but functions, the signature is just the name of the symbol. For
3865 functions, this is the name of the function, the list of types for formals
3866 and the return type (if any). */
3869 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3870 const struct type_print_options *flags)
3872 struct type *type = SYMBOL_TYPE (sym);
3874 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3875 if (!print_signatures
3877 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3880 if (TYPE_NFIELDS (type) > 0)
3884 fprintf_filtered (stream, " (");
3885 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3888 fprintf_filtered (stream, "; ");
3889 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3892 fprintf_filtered (stream, ")");
3894 if (TYPE_TARGET_TYPE (type) != NULL
3895 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3897 fprintf_filtered (stream, " return ");
3898 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3902 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3903 by asking the user (if necessary), returning the number selected,
3904 and setting the first elements of SYMS items. Error if no symbols
3907 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3908 to be re-integrated one of these days. */
3911 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3914 int *chosen = XALLOCAVEC (int , nsyms);
3916 int first_choice = (max_results == 1) ? 1 : 2;
3917 const char *select_mode = multiple_symbols_select_mode ();
3919 if (max_results < 1)
3920 error (_("Request to select 0 symbols!"));
3924 if (select_mode == multiple_symbols_cancel)
3926 canceled because the command is ambiguous\n\
3927 See set/show multiple-symbol."));
3929 /* If select_mode is "all", then return all possible symbols.
3930 Only do that if more than one symbol can be selected, of course.
3931 Otherwise, display the menu as usual. */
3932 if (select_mode == multiple_symbols_all && max_results > 1)
3935 printf_unfiltered (_("[0] cancel\n"));
3936 if (max_results > 1)
3937 printf_unfiltered (_("[1] all\n"));
3939 sort_choices (syms, nsyms);
3941 for (i = 0; i < nsyms; i += 1)
3943 if (syms[i].symbol == NULL)
3946 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3948 struct symtab_and_line sal =
3949 find_function_start_sal (syms[i].symbol, 1);
3951 printf_unfiltered ("[%d] ", i + first_choice);
3952 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3953 &type_print_raw_options);
3954 if (sal.symtab == NULL)
3955 printf_unfiltered (_(" at <no source file available>:%d\n"),
3958 printf_unfiltered (_(" at %s:%d\n"),
3959 symtab_to_filename_for_display (sal.symtab),
3966 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3967 && SYMBOL_TYPE (syms[i].symbol) != NULL
3968 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
3969 struct symtab *symtab = NULL;
3971 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3972 symtab = symbol_symtab (syms[i].symbol);
3974 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3976 printf_unfiltered ("[%d] ", i + first_choice);
3977 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3978 &type_print_raw_options);
3979 printf_unfiltered (_(" at %s:%d\n"),
3980 symtab_to_filename_for_display (symtab),
3981 SYMBOL_LINE (syms[i].symbol));
3983 else if (is_enumeral
3984 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
3986 printf_unfiltered (("[%d] "), i + first_choice);
3987 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3988 gdb_stdout, -1, 0, &type_print_raw_options);
3989 printf_unfiltered (_("'(%s) (enumeral)\n"),
3990 SYMBOL_PRINT_NAME (syms[i].symbol));
3994 printf_unfiltered ("[%d] ", i + first_choice);
3995 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3996 &type_print_raw_options);
3999 printf_unfiltered (is_enumeral
4000 ? _(" in %s (enumeral)\n")
4002 symtab_to_filename_for_display (symtab));
4004 printf_unfiltered (is_enumeral
4005 ? _(" (enumeral)\n")
4011 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4014 for (i = 0; i < n_chosen; i += 1)
4015 syms[i] = syms[chosen[i]];
4020 /* Read and validate a set of numeric choices from the user in the
4021 range 0 .. N_CHOICES-1. Place the results in increasing
4022 order in CHOICES[0 .. N-1], and return N.
4024 The user types choices as a sequence of numbers on one line
4025 separated by blanks, encoding them as follows:
4027 + A choice of 0 means to cancel the selection, throwing an error.
4028 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4029 + The user chooses k by typing k+IS_ALL_CHOICE+1.
4031 The user is not allowed to choose more than MAX_RESULTS values.
4033 ANNOTATION_SUFFIX, if present, is used to annotate the input
4034 prompts (for use with the -f switch). */
4037 get_selections (int *choices, int n_choices, int max_results,
4038 int is_all_choice, const char *annotation_suffix)
4043 int first_choice = is_all_choice ? 2 : 1;
4045 prompt = getenv ("PS2");
4049 args = command_line_input (prompt, 0, annotation_suffix);
4052 error_no_arg (_("one or more choice numbers"));
4056 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4057 order, as given in args. Choices are validated. */
4063 args = skip_spaces (args);
4064 if (*args == '\0' && n_chosen == 0)
4065 error_no_arg (_("one or more choice numbers"));
4066 else if (*args == '\0')
4069 choice = strtol (args, &args2, 10);
4070 if (args == args2 || choice < 0
4071 || choice > n_choices + first_choice - 1)
4072 error (_("Argument must be choice number"));
4076 error (_("cancelled"));
4078 if (choice < first_choice)
4080 n_chosen = n_choices;
4081 for (j = 0; j < n_choices; j += 1)
4085 choice -= first_choice;
4087 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4091 if (j < 0 || choice != choices[j])
4095 for (k = n_chosen - 1; k > j; k -= 1)
4096 choices[k + 1] = choices[k];
4097 choices[j + 1] = choice;
4102 if (n_chosen > max_results)
4103 error (_("Select no more than %d of the above"), max_results);
4108 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4109 on the function identified by SYM and BLOCK, and taking NARGS
4110 arguments. Update *EXPP as needed to hold more space. */
4113 replace_operator_with_call (struct expression **expp, int pc, int nargs,
4114 int oplen, struct symbol *sym,
4115 const struct block *block)
4117 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4118 symbol, -oplen for operator being replaced). */
4119 struct expression *newexp = (struct expression *)
4120 xzalloc (sizeof (struct expression)
4121 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
4122 struct expression *exp = *expp;
4124 newexp->nelts = exp->nelts + 7 - oplen;
4125 newexp->language_defn = exp->language_defn;
4126 newexp->gdbarch = exp->gdbarch;
4127 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
4128 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4129 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
4131 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4132 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4134 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4135 newexp->elts[pc + 4].block = block;
4136 newexp->elts[pc + 5].symbol = sym;
4142 /* Type-class predicates */
4144 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4148 numeric_type_p (struct type *type)
4154 switch (TYPE_CODE (type))
4159 case TYPE_CODE_RANGE:
4160 return (type == TYPE_TARGET_TYPE (type)
4161 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4168 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4171 integer_type_p (struct type *type)
4177 switch (TYPE_CODE (type))
4181 case TYPE_CODE_RANGE:
4182 return (type == TYPE_TARGET_TYPE (type)
4183 || integer_type_p (TYPE_TARGET_TYPE (type)));
4190 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4193 scalar_type_p (struct type *type)
4199 switch (TYPE_CODE (type))
4202 case TYPE_CODE_RANGE:
4203 case TYPE_CODE_ENUM:
4212 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4215 discrete_type_p (struct type *type)
4221 switch (TYPE_CODE (type))
4224 case TYPE_CODE_RANGE:
4225 case TYPE_CODE_ENUM:
4226 case TYPE_CODE_BOOL:
4234 /* Returns non-zero if OP with operands in the vector ARGS could be
4235 a user-defined function. Errs on the side of pre-defined operators
4236 (i.e., result 0). */
4239 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4241 struct type *type0 =
4242 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4243 struct type *type1 =
4244 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4258 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4262 case BINOP_BITWISE_AND:
4263 case BINOP_BITWISE_IOR:
4264 case BINOP_BITWISE_XOR:
4265 return (!(integer_type_p (type0) && integer_type_p (type1)));
4268 case BINOP_NOTEQUAL:
4273 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4276 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4279 return (!(numeric_type_p (type0) && integer_type_p (type1)));
4283 case UNOP_LOGICAL_NOT:
4285 return (!numeric_type_p (type0));
4294 1. In the following, we assume that a renaming type's name may
4295 have an ___XD suffix. It would be nice if this went away at some
4297 2. We handle both the (old) purely type-based representation of
4298 renamings and the (new) variable-based encoding. At some point,
4299 it is devoutly to be hoped that the former goes away
4300 (FIXME: hilfinger-2007-07-09).
4301 3. Subprogram renamings are not implemented, although the XRS
4302 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4304 /* If SYM encodes a renaming,
4306 <renaming> renames <renamed entity>,
4308 sets *LEN to the length of the renamed entity's name,
4309 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4310 the string describing the subcomponent selected from the renamed
4311 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4312 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4313 are undefined). Otherwise, returns a value indicating the category
4314 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4315 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4316 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4317 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4318 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4319 may be NULL, in which case they are not assigned.
4321 [Currently, however, GCC does not generate subprogram renamings.] */
4323 enum ada_renaming_category
4324 ada_parse_renaming (struct symbol *sym,
4325 const char **renamed_entity, int *len,
4326 const char **renaming_expr)
4328 enum ada_renaming_category kind;
4333 return ADA_NOT_RENAMING;
4334 switch (SYMBOL_CLASS (sym))
4337 return ADA_NOT_RENAMING;
4339 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4340 renamed_entity, len, renaming_expr);
4344 case LOC_OPTIMIZED_OUT:
4345 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4347 return ADA_NOT_RENAMING;
4351 kind = ADA_OBJECT_RENAMING;
4355 kind = ADA_EXCEPTION_RENAMING;
4359 kind = ADA_PACKAGE_RENAMING;
4363 kind = ADA_SUBPROGRAM_RENAMING;
4367 return ADA_NOT_RENAMING;
4371 if (renamed_entity != NULL)
4372 *renamed_entity = info;
4373 suffix = strstr (info, "___XE");
4374 if (suffix == NULL || suffix == info)
4375 return ADA_NOT_RENAMING;
4377 *len = strlen (info) - strlen (suffix);
4379 if (renaming_expr != NULL)
4380 *renaming_expr = suffix;
4384 /* Assuming TYPE encodes a renaming according to the old encoding in
4385 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4386 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4387 ADA_NOT_RENAMING otherwise. */
4388 static enum ada_renaming_category
4389 parse_old_style_renaming (struct type *type,
4390 const char **renamed_entity, int *len,
4391 const char **renaming_expr)
4393 enum ada_renaming_category kind;
4398 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4399 || TYPE_NFIELDS (type) != 1)
4400 return ADA_NOT_RENAMING;
4402 name = type_name_no_tag (type);
4404 return ADA_NOT_RENAMING;
4406 name = strstr (name, "___XR");
4408 return ADA_NOT_RENAMING;
4413 kind = ADA_OBJECT_RENAMING;
4416 kind = ADA_EXCEPTION_RENAMING;
4419 kind = ADA_PACKAGE_RENAMING;
4422 kind = ADA_SUBPROGRAM_RENAMING;
4425 return ADA_NOT_RENAMING;
4428 info = TYPE_FIELD_NAME (type, 0);
4430 return ADA_NOT_RENAMING;
4431 if (renamed_entity != NULL)
4432 *renamed_entity = info;
4433 suffix = strstr (info, "___XE");
4434 if (renaming_expr != NULL)
4435 *renaming_expr = suffix + 5;
4436 if (suffix == NULL || suffix == info)
4437 return ADA_NOT_RENAMING;
4439 *len = suffix - info;
4443 /* Compute the value of the given RENAMING_SYM, which is expected to
4444 be a symbol encoding a renaming expression. BLOCK is the block
4445 used to evaluate the renaming. */
4447 static struct value *
4448 ada_read_renaming_var_value (struct symbol *renaming_sym,
4449 const struct block *block)
4451 const char *sym_name;
4453 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4454 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4455 return evaluate_expression (expr.get ());
4459 /* Evaluation: Function Calls */
4461 /* Return an lvalue containing the value VAL. This is the identity on
4462 lvalues, and otherwise has the side-effect of allocating memory
4463 in the inferior where a copy of the value contents is copied. */
4465 static struct value *
4466 ensure_lval (struct value *val)
4468 if (VALUE_LVAL (val) == not_lval
4469 || VALUE_LVAL (val) == lval_internalvar)
4471 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4472 const CORE_ADDR addr =
4473 value_as_long (value_allocate_space_in_inferior (len));
4475 VALUE_LVAL (val) = lval_memory;
4476 set_value_address (val, addr);
4477 write_memory (addr, value_contents (val), len);
4483 /* Return the value ACTUAL, converted to be an appropriate value for a
4484 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4485 allocating any necessary descriptors (fat pointers), or copies of
4486 values not residing in memory, updating it as needed. */
4489 ada_convert_actual (struct value *actual, struct type *formal_type0)
4491 struct type *actual_type = ada_check_typedef (value_type (actual));
4492 struct type *formal_type = ada_check_typedef (formal_type0);
4493 struct type *formal_target =
4494 TYPE_CODE (formal_type) == TYPE_CODE_PTR
4495 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4496 struct type *actual_target =
4497 TYPE_CODE (actual_type) == TYPE_CODE_PTR
4498 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4500 if (ada_is_array_descriptor_type (formal_target)
4501 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
4502 return make_array_descriptor (formal_type, actual);
4503 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4504 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
4506 struct value *result;
4508 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4509 && ada_is_array_descriptor_type (actual_target))
4510 result = desc_data (actual);
4511 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4513 if (VALUE_LVAL (actual) != lval_memory)
4517 actual_type = ada_check_typedef (value_type (actual));
4518 val = allocate_value (actual_type);
4519 memcpy ((char *) value_contents_raw (val),
4520 (char *) value_contents (actual),
4521 TYPE_LENGTH (actual_type));
4522 actual = ensure_lval (val);
4524 result = value_addr (actual);
4528 return value_cast_pointers (formal_type, result, 0);
4530 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4531 return ada_value_ind (actual);
4532 else if (ada_is_aligner_type (formal_type))
4534 /* We need to turn this parameter into an aligner type
4536 struct value *aligner = allocate_value (formal_type);
4537 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4539 value_assign_to_component (aligner, component, actual);
4546 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4547 type TYPE. This is usually an inefficient no-op except on some targets
4548 (such as AVR) where the representation of a pointer and an address
4552 value_pointer (struct value *value, struct type *type)
4554 struct gdbarch *gdbarch = get_type_arch (type);
4555 unsigned len = TYPE_LENGTH (type);
4556 gdb_byte *buf = (gdb_byte *) alloca (len);
4559 addr = value_address (value);
4560 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4561 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4566 /* Push a descriptor of type TYPE for array value ARR on the stack at
4567 *SP, updating *SP to reflect the new descriptor. Return either
4568 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4569 to-descriptor type rather than a descriptor type), a struct value *
4570 representing a pointer to this descriptor. */
4572 static struct value *
4573 make_array_descriptor (struct type *type, struct value *arr)
4575 struct type *bounds_type = desc_bounds_type (type);
4576 struct type *desc_type = desc_base_type (type);
4577 struct value *descriptor = allocate_value (desc_type);
4578 struct value *bounds = allocate_value (bounds_type);
4581 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4584 modify_field (value_type (bounds), value_contents_writeable (bounds),
4585 ada_array_bound (arr, i, 0),
4586 desc_bound_bitpos (bounds_type, i, 0),
4587 desc_bound_bitsize (bounds_type, i, 0));
4588 modify_field (value_type (bounds), value_contents_writeable (bounds),
4589 ada_array_bound (arr, i, 1),
4590 desc_bound_bitpos (bounds_type, i, 1),
4591 desc_bound_bitsize (bounds_type, i, 1));
4594 bounds = ensure_lval (bounds);
4596 modify_field (value_type (descriptor),
4597 value_contents_writeable (descriptor),
4598 value_pointer (ensure_lval (arr),
4599 TYPE_FIELD_TYPE (desc_type, 0)),
4600 fat_pntr_data_bitpos (desc_type),
4601 fat_pntr_data_bitsize (desc_type));
4603 modify_field (value_type (descriptor),
4604 value_contents_writeable (descriptor),
4605 value_pointer (bounds,
4606 TYPE_FIELD_TYPE (desc_type, 1)),
4607 fat_pntr_bounds_bitpos (desc_type),
4608 fat_pntr_bounds_bitsize (desc_type));
4610 descriptor = ensure_lval (descriptor);
4612 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4613 return value_addr (descriptor);
4618 /* Symbol Cache Module */
4620 /* Performance measurements made as of 2010-01-15 indicate that
4621 this cache does bring some noticeable improvements. Depending
4622 on the type of entity being printed, the cache can make it as much
4623 as an order of magnitude faster than without it.
4625 The descriptive type DWARF extension has significantly reduced
4626 the need for this cache, at least when DWARF is being used. However,
4627 even in this case, some expensive name-based symbol searches are still
4628 sometimes necessary - to find an XVZ variable, mostly. */
4630 /* Initialize the contents of SYM_CACHE. */
4633 ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4635 obstack_init (&sym_cache->cache_space);
4636 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4639 /* Free the memory used by SYM_CACHE. */
4642 ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
4644 obstack_free (&sym_cache->cache_space, NULL);
4648 /* Return the symbol cache associated to the given program space PSPACE.
4649 If not allocated for this PSPACE yet, allocate and initialize one. */
4651 static struct ada_symbol_cache *
4652 ada_get_symbol_cache (struct program_space *pspace)
4654 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4656 if (pspace_data->sym_cache == NULL)
4658 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4659 ada_init_symbol_cache (pspace_data->sym_cache);
4662 return pspace_data->sym_cache;
4665 /* Clear all entries from the symbol cache. */
4668 ada_clear_symbol_cache (void)
4670 struct ada_symbol_cache *sym_cache
4671 = ada_get_symbol_cache (current_program_space);
4673 obstack_free (&sym_cache->cache_space, NULL);
4674 ada_init_symbol_cache (sym_cache);
4677 /* Search our cache for an entry matching NAME and DOMAIN.
4678 Return it if found, or NULL otherwise. */
4680 static struct cache_entry **
4681 find_entry (const char *name, domain_enum domain)
4683 struct ada_symbol_cache *sym_cache
4684 = ada_get_symbol_cache (current_program_space);
4685 int h = msymbol_hash (name) % HASH_SIZE;
4686 struct cache_entry **e;
4688 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4690 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4696 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4697 Return 1 if found, 0 otherwise.
4699 If an entry was found and SYM is not NULL, set *SYM to the entry's
4700 SYM. Same principle for BLOCK if not NULL. */
4703 lookup_cached_symbol (const char *name, domain_enum domain,
4704 struct symbol **sym, const struct block **block)
4706 struct cache_entry **e = find_entry (name, domain);
4713 *block = (*e)->block;
4717 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4718 in domain DOMAIN, save this result in our symbol cache. */
4721 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4722 const struct block *block)
4724 struct ada_symbol_cache *sym_cache
4725 = ada_get_symbol_cache (current_program_space);
4728 struct cache_entry *e;
4730 /* Symbols for builtin types don't have a block.
4731 For now don't cache such symbols. */
4732 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4735 /* If the symbol is a local symbol, then do not cache it, as a search
4736 for that symbol depends on the context. To determine whether
4737 the symbol is local or not, we check the block where we found it
4738 against the global and static blocks of its associated symtab. */
4740 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4741 GLOBAL_BLOCK) != block
4742 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4743 STATIC_BLOCK) != block)
4746 h = msymbol_hash (name) % HASH_SIZE;
4747 e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space,
4749 e->next = sym_cache->root[h];
4750 sym_cache->root[h] = e;
4752 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
4753 strcpy (copy, name);
4761 /* Return the symbol name match type that should be used used when
4762 searching for all symbols matching LOOKUP_NAME.
4764 LOOKUP_NAME is expected to be a symbol name after transformation
4765 for Ada lookups (see ada_name_for_lookup). */
4767 static symbol_name_match_type
4768 name_match_type_from_name (const char *lookup_name)
4770 return (strstr (lookup_name, "__") == NULL
4771 ? symbol_name_match_type::WILD
4772 : symbol_name_match_type::FULL);
4775 /* Return the result of a standard (literal, C-like) lookup of NAME in
4776 given DOMAIN, visible from lexical block BLOCK. */
4778 static struct symbol *
4779 standard_lookup (const char *name, const struct block *block,
4782 /* Initialize it just to avoid a GCC false warning. */
4783 struct block_symbol sym = {NULL, NULL};
4785 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4787 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4788 cache_symbol (name, domain, sym.symbol, sym.block);
4793 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4794 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4795 since they contend in overloading in the same way. */
4797 is_nonfunction (struct block_symbol syms[], int n)
4801 for (i = 0; i < n; i += 1)
4802 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4803 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4804 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
4810 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4811 struct types. Otherwise, they may not. */
4814 equiv_types (struct type *type0, struct type *type1)
4818 if (type0 == NULL || type1 == NULL
4819 || TYPE_CODE (type0) != TYPE_CODE (type1))
4821 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4822 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4823 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4824 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4830 /* True iff SYM0 represents the same entity as SYM1, or one that is
4831 no more defined than that of SYM1. */
4834 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4838 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4839 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4842 switch (SYMBOL_CLASS (sym0))
4848 struct type *type0 = SYMBOL_TYPE (sym0);
4849 struct type *type1 = SYMBOL_TYPE (sym1);
4850 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4851 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4852 int len0 = strlen (name0);
4855 TYPE_CODE (type0) == TYPE_CODE (type1)
4856 && (equiv_types (type0, type1)
4857 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4858 && startswith (name1 + len0, "___XV")));
4861 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4862 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4868 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4869 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4872 add_defn_to_vec (struct obstack *obstackp,
4874 const struct block *block)
4877 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
4879 /* Do not try to complete stub types, as the debugger is probably
4880 already scanning all symbols matching a certain name at the
4881 time when this function is called. Trying to replace the stub
4882 type by its associated full type will cause us to restart a scan
4883 which may lead to an infinite recursion. Instead, the client
4884 collecting the matching symbols will end up collecting several
4885 matches, with at least one of them complete. It can then filter
4886 out the stub ones if needed. */
4888 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4890 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4892 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4894 prevDefns[i].symbol = sym;
4895 prevDefns[i].block = block;
4901 struct block_symbol info;
4905 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4909 /* Number of block_symbol structures currently collected in current vector in
4913 num_defns_collected (struct obstack *obstackp)
4915 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4918 /* Vector of block_symbol structures currently collected in current vector in
4919 OBSTACKP. If FINISH, close off the vector and return its final address. */
4921 static struct block_symbol *
4922 defns_collected (struct obstack *obstackp, int finish)
4925 return (struct block_symbol *) obstack_finish (obstackp);
4927 return (struct block_symbol *) obstack_base (obstackp);
4930 /* Return a bound minimal symbol matching NAME according to Ada
4931 decoding rules. Returns an invalid symbol if there is no such
4932 minimal symbol. Names prefixed with "standard__" are handled
4933 specially: "standard__" is first stripped off, and only static and
4934 global symbols are searched. */
4936 struct bound_minimal_symbol
4937 ada_lookup_simple_minsym (const char *name)
4939 struct bound_minimal_symbol result;
4940 struct objfile *objfile;
4941 struct minimal_symbol *msymbol;
4943 memset (&result, 0, sizeof (result));
4945 symbol_name_match_type match_type = name_match_type_from_name (name);
4946 lookup_name_info lookup_name (name, match_type);
4948 symbol_name_matcher_ftype *match_name
4949 = ada_get_symbol_name_matcher (lookup_name);
4951 ALL_MSYMBOLS (objfile, msymbol)
4953 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4954 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4956 result.minsym = msymbol;
4957 result.objfile = objfile;
4965 /* For all subprograms that statically enclose the subprogram of the
4966 selected frame, add symbols matching identifier NAME in DOMAIN
4967 and their blocks to the list of data in OBSTACKP, as for
4968 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4969 with a wildcard prefix. */
4972 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4973 const lookup_name_info &lookup_name,
4978 /* True if TYPE is definitely an artificial type supplied to a symbol
4979 for which no debugging information was given in the symbol file. */
4982 is_nondebugging_type (struct type *type)
4984 const char *name = ada_type_name (type);
4986 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4989 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4990 that are deemed "identical" for practical purposes.
4992 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4993 types and that their number of enumerals is identical (in other
4994 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4997 ada_identical_enum_types_p (struct type *type1, struct type *type2)
5001 /* The heuristic we use here is fairly conservative. We consider
5002 that 2 enumerate types are identical if they have the same
5003 number of enumerals and that all enumerals have the same
5004 underlying value and name. */
5006 /* All enums in the type should have an identical underlying value. */
5007 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5008 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
5011 /* All enumerals should also have the same name (modulo any numerical
5013 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5015 const char *name_1 = TYPE_FIELD_NAME (type1, i);
5016 const char *name_2 = TYPE_FIELD_NAME (type2, i);
5017 int len_1 = strlen (name_1);
5018 int len_2 = strlen (name_2);
5020 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5021 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5023 || strncmp (TYPE_FIELD_NAME (type1, i),
5024 TYPE_FIELD_NAME (type2, i),
5032 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
5033 that are deemed "identical" for practical purposes. Sometimes,
5034 enumerals are not strictly identical, but their types are so similar
5035 that they can be considered identical.
5037 For instance, consider the following code:
5039 type Color is (Black, Red, Green, Blue, White);
5040 type RGB_Color is new Color range Red .. Blue;
5042 Type RGB_Color is a subrange of an implicit type which is a copy
5043 of type Color. If we call that implicit type RGB_ColorB ("B" is
5044 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5045 As a result, when an expression references any of the enumeral
5046 by name (Eg. "print green"), the expression is technically
5047 ambiguous and the user should be asked to disambiguate. But
5048 doing so would only hinder the user, since it wouldn't matter
5049 what choice he makes, the outcome would always be the same.
5050 So, for practical purposes, we consider them as the same. */
5053 symbols_are_identical_enums (struct block_symbol *syms, int nsyms)
5057 /* Before performing a thorough comparison check of each type,
5058 we perform a series of inexpensive checks. We expect that these
5059 checks will quickly fail in the vast majority of cases, and thus
5060 help prevent the unnecessary use of a more expensive comparison.
5061 Said comparison also expects us to make some of these checks
5062 (see ada_identical_enum_types_p). */
5064 /* Quick check: All symbols should have an enum type. */
5065 for (i = 0; i < nsyms; i++)
5066 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
5069 /* Quick check: They should all have the same value. */
5070 for (i = 1; i < nsyms; i++)
5071 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
5074 /* Quick check: They should all have the same number of enumerals. */
5075 for (i = 1; i < nsyms; i++)
5076 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5077 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
5080 /* All the sanity checks passed, so we might have a set of
5081 identical enumeration types. Perform a more complete
5082 comparison of the type of each symbol. */
5083 for (i = 1; i < nsyms; i++)
5084 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5085 SYMBOL_TYPE (syms[0].symbol)))
5091 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
5092 duplicate other symbols in the list (The only case I know of where
5093 this happens is when object files containing stabs-in-ecoff are
5094 linked with files containing ordinary ecoff debugging symbols (or no
5095 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5096 Returns the number of items in the modified list. */
5099 remove_extra_symbols (struct block_symbol *syms, int nsyms)
5103 /* We should never be called with less than 2 symbols, as there
5104 cannot be any extra symbol in that case. But it's easy to
5105 handle, since we have nothing to do in that case. */
5114 /* If two symbols have the same name and one of them is a stub type,
5115 the get rid of the stub. */
5117 if (TYPE_STUB (SYMBOL_TYPE (syms[i].symbol))
5118 && SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL)
5120 for (j = 0; j < nsyms; j++)
5123 && !TYPE_STUB (SYMBOL_TYPE (syms[j].symbol))
5124 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5125 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5126 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0)
5131 /* Two symbols with the same name, same class and same address
5132 should be identical. */
5134 else if (SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL
5135 && SYMBOL_CLASS (syms[i].symbol) == LOC_STATIC
5136 && is_nondebugging_type (SYMBOL_TYPE (syms[i].symbol)))
5138 for (j = 0; j < nsyms; j += 1)
5141 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5142 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5143 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0
5144 && SYMBOL_CLASS (syms[i].symbol)
5145 == SYMBOL_CLASS (syms[j].symbol)
5146 && SYMBOL_VALUE_ADDRESS (syms[i].symbol)
5147 == SYMBOL_VALUE_ADDRESS (syms[j].symbol))
5154 for (j = i + 1; j < nsyms; j += 1)
5155 syms[j - 1] = syms[j];
5162 /* If all the remaining symbols are identical enumerals, then
5163 just keep the first one and discard the rest.
5165 Unlike what we did previously, we do not discard any entry
5166 unless they are ALL identical. This is because the symbol
5167 comparison is not a strict comparison, but rather a practical
5168 comparison. If all symbols are considered identical, then
5169 we can just go ahead and use the first one and discard the rest.
5170 But if we cannot reduce the list to a single element, we have
5171 to ask the user to disambiguate anyways. And if we have to
5172 present a multiple-choice menu, it's less confusing if the list
5173 isn't missing some choices that were identical and yet distinct. */
5174 if (symbols_are_identical_enums (syms, nsyms))
5180 /* Given a type that corresponds to a renaming entity, use the type name
5181 to extract the scope (package name or function name, fully qualified,
5182 and following the GNAT encoding convention) where this renaming has been
5183 defined. The string returned needs to be deallocated after use. */
5186 xget_renaming_scope (struct type *renaming_type)
5188 /* The renaming types adhere to the following convention:
5189 <scope>__<rename>___<XR extension>.
5190 So, to extract the scope, we search for the "___XR" extension,
5191 and then backtrack until we find the first "__". */
5193 const char *name = type_name_no_tag (renaming_type);
5194 const char *suffix = strstr (name, "___XR");
5199 /* Now, backtrack a bit until we find the first "__". Start looking
5200 at suffix - 3, as the <rename> part is at least one character long. */
5202 for (last = suffix - 3; last > name; last--)
5203 if (last[0] == '_' && last[1] == '_')
5206 /* Make a copy of scope and return it. */
5208 scope_len = last - name;
5209 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
5211 strncpy (scope, name, scope_len);
5212 scope[scope_len] = '\0';
5217 /* Return nonzero if NAME corresponds to a package name. */
5220 is_package_name (const char *name)
5222 /* Here, We take advantage of the fact that no symbols are generated
5223 for packages, while symbols are generated for each function.
5224 So the condition for NAME represent a package becomes equivalent
5225 to NAME not existing in our list of symbols. There is only one
5226 small complication with library-level functions (see below). */
5230 /* If it is a function that has not been defined at library level,
5231 then we should be able to look it up in the symbols. */
5232 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5235 /* Library-level function names start with "_ada_". See if function
5236 "_ada_" followed by NAME can be found. */
5238 /* Do a quick check that NAME does not contain "__", since library-level
5239 functions names cannot contain "__" in them. */
5240 if (strstr (name, "__") != NULL)
5243 fun_name = xstrprintf ("_ada_%s", name);
5245 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
5248 /* Return nonzero if SYM corresponds to a renaming entity that is
5249 not visible from FUNCTION_NAME. */
5252 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5255 struct cleanup *old_chain;
5257 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5260 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
5261 old_chain = make_cleanup (xfree, scope);
5263 /* If the rename has been defined in a package, then it is visible. */
5264 if (is_package_name (scope))
5266 do_cleanups (old_chain);
5270 /* Check that the rename is in the current function scope by checking
5271 that its name starts with SCOPE. */
5273 /* If the function name starts with "_ada_", it means that it is
5274 a library-level function. Strip this prefix before doing the
5275 comparison, as the encoding for the renaming does not contain
5277 if (startswith (function_name, "_ada_"))
5281 int is_invisible = !startswith (function_name, scope);
5283 do_cleanups (old_chain);
5284 return is_invisible;
5288 /* Remove entries from SYMS that corresponds to a renaming entity that
5289 is not visible from the function associated with CURRENT_BLOCK or
5290 that is superfluous due to the presence of more specific renaming
5291 information. Places surviving symbols in the initial entries of
5292 SYMS and returns the number of surviving symbols.
5295 First, in cases where an object renaming is implemented as a
5296 reference variable, GNAT may produce both the actual reference
5297 variable and the renaming encoding. In this case, we discard the
5300 Second, GNAT emits a type following a specified encoding for each renaming
5301 entity. Unfortunately, STABS currently does not support the definition
5302 of types that are local to a given lexical block, so all renamings types
5303 are emitted at library level. As a consequence, if an application
5304 contains two renaming entities using the same name, and a user tries to
5305 print the value of one of these entities, the result of the ada symbol
5306 lookup will also contain the wrong renaming type.
5308 This function partially covers for this limitation by attempting to
5309 remove from the SYMS list renaming symbols that should be visible
5310 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5311 method with the current information available. The implementation
5312 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5314 - When the user tries to print a rename in a function while there
5315 is another rename entity defined in a package: Normally, the
5316 rename in the function has precedence over the rename in the
5317 package, so the latter should be removed from the list. This is
5318 currently not the case.
5320 - This function will incorrectly remove valid renames if
5321 the CURRENT_BLOCK corresponds to a function which symbol name
5322 has been changed by an "Export" pragma. As a consequence,
5323 the user will be unable to print such rename entities. */
5326 remove_irrelevant_renamings (struct block_symbol *syms,
5327 int nsyms, const struct block *current_block)
5329 struct symbol *current_function;
5330 const char *current_function_name;
5332 int is_new_style_renaming;
5334 /* If there is both a renaming foo___XR... encoded as a variable and
5335 a simple variable foo in the same block, discard the latter.
5336 First, zero out such symbols, then compress. */
5337 is_new_style_renaming = 0;
5338 for (i = 0; i < nsyms; i += 1)
5340 struct symbol *sym = syms[i].symbol;
5341 const struct block *block = syms[i].block;
5345 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5347 name = SYMBOL_LINKAGE_NAME (sym);
5348 suffix = strstr (name, "___XR");
5352 int name_len = suffix - name;
5355 is_new_style_renaming = 1;
5356 for (j = 0; j < nsyms; j += 1)
5357 if (i != j && syms[j].symbol != NULL
5358 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].symbol),
5360 && block == syms[j].block)
5361 syms[j].symbol = NULL;
5364 if (is_new_style_renaming)
5368 for (j = k = 0; j < nsyms; j += 1)
5369 if (syms[j].symbol != NULL)
5377 /* Extract the function name associated to CURRENT_BLOCK.
5378 Abort if unable to do so. */
5380 if (current_block == NULL)
5383 current_function = block_linkage_function (current_block);
5384 if (current_function == NULL)
5387 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5388 if (current_function_name == NULL)
5391 /* Check each of the symbols, and remove it from the list if it is
5392 a type corresponding to a renaming that is out of the scope of
5393 the current block. */
5398 if (ada_parse_renaming (syms[i].symbol, NULL, NULL, NULL)
5399 == ADA_OBJECT_RENAMING
5400 && old_renaming_is_invisible (syms[i].symbol, current_function_name))
5404 for (j = i + 1; j < nsyms; j += 1)
5405 syms[j - 1] = syms[j];
5415 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5416 whose name and domain match NAME and DOMAIN respectively.
5417 If no match was found, then extend the search to "enclosing"
5418 routines (in other words, if we're inside a nested function,
5419 search the symbols defined inside the enclosing functions).
5420 If WILD_MATCH_P is nonzero, perform the naming matching in
5421 "wild" mode (see function "wild_match" for more info).
5423 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5426 ada_add_local_symbols (struct obstack *obstackp,
5427 const lookup_name_info &lookup_name,
5428 const struct block *block, domain_enum domain)
5430 int block_depth = 0;
5432 while (block != NULL)
5435 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5437 /* If we found a non-function match, assume that's the one. */
5438 if (is_nonfunction (defns_collected (obstackp, 0),
5439 num_defns_collected (obstackp)))
5442 block = BLOCK_SUPERBLOCK (block);
5445 /* If no luck so far, try to find NAME as a local symbol in some lexically
5446 enclosing subprogram. */
5447 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
5448 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
5451 /* An object of this type is used as the user_data argument when
5452 calling the map_matching_symbols method. */
5456 struct objfile *objfile;
5457 struct obstack *obstackp;
5458 struct symbol *arg_sym;
5462 /* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
5463 to a list of symbols. DATA0 is a pointer to a struct match_data *
5464 containing the obstack that collects the symbol list, the file that SYM
5465 must come from, a flag indicating whether a non-argument symbol has
5466 been found in the current block, and the last argument symbol
5467 passed in SYM within the current block (if any). When SYM is null,
5468 marking the end of a block, the argument symbol is added if no
5469 other has been found. */
5472 aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
5474 struct match_data *data = (struct match_data *) data0;
5478 if (!data->found_sym && data->arg_sym != NULL)
5479 add_defn_to_vec (data->obstackp,
5480 fixup_symbol_section (data->arg_sym, data->objfile),
5482 data->found_sym = 0;
5483 data->arg_sym = NULL;
5487 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5489 else if (SYMBOL_IS_ARGUMENT (sym))
5490 data->arg_sym = sym;
5493 data->found_sym = 1;
5494 add_defn_to_vec (data->obstackp,
5495 fixup_symbol_section (sym, data->objfile),
5502 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5503 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5504 symbols to OBSTACKP. Return whether we found such symbols. */
5507 ada_add_block_renamings (struct obstack *obstackp,
5508 const struct block *block,
5509 const lookup_name_info &lookup_name,
5512 struct using_direct *renaming;
5513 int defns_mark = num_defns_collected (obstackp);
5515 symbol_name_matcher_ftype *name_match
5516 = ada_get_symbol_name_matcher (lookup_name);
5518 for (renaming = block_using (block);
5520 renaming = renaming->next)
5524 /* Avoid infinite recursions: skip this renaming if we are actually
5525 already traversing it.
5527 Currently, symbol lookup in Ada don't use the namespace machinery from
5528 C++/Fortran support: skip namespace imports that use them. */
5529 if (renaming->searched
5530 || (renaming->import_src != NULL
5531 && renaming->import_src[0] != '\0')
5532 || (renaming->import_dest != NULL
5533 && renaming->import_dest[0] != '\0'))
5535 renaming->searched = 1;
5537 /* TODO: here, we perform another name-based symbol lookup, which can
5538 pull its own multiple overloads. In theory, we should be able to do
5539 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5540 not a simple name. But in order to do this, we would need to enhance
5541 the DWARF reader to associate a symbol to this renaming, instead of a
5542 name. So, for now, we do something simpler: re-use the C++/Fortran
5543 namespace machinery. */
5544 r_name = (renaming->alias != NULL
5546 : renaming->declaration);
5547 if (name_match (r_name, lookup_name, NULL))
5549 lookup_name_info decl_lookup_name (renaming->declaration,
5550 lookup_name.match_type ());
5551 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5554 renaming->searched = 0;
5556 return num_defns_collected (obstackp) != defns_mark;
5559 /* Implements compare_names, but only applying the comparision using
5560 the given CASING. */
5563 compare_names_with_case (const char *string1, const char *string2,
5564 enum case_sensitivity casing)
5566 while (*string1 != '\0' && *string2 != '\0')
5570 if (isspace (*string1) || isspace (*string2))
5571 return strcmp_iw_ordered (string1, string2);
5573 if (casing == case_sensitive_off)
5575 c1 = tolower (*string1);
5576 c2 = tolower (*string2);
5593 return strcmp_iw_ordered (string1, string2);
5595 if (*string2 == '\0')
5597 if (is_name_suffix (string1))
5604 if (*string2 == '(')
5605 return strcmp_iw_ordered (string1, string2);
5608 if (casing == case_sensitive_off)
5609 return tolower (*string1) - tolower (*string2);
5611 return *string1 - *string2;
5616 /* Compare STRING1 to STRING2, with results as for strcmp.
5617 Compatible with strcmp_iw_ordered in that...
5619 strcmp_iw_ordered (STRING1, STRING2) <= 0
5623 compare_names (STRING1, STRING2) <= 0
5625 (they may differ as to what symbols compare equal). */
5628 compare_names (const char *string1, const char *string2)
5632 /* Similar to what strcmp_iw_ordered does, we need to perform
5633 a case-insensitive comparison first, and only resort to
5634 a second, case-sensitive, comparison if the first one was
5635 not sufficient to differentiate the two strings. */
5637 result = compare_names_with_case (string1, string2, case_sensitive_off);
5639 result = compare_names_with_case (string1, string2, case_sensitive_on);
5644 /* Convenience function to get at the Ada encoded lookup name for
5645 LOOKUP_NAME, as a C string. */
5648 ada_lookup_name (const lookup_name_info &lookup_name)
5650 return lookup_name.ada ().lookup_name ().c_str ();
5653 /* Add to OBSTACKP all non-local symbols whose name and domain match
5654 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5655 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5656 symbols otherwise. */
5659 add_nonlocal_symbols (struct obstack *obstackp,
5660 const lookup_name_info &lookup_name,
5661 domain_enum domain, int global)
5663 struct objfile *objfile;
5664 struct compunit_symtab *cu;
5665 struct match_data data;
5667 memset (&data, 0, sizeof data);
5668 data.obstackp = obstackp;
5670 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5672 ALL_OBJFILES (objfile)
5674 data.objfile = objfile;
5677 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5679 aux_add_nonlocal_symbols, &data,
5680 symbol_name_match_type::WILD,
5683 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5685 aux_add_nonlocal_symbols, &data,
5686 symbol_name_match_type::FULL,
5689 ALL_OBJFILE_COMPUNITS (objfile, cu)
5691 const struct block *global_block
5692 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5694 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5700 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5702 const char *name = ada_lookup_name (lookup_name);
5703 std::string name1 = std::string ("<_ada_") + name + '>';
5705 ALL_OBJFILES (objfile)
5707 data.objfile = objfile;
5708 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5710 aux_add_nonlocal_symbols,
5712 symbol_name_match_type::FULL,
5718 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5719 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5720 returning the number of matches. Add these to OBSTACKP.
5722 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5723 symbol match within the nest of blocks whose innermost member is BLOCK,
5724 is the one match returned (no other matches in that or
5725 enclosing blocks is returned). If there are any matches in or
5726 surrounding BLOCK, then these alone are returned.
5728 Names prefixed with "standard__" are handled specially:
5729 "standard__" is first stripped off (by the lookup_name
5730 constructor), and only static and global symbols are searched.
5732 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5733 to lookup global symbols. */
5736 ada_add_all_symbols (struct obstack *obstackp,
5737 const struct block *block,
5738 const lookup_name_info &lookup_name,
5741 int *made_global_lookup_p)
5745 if (made_global_lookup_p)
5746 *made_global_lookup_p = 0;
5748 /* Special case: If the user specifies a symbol name inside package
5749 Standard, do a non-wild matching of the symbol name without
5750 the "standard__" prefix. This was primarily introduced in order
5751 to allow the user to specifically access the standard exceptions
5752 using, for instance, Standard.Constraint_Error when Constraint_Error
5753 is ambiguous (due to the user defining its own Constraint_Error
5754 entity inside its program). */
5755 if (lookup_name.ada ().standard_p ())
5758 /* Check the non-global symbols. If we have ANY match, then we're done. */
5763 ada_add_local_symbols (obstackp, lookup_name, block, domain);
5766 /* In the !full_search case we're are being called by
5767 ada_iterate_over_symbols, and we don't want to search
5769 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5771 if (num_defns_collected (obstackp) > 0 || !full_search)
5775 /* No non-global symbols found. Check our cache to see if we have
5776 already performed this search before. If we have, then return
5779 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5780 domain, &sym, &block))
5783 add_defn_to_vec (obstackp, sym, block);
5787 if (made_global_lookup_p)
5788 *made_global_lookup_p = 1;
5790 /* Search symbols from all global blocks. */
5792 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
5794 /* Now add symbols from all per-file blocks if we've gotten no hits
5795 (not strictly correct, but perhaps better than an error). */
5797 if (num_defns_collected (obstackp) == 0)
5798 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
5801 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5802 is non-zero, enclosing scope and in global scopes, returning the number of
5804 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
5805 indicating the symbols found and the blocks and symbol tables (if
5806 any) in which they were found. This vector is transient---good only to
5807 the next call of ada_lookup_symbol_list.
5809 When full_search is non-zero, any non-function/non-enumeral
5810 symbol match within the nest of blocks whose innermost member is BLOCK,
5811 is the one match returned (no other matches in that or
5812 enclosing blocks is returned). If there are any matches in or
5813 surrounding BLOCK, then these alone are returned.
5815 Names prefixed with "standard__" are handled specially: "standard__"
5816 is first stripped off, and only static and global symbols are searched. */
5819 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5820 const struct block *block,
5822 struct block_symbol **results,
5825 int syms_from_global_search;
5828 obstack_free (&symbol_list_obstack, NULL);
5829 obstack_init (&symbol_list_obstack);
5830 ada_add_all_symbols (&symbol_list_obstack, block, lookup_name,
5831 domain, full_search, &syms_from_global_search);
5833 ndefns = num_defns_collected (&symbol_list_obstack);
5834 *results = defns_collected (&symbol_list_obstack, 1);
5836 ndefns = remove_extra_symbols (*results, ndefns);
5838 if (ndefns == 0 && full_search && syms_from_global_search)
5839 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5841 if (ndefns == 1 && full_search && syms_from_global_search)
5842 cache_symbol (ada_lookup_name (lookup_name), domain,
5843 (*results)[0].symbol, (*results)[0].block);
5845 ndefns = remove_irrelevant_renamings (*results, ndefns, block);
5849 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5850 in global scopes, returning the number of matches, and setting *RESULTS
5851 to a vector of (SYM,BLOCK) tuples.
5852 See ada_lookup_symbol_list_worker for further details. */
5855 ada_lookup_symbol_list (const char *name, const struct block *block,
5856 domain_enum domain, struct block_symbol **results)
5858 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5859 lookup_name_info lookup_name (name, name_match_type);
5861 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
5864 /* Implementation of the la_iterate_over_symbols method. */
5867 ada_iterate_over_symbols
5868 (const struct block *block, const lookup_name_info &name,
5870 gdb::function_view<symbol_found_callback_ftype> callback)
5873 struct block_symbol *results;
5875 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5876 for (i = 0; i < ndefs; ++i)
5878 if (!callback (results[i].symbol))
5883 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5884 to 1, but choosing the first symbol found if there are multiple
5887 The result is stored in *INFO, which must be non-NULL.
5888 If no match is found, INFO->SYM is set to NULL. */
5891 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5893 struct block_symbol *info)
5895 struct block_symbol *candidates;
5898 /* Since we already have an encoded name, wrap it in '<>' to force a
5899 verbatim match. Otherwise, if the name happens to not look like
5900 an encoded name (because it doesn't include a "__"),
5901 ada_lookup_name_info would re-encode/fold it again, and that
5902 would e.g., incorrectly lowercase object renaming names like
5903 "R28b" -> "r28b". */
5904 std::string verbatim = std::string ("<") + name + '>';
5906 gdb_assert (info != NULL);
5907 memset (info, 0, sizeof (struct block_symbol));
5909 n_candidates = ada_lookup_symbol_list (verbatim.c_str (), block,
5910 domain, &candidates);
5911 if (n_candidates == 0)
5914 *info = candidates[0];
5915 info->symbol = fixup_symbol_section (info->symbol, NULL);
5918 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5919 scope and in global scopes, or NULL if none. NAME is folded and
5920 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5921 choosing the first symbol if there are multiple choices.
5922 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5925 ada_lookup_symbol (const char *name, const struct block *block0,
5926 domain_enum domain, int *is_a_field_of_this)
5928 struct block_symbol info;
5930 if (is_a_field_of_this != NULL)
5931 *is_a_field_of_this = 0;
5933 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
5934 block0, domain, &info);
5938 static struct block_symbol
5939 ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5941 const struct block *block,
5942 const domain_enum domain)
5944 struct block_symbol sym;
5946 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
5947 if (sym.symbol != NULL)
5950 /* If we haven't found a match at this point, try the primitive
5951 types. In other languages, this search is performed before
5952 searching for global symbols in order to short-circuit that
5953 global-symbol search if it happens that the name corresponds
5954 to a primitive type. But we cannot do the same in Ada, because
5955 it is perfectly legitimate for a program to declare a type which
5956 has the same name as a standard type. If looking up a type in
5957 that situation, we have traditionally ignored the primitive type
5958 in favor of user-defined types. This is why, unlike most other
5959 languages, we search the primitive types this late and only after
5960 having searched the global symbols without success. */
5962 if (domain == VAR_DOMAIN)
5964 struct gdbarch *gdbarch;
5967 gdbarch = target_gdbarch ();
5969 gdbarch = block_gdbarch (block);
5970 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5971 if (sym.symbol != NULL)
5975 return (struct block_symbol) {NULL, NULL};
5979 /* True iff STR is a possible encoded suffix of a normal Ada name
5980 that is to be ignored for matching purposes. Suffixes of parallel
5981 names (e.g., XVE) are not included here. Currently, the possible suffixes
5982 are given by any of the regular expressions:
5984 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5985 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5986 TKB [subprogram suffix for task bodies]
5987 _E[0-9]+[bs]$ [protected object entry suffixes]
5988 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5990 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5991 match is performed. This sequence is used to differentiate homonyms,
5992 is an optional part of a valid name suffix. */
5995 is_name_suffix (const char *str)
5998 const char *matching;
5999 const int len = strlen (str);
6001 /* Skip optional leading __[0-9]+. */
6003 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
6006 while (isdigit (str[0]))
6012 if (str[0] == '.' || str[0] == '$')
6015 while (isdigit (matching[0]))
6017 if (matching[0] == '\0')
6023 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
6026 while (isdigit (matching[0]))
6028 if (matching[0] == '\0')
6032 /* "TKB" suffixes are used for subprograms implementing task bodies. */
6034 if (strcmp (str, "TKB") == 0)
6038 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
6039 with a N at the end. Unfortunately, the compiler uses the same
6040 convention for other internal types it creates. So treating
6041 all entity names that end with an "N" as a name suffix causes
6042 some regressions. For instance, consider the case of an enumerated
6043 type. To support the 'Image attribute, it creates an array whose
6045 Having a single character like this as a suffix carrying some
6046 information is a bit risky. Perhaps we should change the encoding
6047 to be something like "_N" instead. In the meantime, do not do
6048 the following check. */
6049 /* Protected Object Subprograms */
6050 if (len == 1 && str [0] == 'N')
6055 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6058 while (isdigit (matching[0]))
6060 if ((matching[0] == 'b' || matching[0] == 's')
6061 && matching [1] == '\0')
6065 /* ??? We should not modify STR directly, as we are doing below. This
6066 is fine in this case, but may become problematic later if we find
6067 that this alternative did not work, and want to try matching
6068 another one from the begining of STR. Since we modified it, we
6069 won't be able to find the begining of the string anymore! */
6073 while (str[0] != '_' && str[0] != '\0')
6075 if (str[0] != 'n' && str[0] != 'b')
6081 if (str[0] == '\000')
6086 if (str[1] != '_' || str[2] == '\000')
6090 if (strcmp (str + 3, "JM") == 0)
6092 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6093 the LJM suffix in favor of the JM one. But we will
6094 still accept LJM as a valid suffix for a reasonable
6095 amount of time, just to allow ourselves to debug programs
6096 compiled using an older version of GNAT. */
6097 if (strcmp (str + 3, "LJM") == 0)
6101 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6102 || str[4] == 'U' || str[4] == 'P')
6104 if (str[4] == 'R' && str[5] != 'T')
6108 if (!isdigit (str[2]))
6110 for (k = 3; str[k] != '\0'; k += 1)
6111 if (!isdigit (str[k]) && str[k] != '_')
6115 if (str[0] == '$' && isdigit (str[1]))
6117 for (k = 2; str[k] != '\0'; k += 1)
6118 if (!isdigit (str[k]) && str[k] != '_')
6125 /* Return non-zero if the string starting at NAME and ending before
6126 NAME_END contains no capital letters. */
6129 is_valid_name_for_wild_match (const char *name0)
6131 const char *decoded_name = ada_decode (name0);
6134 /* If the decoded name starts with an angle bracket, it means that
6135 NAME0 does not follow the GNAT encoding format. It should then
6136 not be allowed as a possible wild match. */
6137 if (decoded_name[0] == '<')
6140 for (i=0; decoded_name[i] != '\0'; i++)
6141 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6147 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6148 that could start a simple name. Assumes that *NAMEP points into
6149 the string beginning at NAME0. */
6152 advance_wild_match (const char **namep, const char *name0, int target0)
6154 const char *name = *namep;
6164 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6167 if (name == name0 + 5 && startswith (name0, "_ada"))
6172 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6173 || name[2] == target0))
6181 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6191 /* Return true iff NAME encodes a name of the form prefix.PATN.
6192 Ignores any informational suffixes of NAME (i.e., for which
6193 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6197 wild_match (const char *name, const char *patn)
6200 const char *name0 = name;
6204 const char *match = name;
6208 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6211 if (*p == '\0' && is_name_suffix (name))
6212 return match == name0 || is_valid_name_for_wild_match (name0);
6214 if (name[-1] == '_')
6217 if (!advance_wild_match (&name, name0, *patn))
6222 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6223 any trailing suffixes that encode debugging information or leading
6224 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6225 information that is ignored). */
6228 full_match (const char *sym_name, const char *search_name)
6230 size_t search_name_len = strlen (search_name);
6232 if (strncmp (sym_name, search_name, search_name_len) == 0
6233 && is_name_suffix (sym_name + search_name_len))
6236 if (startswith (sym_name, "_ada_")
6237 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6238 && is_name_suffix (sym_name + search_name_len + 5))
6244 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6245 *defn_symbols, updating the list of symbols in OBSTACKP (if
6246 necessary). OBJFILE is the section containing BLOCK. */
6249 ada_add_block_symbols (struct obstack *obstackp,
6250 const struct block *block,
6251 const lookup_name_info &lookup_name,
6252 domain_enum domain, struct objfile *objfile)
6254 struct block_iterator iter;
6255 /* A matching argument symbol, if any. */
6256 struct symbol *arg_sym;
6257 /* Set true when we find a matching non-argument symbol. */
6263 for (sym = block_iter_match_first (block, lookup_name, &iter);
6265 sym = block_iter_match_next (lookup_name, &iter))
6267 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6268 SYMBOL_DOMAIN (sym), domain))
6270 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6272 if (SYMBOL_IS_ARGUMENT (sym))
6277 add_defn_to_vec (obstackp,
6278 fixup_symbol_section (sym, objfile),
6285 /* Handle renamings. */
6287 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
6290 if (!found_sym && arg_sym != NULL)
6292 add_defn_to_vec (obstackp,
6293 fixup_symbol_section (arg_sym, objfile),
6297 if (!lookup_name.ada ().wild_match_p ())
6301 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6302 const char *name = ada_lookup_name.c_str ();
6303 size_t name_len = ada_lookup_name.size ();
6305 ALL_BLOCK_SYMBOLS (block, iter, sym)
6307 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6308 SYMBOL_DOMAIN (sym), domain))
6312 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6315 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
6317 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6322 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6324 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6326 if (SYMBOL_IS_ARGUMENT (sym))
6331 add_defn_to_vec (obstackp,
6332 fixup_symbol_section (sym, objfile),
6340 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6341 They aren't parameters, right? */
6342 if (!found_sym && arg_sym != NULL)
6344 add_defn_to_vec (obstackp,
6345 fixup_symbol_section (arg_sym, objfile),
6352 /* Symbol Completion */
6357 ada_lookup_name_info::matches
6358 (const char *sym_name,
6359 symbol_name_match_type match_type,
6360 completion_match *comp_match) const
6363 const char *text = m_encoded_name.c_str ();
6364 size_t text_len = m_encoded_name.size ();
6366 /* First, test against the fully qualified name of the symbol. */
6368 if (strncmp (sym_name, text, text_len) == 0)
6371 if (match && !m_encoded_p)
6373 /* One needed check before declaring a positive match is to verify
6374 that iff we are doing a verbatim match, the decoded version
6375 of the symbol name starts with '<'. Otherwise, this symbol name
6376 is not a suitable completion. */
6377 const char *sym_name_copy = sym_name;
6378 bool has_angle_bracket;
6380 sym_name = ada_decode (sym_name);
6381 has_angle_bracket = (sym_name[0] == '<');
6382 match = (has_angle_bracket == m_verbatim_p);
6383 sym_name = sym_name_copy;
6386 if (match && !m_verbatim_p)
6388 /* When doing non-verbatim match, another check that needs to
6389 be done is to verify that the potentially matching symbol name
6390 does not include capital letters, because the ada-mode would
6391 not be able to understand these symbol names without the
6392 angle bracket notation. */
6395 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6400 /* Second: Try wild matching... */
6402 if (!match && m_wild_match_p)
6404 /* Since we are doing wild matching, this means that TEXT
6405 may represent an unqualified symbol name. We therefore must
6406 also compare TEXT against the unqualified name of the symbol. */
6407 sym_name = ada_unqualified_name (ada_decode (sym_name));
6409 if (strncmp (sym_name, text, text_len) == 0)
6413 /* Finally: If we found a match, prepare the result to return. */
6418 if (comp_match != NULL)
6420 std::string &match_str = comp_match->storage ();
6424 match_str = ada_decode (sym_name);
6425 comp_match->set_match (match_str.c_str ());
6430 match_str = add_angle_brackets (sym_name);
6432 match_str = sym_name;
6434 comp_match->set_match (match_str.c_str ());
6441 /* Add the list of possible symbol names completing TEXT to TRACKER.
6442 WORD is the entire command on which completion is made. */
6445 ada_collect_symbol_completion_matches (completion_tracker &tracker,
6446 complete_symbol_mode mode,
6447 symbol_name_match_type name_match_type,
6448 const char *text, const char *word,
6449 enum type_code code)
6452 struct compunit_symtab *s;
6453 struct minimal_symbol *msymbol;
6454 struct objfile *objfile;
6455 const struct block *b, *surrounding_static_block = 0;
6457 struct block_iterator iter;
6458 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
6460 gdb_assert (code == TYPE_CODE_UNDEF);
6462 lookup_name_info lookup_name (text, name_match_type, true);
6464 /* First, look at the partial symtab symbols. */
6465 expand_symtabs_matching (NULL,
6471 /* At this point scan through the misc symbol vectors and add each
6472 symbol you find to the list. Eventually we want to ignore
6473 anything that isn't a text symbol (everything else will be
6474 handled by the psymtab code above). */
6476 ALL_MSYMBOLS (objfile, msymbol)
6480 if (completion_skip_symbol (mode, msymbol))
6483 completion_list_add_name (tracker,
6484 MSYMBOL_LANGUAGE (msymbol),
6485 MSYMBOL_LINKAGE_NAME (msymbol),
6486 lookup_name, text, word);
6489 /* Search upwards from currently selected frame (so that we can
6490 complete on local vars. */
6492 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6494 if (!BLOCK_SUPERBLOCK (b))
6495 surrounding_static_block = b; /* For elmin of dups */
6497 ALL_BLOCK_SYMBOLS (b, iter, sym)
6499 if (completion_skip_symbol (mode, sym))
6502 completion_list_add_name (tracker,
6503 SYMBOL_LANGUAGE (sym),
6504 SYMBOL_LINKAGE_NAME (sym),
6505 lookup_name, text, word);
6509 /* Go through the symtabs and check the externs and statics for
6510 symbols which match. */
6512 ALL_COMPUNITS (objfile, s)
6515 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
6516 ALL_BLOCK_SYMBOLS (b, iter, sym)
6518 if (completion_skip_symbol (mode, sym))
6521 completion_list_add_name (tracker,
6522 SYMBOL_LANGUAGE (sym),
6523 SYMBOL_LINKAGE_NAME (sym),
6524 lookup_name, text, word);
6528 ALL_COMPUNITS (objfile, s)
6531 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
6532 /* Don't do this block twice. */
6533 if (b == surrounding_static_block)
6535 ALL_BLOCK_SYMBOLS (b, iter, sym)
6537 if (completion_skip_symbol (mode, sym))
6540 completion_list_add_name (tracker,
6541 SYMBOL_LANGUAGE (sym),
6542 SYMBOL_LINKAGE_NAME (sym),
6543 lookup_name, text, word);
6547 do_cleanups (old_chain);
6552 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6553 for tagged types. */
6556 ada_is_dispatch_table_ptr_type (struct type *type)
6560 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6563 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6567 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6570 /* Return non-zero if TYPE is an interface tag. */
6573 ada_is_interface_tag (struct type *type)
6575 const char *name = TYPE_NAME (type);
6580 return (strcmp (name, "ada__tags__interface_tag") == 0);
6583 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6584 to be invisible to users. */
6587 ada_is_ignored_field (struct type *type, int field_num)
6589 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6592 /* Check the name of that field. */
6594 const char *name = TYPE_FIELD_NAME (type, field_num);
6596 /* Anonymous field names should not be printed.
6597 brobecker/2007-02-20: I don't think this can actually happen
6598 but we don't want to print the value of annonymous fields anyway. */
6602 /* Normally, fields whose name start with an underscore ("_")
6603 are fields that have been internally generated by the compiler,
6604 and thus should not be printed. The "_parent" field is special,
6605 however: This is a field internally generated by the compiler
6606 for tagged types, and it contains the components inherited from
6607 the parent type. This field should not be printed as is, but
6608 should not be ignored either. */
6609 if (name[0] == '_' && !startswith (name, "_parent"))
6613 /* If this is the dispatch table of a tagged type or an interface tag,
6615 if (ada_is_tagged_type (type, 1)
6616 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6617 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
6620 /* Not a special field, so it should not be ignored. */
6624 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6625 pointer or reference type whose ultimate target has a tag field. */
6628 ada_is_tagged_type (struct type *type, int refok)
6630 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6633 /* True iff TYPE represents the type of X'Tag */
6636 ada_is_tag_type (struct type *type)
6638 type = ada_check_typedef (type);
6640 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6644 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6646 return (name != NULL
6647 && strcmp (name, "ada__tags__dispatch_table") == 0);
6651 /* The type of the tag on VAL. */
6654 ada_tag_type (struct value *val)
6656 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6659 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6660 retired at Ada 05). */
6663 is_ada95_tag (struct value *tag)
6665 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6668 /* The value of the tag on VAL. */
6671 ada_value_tag (struct value *val)
6673 return ada_value_struct_elt (val, "_tag", 0);
6676 /* The value of the tag on the object of type TYPE whose contents are
6677 saved at VALADDR, if it is non-null, or is at memory address
6680 static struct value *
6681 value_tag_from_contents_and_address (struct type *type,
6682 const gdb_byte *valaddr,
6685 int tag_byte_offset;
6686 struct type *tag_type;
6688 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6691 const gdb_byte *valaddr1 = ((valaddr == NULL)
6693 : valaddr + tag_byte_offset);
6694 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6696 return value_from_contents_and_address (tag_type, valaddr1, address1);
6701 static struct type *
6702 type_from_tag (struct value *tag)
6704 const char *type_name = ada_tag_name (tag);
6706 if (type_name != NULL)
6707 return ada_find_any_type (ada_encode (type_name));
6711 /* Given a value OBJ of a tagged type, return a value of this
6712 type at the base address of the object. The base address, as
6713 defined in Ada.Tags, it is the address of the primary tag of
6714 the object, and therefore where the field values of its full
6715 view can be fetched. */
6718 ada_tag_value_at_base_address (struct value *obj)
6721 LONGEST offset_to_top = 0;
6722 struct type *ptr_type, *obj_type;
6724 CORE_ADDR base_address;
6726 obj_type = value_type (obj);
6728 /* It is the responsability of the caller to deref pointers. */
6730 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6731 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6734 tag = ada_value_tag (obj);
6738 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6740 if (is_ada95_tag (tag))
6743 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6744 ptr_type = lookup_pointer_type (ptr_type);
6745 val = value_cast (ptr_type, tag);
6749 /* It is perfectly possible that an exception be raised while
6750 trying to determine the base address, just like for the tag;
6751 see ada_tag_name for more details. We do not print the error
6752 message for the same reason. */
6756 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6759 CATCH (e, RETURN_MASK_ERROR)
6765 /* If offset is null, nothing to do. */
6767 if (offset_to_top == 0)
6770 /* -1 is a special case in Ada.Tags; however, what should be done
6771 is not quite clear from the documentation. So do nothing for
6774 if (offset_to_top == -1)
6777 base_address = value_address (obj) - offset_to_top;
6778 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6780 /* Make sure that we have a proper tag at the new address.
6781 Otherwise, offset_to_top is bogus (which can happen when
6782 the object is not initialized yet). */
6787 obj_type = type_from_tag (tag);
6792 return value_from_contents_and_address (obj_type, NULL, base_address);
6795 /* Return the "ada__tags__type_specific_data" type. */
6797 static struct type *
6798 ada_get_tsd_type (struct inferior *inf)
6800 struct ada_inferior_data *data = get_ada_inferior_data (inf);
6802 if (data->tsd_type == 0)
6803 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6804 return data->tsd_type;
6807 /* Return the TSD (type-specific data) associated to the given TAG.
6808 TAG is assumed to be the tag of a tagged-type entity.
6810 May return NULL if we are unable to get the TSD. */
6812 static struct value *
6813 ada_get_tsd_from_tag (struct value *tag)
6818 /* First option: The TSD is simply stored as a field of our TAG.
6819 Only older versions of GNAT would use this format, but we have
6820 to test it first, because there are no visible markers for
6821 the current approach except the absence of that field. */
6823 val = ada_value_struct_elt (tag, "tsd", 1);
6827 /* Try the second representation for the dispatch table (in which
6828 there is no explicit 'tsd' field in the referent of the tag pointer,
6829 and instead the tsd pointer is stored just before the dispatch
6832 type = ada_get_tsd_type (current_inferior());
6835 type = lookup_pointer_type (lookup_pointer_type (type));
6836 val = value_cast (type, tag);
6839 return value_ind (value_ptradd (val, -1));
6842 /* Given the TSD of a tag (type-specific data), return a string
6843 containing the name of the associated type.
6845 The returned value is good until the next call. May return NULL
6846 if we are unable to determine the tag name. */
6849 ada_tag_name_from_tsd (struct value *tsd)
6851 static char name[1024];
6855 val = ada_value_struct_elt (tsd, "expanded_name", 1);
6858 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6859 for (p = name; *p != '\0'; p += 1)
6865 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6868 Return NULL if the TAG is not an Ada tag, or if we were unable to
6869 determine the name of that tag. The result is good until the next
6873 ada_tag_name (struct value *tag)
6877 if (!ada_is_tag_type (value_type (tag)))
6880 /* It is perfectly possible that an exception be raised while trying
6881 to determine the TAG's name, even under normal circumstances:
6882 The associated variable may be uninitialized or corrupted, for
6883 instance. We do not let any exception propagate past this point.
6884 instead we return NULL.
6886 We also do not print the error message either (which often is very
6887 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6888 the caller print a more meaningful message if necessary. */
6891 struct value *tsd = ada_get_tsd_from_tag (tag);
6894 name = ada_tag_name_from_tsd (tsd);
6896 CATCH (e, RETURN_MASK_ERROR)
6904 /* The parent type of TYPE, or NULL if none. */
6907 ada_parent_type (struct type *type)
6911 type = ada_check_typedef (type);
6913 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6916 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6917 if (ada_is_parent_field (type, i))
6919 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6921 /* If the _parent field is a pointer, then dereference it. */
6922 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6923 parent_type = TYPE_TARGET_TYPE (parent_type);
6924 /* If there is a parallel XVS type, get the actual base type. */
6925 parent_type = ada_get_base_type (parent_type);
6927 return ada_check_typedef (parent_type);
6933 /* True iff field number FIELD_NUM of structure type TYPE contains the
6934 parent-type (inherited) fields of a derived type. Assumes TYPE is
6935 a structure type with at least FIELD_NUM+1 fields. */
6938 ada_is_parent_field (struct type *type, int field_num)
6940 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6942 return (name != NULL
6943 && (startswith (name, "PARENT")
6944 || startswith (name, "_parent")));
6947 /* True iff field number FIELD_NUM of structure type TYPE is a
6948 transparent wrapper field (which should be silently traversed when doing
6949 field selection and flattened when printing). Assumes TYPE is a
6950 structure type with at least FIELD_NUM+1 fields. Such fields are always
6954 ada_is_wrapper_field (struct type *type, int field_num)
6956 const char *name = TYPE_FIELD_NAME (type, field_num);
6958 if (name != NULL && strcmp (name, "RETVAL") == 0)
6960 /* This happens in functions with "out" or "in out" parameters
6961 which are passed by copy. For such functions, GNAT describes
6962 the function's return type as being a struct where the return
6963 value is in a field called RETVAL, and where the other "out"
6964 or "in out" parameters are fields of that struct. This is not
6969 return (name != NULL
6970 && (startswith (name, "PARENT")
6971 || strcmp (name, "REP") == 0
6972 || startswith (name, "_parent")
6973 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6976 /* True iff field number FIELD_NUM of structure or union type TYPE
6977 is a variant wrapper. Assumes TYPE is a structure type with at least
6978 FIELD_NUM+1 fields. */
6981 ada_is_variant_part (struct type *type, int field_num)
6983 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
6985 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
6986 || (is_dynamic_field (type, field_num)
6987 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6988 == TYPE_CODE_UNION)));
6991 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6992 whose discriminants are contained in the record type OUTER_TYPE,
6993 returns the type of the controlling discriminant for the variant.
6994 May return NULL if the type could not be found. */
6997 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6999 const char *name = ada_variant_discrim_name (var_type);
7001 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
7004 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
7005 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
7006 represents a 'when others' clause; otherwise 0. */
7009 ada_is_others_clause (struct type *type, int field_num)
7011 const char *name = TYPE_FIELD_NAME (type, field_num);
7013 return (name != NULL && name[0] == 'O');
7016 /* Assuming that TYPE0 is the type of the variant part of a record,
7017 returns the name of the discriminant controlling the variant.
7018 The value is valid until the next call to ada_variant_discrim_name. */
7021 ada_variant_discrim_name (struct type *type0)
7023 static char *result = NULL;
7024 static size_t result_len = 0;
7027 const char *discrim_end;
7028 const char *discrim_start;
7030 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7031 type = TYPE_TARGET_TYPE (type0);
7035 name = ada_type_name (type);
7037 if (name == NULL || name[0] == '\000')
7040 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7043 if (startswith (discrim_end, "___XVN"))
7046 if (discrim_end == name)
7049 for (discrim_start = discrim_end; discrim_start != name + 3;
7052 if (discrim_start == name + 1)
7054 if ((discrim_start > name + 3
7055 && startswith (discrim_start - 3, "___"))
7056 || discrim_start[-1] == '.')
7060 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7061 strncpy (result, discrim_start, discrim_end - discrim_start);
7062 result[discrim_end - discrim_start] = '\0';
7066 /* Scan STR for a subtype-encoded number, beginning at position K.
7067 Put the position of the character just past the number scanned in
7068 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7069 Return 1 if there was a valid number at the given position, and 0
7070 otherwise. A "subtype-encoded" number consists of the absolute value
7071 in decimal, followed by the letter 'm' to indicate a negative number.
7072 Assumes 0m does not occur. */
7075 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
7079 if (!isdigit (str[k]))
7082 /* Do it the hard way so as not to make any assumption about
7083 the relationship of unsigned long (%lu scan format code) and
7086 while (isdigit (str[k]))
7088 RU = RU * 10 + (str[k] - '0');
7095 *R = (-(LONGEST) (RU - 1)) - 1;
7101 /* NOTE on the above: Technically, C does not say what the results of
7102 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7103 number representable as a LONGEST (although either would probably work
7104 in most implementations). When RU>0, the locution in the then branch
7105 above is always equivalent to the negative of RU. */
7112 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7113 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7114 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
7117 ada_in_variant (LONGEST val, struct type *type, int field_num)
7119 const char *name = TYPE_FIELD_NAME (type, field_num);
7133 if (!ada_scan_number (name, p + 1, &W, &p))
7143 if (!ada_scan_number (name, p + 1, &L, &p)
7144 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7146 if (val >= L && val <= U)
7158 /* FIXME: Lots of redundancy below. Try to consolidate. */
7160 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7161 ARG_TYPE, extract and return the value of one of its (non-static)
7162 fields. FIELDNO says which field. Differs from value_primitive_field
7163 only in that it can handle packed values of arbitrary type. */
7165 static struct value *
7166 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
7167 struct type *arg_type)
7171 arg_type = ada_check_typedef (arg_type);
7172 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7174 /* Handle packed fields. */
7176 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7178 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7179 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
7181 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
7182 offset + bit_pos / 8,
7183 bit_pos % 8, bit_size, type);
7186 return value_primitive_field (arg1, offset, fieldno, arg_type);
7189 /* Find field with name NAME in object of type TYPE. If found,
7190 set the following for each argument that is non-null:
7191 - *FIELD_TYPE_P to the field's type;
7192 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7193 an object of that type;
7194 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7195 - *BIT_SIZE_P to its size in bits if the field is packed, and
7197 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7198 fields up to but not including the desired field, or by the total
7199 number of fields if not found. A NULL value of NAME never
7200 matches; the function just counts visible fields in this case.
7202 Returns 1 if found, 0 otherwise. */
7205 find_struct_field (const char *name, struct type *type, int offset,
7206 struct type **field_type_p,
7207 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7212 type = ada_check_typedef (type);
7214 if (field_type_p != NULL)
7215 *field_type_p = NULL;
7216 if (byte_offset_p != NULL)
7218 if (bit_offset_p != NULL)
7220 if (bit_size_p != NULL)
7223 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7225 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7226 int fld_offset = offset + bit_pos / 8;
7227 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7229 if (t_field_name == NULL)
7232 else if (name != NULL && field_name_match (t_field_name, name))
7234 int bit_size = TYPE_FIELD_BITSIZE (type, i);
7236 if (field_type_p != NULL)
7237 *field_type_p = TYPE_FIELD_TYPE (type, i);
7238 if (byte_offset_p != NULL)
7239 *byte_offset_p = fld_offset;
7240 if (bit_offset_p != NULL)
7241 *bit_offset_p = bit_pos % 8;
7242 if (bit_size_p != NULL)
7243 *bit_size_p = bit_size;
7246 else if (ada_is_wrapper_field (type, i))
7248 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7249 field_type_p, byte_offset_p, bit_offset_p,
7250 bit_size_p, index_p))
7253 else if (ada_is_variant_part (type, i))
7255 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7258 struct type *field_type
7259 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
7261 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7263 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7265 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7266 field_type_p, byte_offset_p,
7267 bit_offset_p, bit_size_p, index_p))
7271 else if (index_p != NULL)
7277 /* Number of user-visible fields in record type TYPE. */
7280 num_visible_fields (struct type *type)
7285 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7289 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7290 and search in it assuming it has (class) type TYPE.
7291 If found, return value, else return NULL.
7293 Searches recursively through wrapper fields (e.g., '_parent'). */
7295 static struct value *
7296 ada_search_struct_field (const char *name, struct value *arg, int offset,
7301 type = ada_check_typedef (type);
7302 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7304 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7306 if (t_field_name == NULL)
7309 else if (field_name_match (t_field_name, name))
7310 return ada_value_primitive_field (arg, offset, i, type);
7312 else if (ada_is_wrapper_field (type, i))
7314 struct value *v = /* Do not let indent join lines here. */
7315 ada_search_struct_field (name, arg,
7316 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7317 TYPE_FIELD_TYPE (type, i));
7323 else if (ada_is_variant_part (type, i))
7325 /* PNH: Do we ever get here? See find_struct_field. */
7327 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7329 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7331 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7333 struct value *v = ada_search_struct_field /* Force line
7336 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7337 TYPE_FIELD_TYPE (field_type, j));
7347 static struct value *ada_index_struct_field_1 (int *, struct value *,
7348 int, struct type *);
7351 /* Return field #INDEX in ARG, where the index is that returned by
7352 * find_struct_field through its INDEX_P argument. Adjust the address
7353 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7354 * If found, return value, else return NULL. */
7356 static struct value *
7357 ada_index_struct_field (int index, struct value *arg, int offset,
7360 return ada_index_struct_field_1 (&index, arg, offset, type);
7364 /* Auxiliary function for ada_index_struct_field. Like
7365 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7368 static struct value *
7369 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7373 type = ada_check_typedef (type);
7375 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7377 if (TYPE_FIELD_NAME (type, i) == NULL)
7379 else if (ada_is_wrapper_field (type, i))
7381 struct value *v = /* Do not let indent join lines here. */
7382 ada_index_struct_field_1 (index_p, arg,
7383 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7384 TYPE_FIELD_TYPE (type, i));
7390 else if (ada_is_variant_part (type, i))
7392 /* PNH: Do we ever get here? See ada_search_struct_field,
7393 find_struct_field. */
7394 error (_("Cannot assign this kind of variant record"));
7396 else if (*index_p == 0)
7397 return ada_value_primitive_field (arg, offset, i, type);
7404 /* Given ARG, a value of type (pointer or reference to a)*
7405 structure/union, extract the component named NAME from the ultimate
7406 target structure/union and return it as a value with its
7409 The routine searches for NAME among all members of the structure itself
7410 and (recursively) among all members of any wrapper members
7413 If NO_ERR, then simply return NULL in case of error, rather than
7417 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
7419 struct type *t, *t1;
7423 t1 = t = ada_check_typedef (value_type (arg));
7424 if (TYPE_CODE (t) == TYPE_CODE_REF)
7426 t1 = TYPE_TARGET_TYPE (t);
7429 t1 = ada_check_typedef (t1);
7430 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7432 arg = coerce_ref (arg);
7437 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7439 t1 = TYPE_TARGET_TYPE (t);
7442 t1 = ada_check_typedef (t1);
7443 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7445 arg = value_ind (arg);
7452 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
7456 v = ada_search_struct_field (name, arg, 0, t);
7459 int bit_offset, bit_size, byte_offset;
7460 struct type *field_type;
7463 if (TYPE_CODE (t) == TYPE_CODE_PTR)
7464 address = value_address (ada_value_ind (arg));
7466 address = value_address (ada_coerce_ref (arg));
7468 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
7469 if (find_struct_field (name, t1, 0,
7470 &field_type, &byte_offset, &bit_offset,
7475 if (TYPE_CODE (t) == TYPE_CODE_REF)
7476 arg = ada_coerce_ref (arg);
7478 arg = ada_value_ind (arg);
7479 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7480 bit_offset, bit_size,
7484 v = value_at_lazy (field_type, address + byte_offset);
7488 if (v != NULL || no_err)
7491 error (_("There is no member named %s."), name);
7497 error (_("Attempt to extract a component of "
7498 "a value that is not a record."));
7501 /* Return a string representation of type TYPE. */
7504 type_as_string (struct type *type)
7506 string_file tmp_stream;
7508 type_print (type, "", &tmp_stream, -1);
7510 return std::move (tmp_stream.string ());
7513 /* Given a type TYPE, look up the type of the component of type named NAME.
7514 If DISPP is non-null, add its byte displacement from the beginning of a
7515 structure (pointed to by a value) of type TYPE to *DISPP (does not
7516 work for packed fields).
7518 Matches any field whose name has NAME as a prefix, possibly
7521 TYPE can be either a struct or union. If REFOK, TYPE may also
7522 be a (pointer or reference)+ to a struct or union, and the
7523 ultimate target type will be searched.
7525 Looks recursively into variant clauses and parent types.
7527 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7528 TYPE is not a type of the right kind. */
7530 static struct type *
7531 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7539 if (refok && type != NULL)
7542 type = ada_check_typedef (type);
7543 if (TYPE_CODE (type) != TYPE_CODE_PTR
7544 && TYPE_CODE (type) != TYPE_CODE_REF)
7546 type = TYPE_TARGET_TYPE (type);
7550 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7551 && TYPE_CODE (type) != TYPE_CODE_UNION))
7556 error (_("Type %s is not a structure or union type"),
7557 type != NULL ? type_as_string (type).c_str () : _("(null)"));
7560 type = to_static_fixed_type (type);
7562 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7564 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7567 if (t_field_name == NULL)
7570 else if (field_name_match (t_field_name, name))
7571 return TYPE_FIELD_TYPE (type, i);
7573 else if (ada_is_wrapper_field (type, i))
7575 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7581 else if (ada_is_variant_part (type, i))
7584 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7587 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7589 /* FIXME pnh 2008/01/26: We check for a field that is
7590 NOT wrapped in a struct, since the compiler sometimes
7591 generates these for unchecked variant types. Revisit
7592 if the compiler changes this practice. */
7593 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
7595 if (v_field_name != NULL
7596 && field_name_match (v_field_name, name))
7597 t = TYPE_FIELD_TYPE (field_type, j);
7599 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7613 const char *name_str = name != NULL ? name : _("<null>");
7615 error (_("Type %s has no component named %s"),
7616 type_as_string (type).c_str (), name_str);
7622 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7623 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7624 represents an unchecked union (that is, the variant part of a
7625 record that is named in an Unchecked_Union pragma). */
7628 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7630 const char *discrim_name = ada_variant_discrim_name (var_type);
7632 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7636 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7637 within a value of type OUTER_TYPE that is stored in GDB at
7638 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7639 numbering from 0) is applicable. Returns -1 if none are. */
7642 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
7643 const gdb_byte *outer_valaddr)
7647 const char *discrim_name = ada_variant_discrim_name (var_type);
7648 struct value *outer;
7649 struct value *discrim;
7650 LONGEST discrim_val;
7652 /* Using plain value_from_contents_and_address here causes problems
7653 because we will end up trying to resolve a type that is currently
7654 being constructed. */
7655 outer = value_from_contents_and_address_unresolved (outer_type,
7657 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7658 if (discrim == NULL)
7660 discrim_val = value_as_long (discrim);
7663 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7665 if (ada_is_others_clause (var_type, i))
7667 else if (ada_in_variant (discrim_val, var_type, i))
7671 return others_clause;
7676 /* Dynamic-Sized Records */
7678 /* Strategy: The type ostensibly attached to a value with dynamic size
7679 (i.e., a size that is not statically recorded in the debugging
7680 data) does not accurately reflect the size or layout of the value.
7681 Our strategy is to convert these values to values with accurate,
7682 conventional types that are constructed on the fly. */
7684 /* There is a subtle and tricky problem here. In general, we cannot
7685 determine the size of dynamic records without its data. However,
7686 the 'struct value' data structure, which GDB uses to represent
7687 quantities in the inferior process (the target), requires the size
7688 of the type at the time of its allocation in order to reserve space
7689 for GDB's internal copy of the data. That's why the
7690 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7691 rather than struct value*s.
7693 However, GDB's internal history variables ($1, $2, etc.) are
7694 struct value*s containing internal copies of the data that are not, in
7695 general, the same as the data at their corresponding addresses in
7696 the target. Fortunately, the types we give to these values are all
7697 conventional, fixed-size types (as per the strategy described
7698 above), so that we don't usually have to perform the
7699 'to_fixed_xxx_type' conversions to look at their values.
7700 Unfortunately, there is one exception: if one of the internal
7701 history variables is an array whose elements are unconstrained
7702 records, then we will need to create distinct fixed types for each
7703 element selected. */
7705 /* The upshot of all of this is that many routines take a (type, host
7706 address, target address) triple as arguments to represent a value.
7707 The host address, if non-null, is supposed to contain an internal
7708 copy of the relevant data; otherwise, the program is to consult the
7709 target at the target address. */
7711 /* Assuming that VAL0 represents a pointer value, the result of
7712 dereferencing it. Differs from value_ind in its treatment of
7713 dynamic-sized types. */
7716 ada_value_ind (struct value *val0)
7718 struct value *val = value_ind (val0);
7720 if (ada_is_tagged_type (value_type (val), 0))
7721 val = ada_tag_value_at_base_address (val);
7723 return ada_to_fixed_value (val);
7726 /* The value resulting from dereferencing any "reference to"
7727 qualifiers on VAL0. */
7729 static struct value *
7730 ada_coerce_ref (struct value *val0)
7732 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
7734 struct value *val = val0;
7736 val = coerce_ref (val);
7738 if (ada_is_tagged_type (value_type (val), 0))
7739 val = ada_tag_value_at_base_address (val);
7741 return ada_to_fixed_value (val);
7747 /* Return OFF rounded upward if necessary to a multiple of
7748 ALIGNMENT (a power of 2). */
7751 align_value (unsigned int off, unsigned int alignment)
7753 return (off + alignment - 1) & ~(alignment - 1);
7756 /* Return the bit alignment required for field #F of template type TYPE. */
7759 field_alignment (struct type *type, int f)
7761 const char *name = TYPE_FIELD_NAME (type, f);
7765 /* The field name should never be null, unless the debugging information
7766 is somehow malformed. In this case, we assume the field does not
7767 require any alignment. */
7771 len = strlen (name);
7773 if (!isdigit (name[len - 1]))
7776 if (isdigit (name[len - 2]))
7777 align_offset = len - 2;
7779 align_offset = len - 1;
7781 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7782 return TARGET_CHAR_BIT;
7784 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7787 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7789 static struct symbol *
7790 ada_find_any_type_symbol (const char *name)
7794 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7795 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7798 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7802 /* Find a type named NAME. Ignores ambiguity. This routine will look
7803 solely for types defined by debug info, it will not search the GDB
7806 static struct type *
7807 ada_find_any_type (const char *name)
7809 struct symbol *sym = ada_find_any_type_symbol (name);
7812 return SYMBOL_TYPE (sym);
7817 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7818 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7819 symbol, in which case it is returned. Otherwise, this looks for
7820 symbols whose name is that of NAME_SYM suffixed with "___XR".
7821 Return symbol if found, and NULL otherwise. */
7824 ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
7826 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
7829 if (strstr (name, "___XR") != NULL)
7832 sym = find_old_style_renaming_symbol (name, block);
7837 /* Not right yet. FIXME pnh 7/20/2007. */
7838 sym = ada_find_any_type_symbol (name);
7839 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7845 static struct symbol *
7846 find_old_style_renaming_symbol (const char *name, const struct block *block)
7848 const struct symbol *function_sym = block_linkage_function (block);
7851 if (function_sym != NULL)
7853 /* If the symbol is defined inside a function, NAME is not fully
7854 qualified. This means we need to prepend the function name
7855 as well as adding the ``___XR'' suffix to build the name of
7856 the associated renaming symbol. */
7857 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
7858 /* Function names sometimes contain suffixes used
7859 for instance to qualify nested subprograms. When building
7860 the XR type name, we need to make sure that this suffix is
7861 not included. So do not include any suffix in the function
7862 name length below. */
7863 int function_name_len = ada_name_prefix_len (function_name);
7864 const int rename_len = function_name_len + 2 /* "__" */
7865 + strlen (name) + 6 /* "___XR\0" */ ;
7867 /* Strip the suffix if necessary. */
7868 ada_remove_trailing_digits (function_name, &function_name_len);
7869 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7870 ada_remove_Xbn_suffix (function_name, &function_name_len);
7872 /* Library-level functions are a special case, as GNAT adds
7873 a ``_ada_'' prefix to the function name to avoid namespace
7874 pollution. However, the renaming symbols themselves do not
7875 have this prefix, so we need to skip this prefix if present. */
7876 if (function_name_len > 5 /* "_ada_" */
7877 && strstr (function_name, "_ada_") == function_name)
7880 function_name_len -= 5;
7883 rename = (char *) alloca (rename_len * sizeof (char));
7884 strncpy (rename, function_name, function_name_len);
7885 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7890 const int rename_len = strlen (name) + 6;
7892 rename = (char *) alloca (rename_len * sizeof (char));
7893 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
7896 return ada_find_any_type_symbol (rename);
7899 /* Because of GNAT encoding conventions, several GDB symbols may match a
7900 given type name. If the type denoted by TYPE0 is to be preferred to
7901 that of TYPE1 for purposes of type printing, return non-zero;
7902 otherwise return 0. */
7905 ada_prefer_type (struct type *type0, struct type *type1)
7909 else if (type0 == NULL)
7911 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7913 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7915 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7917 else if (ada_is_constrained_packed_array_type (type0))
7919 else if (ada_is_array_descriptor_type (type0)
7920 && !ada_is_array_descriptor_type (type1))
7924 const char *type0_name = type_name_no_tag (type0);
7925 const char *type1_name = type_name_no_tag (type1);
7927 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7928 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7934 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
7935 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7938 ada_type_name (struct type *type)
7942 else if (TYPE_NAME (type) != NULL)
7943 return TYPE_NAME (type);
7945 return TYPE_TAG_NAME (type);
7948 /* Search the list of "descriptive" types associated to TYPE for a type
7949 whose name is NAME. */
7951 static struct type *
7952 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7954 struct type *result, *tmp;
7956 if (ada_ignore_descriptive_types_p)
7959 /* If there no descriptive-type info, then there is no parallel type
7961 if (!HAVE_GNAT_AUX_INFO (type))
7964 result = TYPE_DESCRIPTIVE_TYPE (type);
7965 while (result != NULL)
7967 const char *result_name = ada_type_name (result);
7969 if (result_name == NULL)
7971 warning (_("unexpected null name on descriptive type"));
7975 /* If the names match, stop. */
7976 if (strcmp (result_name, name) == 0)
7979 /* Otherwise, look at the next item on the list, if any. */
7980 if (HAVE_GNAT_AUX_INFO (result))
7981 tmp = TYPE_DESCRIPTIVE_TYPE (result);
7985 /* If not found either, try after having resolved the typedef. */
7990 result = check_typedef (result);
7991 if (HAVE_GNAT_AUX_INFO (result))
7992 result = TYPE_DESCRIPTIVE_TYPE (result);
7998 /* If we didn't find a match, see whether this is a packed array. With
7999 older compilers, the descriptive type information is either absent or
8000 irrelevant when it comes to packed arrays so the above lookup fails.
8001 Fall back to using a parallel lookup by name in this case. */
8002 if (result == NULL && ada_is_constrained_packed_array_type (type))
8003 return ada_find_any_type (name);
8008 /* Find a parallel type to TYPE with the specified NAME, using the
8009 descriptive type taken from the debugging information, if available,
8010 and otherwise using the (slower) name-based method. */
8012 static struct type *
8013 ada_find_parallel_type_with_name (struct type *type, const char *name)
8015 struct type *result = NULL;
8017 if (HAVE_GNAT_AUX_INFO (type))
8018 result = find_parallel_type_by_descriptive_type (type, name);
8020 result = ada_find_any_type (name);
8025 /* Same as above, but specify the name of the parallel type by appending
8026 SUFFIX to the name of TYPE. */
8029 ada_find_parallel_type (struct type *type, const char *suffix)
8032 const char *type_name = ada_type_name (type);
8035 if (type_name == NULL)
8038 len = strlen (type_name);
8040 name = (char *) alloca (len + strlen (suffix) + 1);
8042 strcpy (name, type_name);
8043 strcpy (name + len, suffix);
8045 return ada_find_parallel_type_with_name (type, name);
8048 /* If TYPE is a variable-size record type, return the corresponding template
8049 type describing its fields. Otherwise, return NULL. */
8051 static struct type *
8052 dynamic_template_type (struct type *type)
8054 type = ada_check_typedef (type);
8056 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
8057 || ada_type_name (type) == NULL)
8061 int len = strlen (ada_type_name (type));
8063 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8066 return ada_find_parallel_type (type, "___XVE");
8070 /* Assuming that TEMPL_TYPE is a union or struct type, returns
8071 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
8074 is_dynamic_field (struct type *templ_type, int field_num)
8076 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
8079 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8080 && strstr (name, "___XVL") != NULL;
8083 /* The index of the variant field of TYPE, or -1 if TYPE does not
8084 represent a variant record type. */
8087 variant_field_index (struct type *type)
8091 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8094 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8096 if (ada_is_variant_part (type, f))
8102 /* A record type with no fields. */
8104 static struct type *
8105 empty_record (struct type *templ)
8107 struct type *type = alloc_type_copy (templ);
8109 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8110 TYPE_NFIELDS (type) = 0;
8111 TYPE_FIELDS (type) = NULL;
8112 INIT_CPLUS_SPECIFIC (type);
8113 TYPE_NAME (type) = "<empty>";
8114 TYPE_TAG_NAME (type) = NULL;
8115 TYPE_LENGTH (type) = 0;
8119 /* An ordinary record type (with fixed-length fields) that describes
8120 the value of type TYPE at VALADDR or ADDRESS (see comments at
8121 the beginning of this section) VAL according to GNAT conventions.
8122 DVAL0 should describe the (portion of a) record that contains any
8123 necessary discriminants. It should be NULL if value_type (VAL) is
8124 an outer-level type (i.e., as opposed to a branch of a variant.) A
8125 variant field (unless unchecked) is replaced by a particular branch
8128 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8129 length are not statically known are discarded. As a consequence,
8130 VALADDR, ADDRESS and DVAL0 are ignored.
8132 NOTE: Limitations: For now, we assume that dynamic fields and
8133 variants occupy whole numbers of bytes. However, they need not be
8137 ada_template_to_fixed_record_type_1 (struct type *type,
8138 const gdb_byte *valaddr,
8139 CORE_ADDR address, struct value *dval0,
8140 int keep_dynamic_fields)
8142 struct value *mark = value_mark ();
8145 int nfields, bit_len;
8151 /* Compute the number of fields in this record type that are going
8152 to be processed: unless keep_dynamic_fields, this includes only
8153 fields whose position and length are static will be processed. */
8154 if (keep_dynamic_fields)
8155 nfields = TYPE_NFIELDS (type);
8159 while (nfields < TYPE_NFIELDS (type)
8160 && !ada_is_variant_part (type, nfields)
8161 && !is_dynamic_field (type, nfields))
8165 rtype = alloc_type_copy (type);
8166 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8167 INIT_CPLUS_SPECIFIC (rtype);
8168 TYPE_NFIELDS (rtype) = nfields;
8169 TYPE_FIELDS (rtype) = (struct field *)
8170 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8171 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8172 TYPE_NAME (rtype) = ada_type_name (type);
8173 TYPE_TAG_NAME (rtype) = NULL;
8174 TYPE_FIXED_INSTANCE (rtype) = 1;
8180 for (f = 0; f < nfields; f += 1)
8182 off = align_value (off, field_alignment (type, f))
8183 + TYPE_FIELD_BITPOS (type, f);
8184 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
8185 TYPE_FIELD_BITSIZE (rtype, f) = 0;
8187 if (ada_is_variant_part (type, f))
8192 else if (is_dynamic_field (type, f))
8194 const gdb_byte *field_valaddr = valaddr;
8195 CORE_ADDR field_address = address;
8196 struct type *field_type =
8197 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8201 /* rtype's length is computed based on the run-time
8202 value of discriminants. If the discriminants are not
8203 initialized, the type size may be completely bogus and
8204 GDB may fail to allocate a value for it. So check the
8205 size first before creating the value. */
8206 ada_ensure_varsize_limit (rtype);
8207 /* Using plain value_from_contents_and_address here
8208 causes problems because we will end up trying to
8209 resolve a type that is currently being
8211 dval = value_from_contents_and_address_unresolved (rtype,
8214 rtype = value_type (dval);
8219 /* If the type referenced by this field is an aligner type, we need
8220 to unwrap that aligner type, because its size might not be set.
8221 Keeping the aligner type would cause us to compute the wrong
8222 size for this field, impacting the offset of the all the fields
8223 that follow this one. */
8224 if (ada_is_aligner_type (field_type))
8226 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8228 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8229 field_address = cond_offset_target (field_address, field_offset);
8230 field_type = ada_aligned_type (field_type);
8233 field_valaddr = cond_offset_host (field_valaddr,
8234 off / TARGET_CHAR_BIT);
8235 field_address = cond_offset_target (field_address,
8236 off / TARGET_CHAR_BIT);
8238 /* Get the fixed type of the field. Note that, in this case,
8239 we do not want to get the real type out of the tag: if
8240 the current field is the parent part of a tagged record,
8241 we will get the tag of the object. Clearly wrong: the real
8242 type of the parent is not the real type of the child. We
8243 would end up in an infinite loop. */
8244 field_type = ada_get_base_type (field_type);
8245 field_type = ada_to_fixed_type (field_type, field_valaddr,
8246 field_address, dval, 0);
8247 /* If the field size is already larger than the maximum
8248 object size, then the record itself will necessarily
8249 be larger than the maximum object size. We need to make
8250 this check now, because the size might be so ridiculously
8251 large (due to an uninitialized variable in the inferior)
8252 that it would cause an overflow when adding it to the
8254 ada_ensure_varsize_limit (field_type);
8256 TYPE_FIELD_TYPE (rtype, f) = field_type;
8257 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8258 /* The multiplication can potentially overflow. But because
8259 the field length has been size-checked just above, and
8260 assuming that the maximum size is a reasonable value,
8261 an overflow should not happen in practice. So rather than
8262 adding overflow recovery code to this already complex code,
8263 we just assume that it's not going to happen. */
8265 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8269 /* Note: If this field's type is a typedef, it is important
8270 to preserve the typedef layer.
8272 Otherwise, we might be transforming a typedef to a fat
8273 pointer (encoding a pointer to an unconstrained array),
8274 into a basic fat pointer (encoding an unconstrained
8275 array). As both types are implemented using the same
8276 structure, the typedef is the only clue which allows us
8277 to distinguish between the two options. Stripping it
8278 would prevent us from printing this field appropriately. */
8279 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
8280 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8281 if (TYPE_FIELD_BITSIZE (type, f) > 0)
8283 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8286 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8288 /* We need to be careful of typedefs when computing
8289 the length of our field. If this is a typedef,
8290 get the length of the target type, not the length
8292 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8293 field_type = ada_typedef_target_type (field_type);
8296 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8299 if (off + fld_bit_len > bit_len)
8300 bit_len = off + fld_bit_len;
8302 TYPE_LENGTH (rtype) =
8303 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8306 /* We handle the variant part, if any, at the end because of certain
8307 odd cases in which it is re-ordered so as NOT to be the last field of
8308 the record. This can happen in the presence of representation
8310 if (variant_field >= 0)
8312 struct type *branch_type;
8314 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8318 /* Using plain value_from_contents_and_address here causes
8319 problems because we will end up trying to resolve a type
8320 that is currently being constructed. */
8321 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8323 rtype = value_type (dval);
8329 to_fixed_variant_branch_type
8330 (TYPE_FIELD_TYPE (type, variant_field),
8331 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8332 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8333 if (branch_type == NULL)
8335 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8336 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8337 TYPE_NFIELDS (rtype) -= 1;
8341 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8342 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8344 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8346 if (off + fld_bit_len > bit_len)
8347 bit_len = off + fld_bit_len;
8348 TYPE_LENGTH (rtype) =
8349 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8353 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8354 should contain the alignment of that record, which should be a strictly
8355 positive value. If null or negative, then something is wrong, most
8356 probably in the debug info. In that case, we don't round up the size
8357 of the resulting type. If this record is not part of another structure,
8358 the current RTYPE length might be good enough for our purposes. */
8359 if (TYPE_LENGTH (type) <= 0)
8361 if (TYPE_NAME (rtype))
8362 warning (_("Invalid type size for `%s' detected: %d."),
8363 TYPE_NAME (rtype), TYPE_LENGTH (type));
8365 warning (_("Invalid type size for <unnamed> detected: %d."),
8366 TYPE_LENGTH (type));
8370 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8371 TYPE_LENGTH (type));
8374 value_free_to_mark (mark);
8375 if (TYPE_LENGTH (rtype) > varsize_limit)
8376 error (_("record type with dynamic size is larger than varsize-limit"));
8380 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8383 static struct type *
8384 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8385 CORE_ADDR address, struct value *dval0)
8387 return ada_template_to_fixed_record_type_1 (type, valaddr,
8391 /* An ordinary record type in which ___XVL-convention fields and
8392 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8393 static approximations, containing all possible fields. Uses
8394 no runtime values. Useless for use in values, but that's OK,
8395 since the results are used only for type determinations. Works on both
8396 structs and unions. Representation note: to save space, we memorize
8397 the result of this function in the TYPE_TARGET_TYPE of the
8400 static struct type *
8401 template_to_static_fixed_type (struct type *type0)
8407 /* No need no do anything if the input type is already fixed. */
8408 if (TYPE_FIXED_INSTANCE (type0))
8411 /* Likewise if we already have computed the static approximation. */
8412 if (TYPE_TARGET_TYPE (type0) != NULL)
8413 return TYPE_TARGET_TYPE (type0);
8415 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8417 nfields = TYPE_NFIELDS (type0);
8419 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8420 recompute all over next time. */
8421 TYPE_TARGET_TYPE (type0) = type;
8423 for (f = 0; f < nfields; f += 1)
8425 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
8426 struct type *new_type;
8428 if (is_dynamic_field (type0, f))
8430 field_type = ada_check_typedef (field_type);
8431 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8434 new_type = static_unwrap_type (field_type);
8436 if (new_type != field_type)
8438 /* Clone TYPE0 only the first time we get a new field type. */
8441 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8442 TYPE_CODE (type) = TYPE_CODE (type0);
8443 INIT_CPLUS_SPECIFIC (type);
8444 TYPE_NFIELDS (type) = nfields;
8445 TYPE_FIELDS (type) = (struct field *)
8446 TYPE_ALLOC (type, nfields * sizeof (struct field));
8447 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8448 sizeof (struct field) * nfields);
8449 TYPE_NAME (type) = ada_type_name (type0);
8450 TYPE_TAG_NAME (type) = NULL;
8451 TYPE_FIXED_INSTANCE (type) = 1;
8452 TYPE_LENGTH (type) = 0;
8454 TYPE_FIELD_TYPE (type, f) = new_type;
8455 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8462 /* Given an object of type TYPE whose contents are at VALADDR and
8463 whose address in memory is ADDRESS, returns a revision of TYPE,
8464 which should be a non-dynamic-sized record, in which the variant
8465 part, if any, is replaced with the appropriate branch. Looks
8466 for discriminant values in DVAL0, which can be NULL if the record
8467 contains the necessary discriminant values. */
8469 static struct type *
8470 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8471 CORE_ADDR address, struct value *dval0)
8473 struct value *mark = value_mark ();
8476 struct type *branch_type;
8477 int nfields = TYPE_NFIELDS (type);
8478 int variant_field = variant_field_index (type);
8480 if (variant_field == -1)
8485 dval = value_from_contents_and_address (type, valaddr, address);
8486 type = value_type (dval);
8491 rtype = alloc_type_copy (type);
8492 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8493 INIT_CPLUS_SPECIFIC (rtype);
8494 TYPE_NFIELDS (rtype) = nfields;
8495 TYPE_FIELDS (rtype) =
8496 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8497 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
8498 sizeof (struct field) * nfields);
8499 TYPE_NAME (rtype) = ada_type_name (type);
8500 TYPE_TAG_NAME (rtype) = NULL;
8501 TYPE_FIXED_INSTANCE (rtype) = 1;
8502 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8504 branch_type = to_fixed_variant_branch_type
8505 (TYPE_FIELD_TYPE (type, variant_field),
8506 cond_offset_host (valaddr,
8507 TYPE_FIELD_BITPOS (type, variant_field)
8509 cond_offset_target (address,
8510 TYPE_FIELD_BITPOS (type, variant_field)
8511 / TARGET_CHAR_BIT), dval);
8512 if (branch_type == NULL)
8516 for (f = variant_field + 1; f < nfields; f += 1)
8517 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8518 TYPE_NFIELDS (rtype) -= 1;
8522 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8523 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8524 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8525 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8527 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
8529 value_free_to_mark (mark);
8533 /* An ordinary record type (with fixed-length fields) that describes
8534 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8535 beginning of this section]. Any necessary discriminants' values
8536 should be in DVAL, a record value; it may be NULL if the object
8537 at ADDR itself contains any necessary discriminant values.
8538 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8539 values from the record are needed. Except in the case that DVAL,
8540 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8541 unchecked) is replaced by a particular branch of the variant.
8543 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8544 is questionable and may be removed. It can arise during the
8545 processing of an unconstrained-array-of-record type where all the
8546 variant branches have exactly the same size. This is because in
8547 such cases, the compiler does not bother to use the XVS convention
8548 when encoding the record. I am currently dubious of this
8549 shortcut and suspect the compiler should be altered. FIXME. */
8551 static struct type *
8552 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8553 CORE_ADDR address, struct value *dval)
8555 struct type *templ_type;
8557 if (TYPE_FIXED_INSTANCE (type0))
8560 templ_type = dynamic_template_type (type0);
8562 if (templ_type != NULL)
8563 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8564 else if (variant_field_index (type0) >= 0)
8566 if (dval == NULL && valaddr == NULL && address == 0)
8568 return to_record_with_fixed_variant_part (type0, valaddr, address,
8573 TYPE_FIXED_INSTANCE (type0) = 1;
8579 /* An ordinary record type (with fixed-length fields) that describes
8580 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8581 union type. Any necessary discriminants' values should be in DVAL,
8582 a record value. That is, this routine selects the appropriate
8583 branch of the union at ADDR according to the discriminant value
8584 indicated in the union's type name. Returns VAR_TYPE0 itself if
8585 it represents a variant subject to a pragma Unchecked_Union. */
8587 static struct type *
8588 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8589 CORE_ADDR address, struct value *dval)
8592 struct type *templ_type;
8593 struct type *var_type;
8595 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8596 var_type = TYPE_TARGET_TYPE (var_type0);
8598 var_type = var_type0;
8600 templ_type = ada_find_parallel_type (var_type, "___XVU");
8602 if (templ_type != NULL)
8603 var_type = templ_type;
8605 if (is_unchecked_variant (var_type, value_type (dval)))
8608 ada_which_variant_applies (var_type,
8609 value_type (dval), value_contents (dval));
8612 return empty_record (var_type);
8613 else if (is_dynamic_field (var_type, which))
8614 return to_fixed_record_type
8615 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8616 valaddr, address, dval);
8617 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
8619 to_fixed_record_type
8620 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
8622 return TYPE_FIELD_TYPE (var_type, which);
8625 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8626 ENCODING_TYPE, a type following the GNAT conventions for discrete
8627 type encodings, only carries redundant information. */
8630 ada_is_redundant_range_encoding (struct type *range_type,
8631 struct type *encoding_type)
8633 struct type *fixed_range_type;
8634 const char *bounds_str;
8638 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8640 if (TYPE_CODE (get_base_type (range_type))
8641 != TYPE_CODE (get_base_type (encoding_type)))
8643 /* The compiler probably used a simple base type to describe
8644 the range type instead of the range's actual base type,
8645 expecting us to get the real base type from the encoding
8646 anyway. In this situation, the encoding cannot be ignored
8651 if (is_dynamic_type (range_type))
8654 if (TYPE_NAME (encoding_type) == NULL)
8657 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8658 if (bounds_str == NULL)
8661 n = 8; /* Skip "___XDLU_". */
8662 if (!ada_scan_number (bounds_str, n, &lo, &n))
8664 if (TYPE_LOW_BOUND (range_type) != lo)
8667 n += 2; /* Skip the "__" separator between the two bounds. */
8668 if (!ada_scan_number (bounds_str, n, &hi, &n))
8670 if (TYPE_HIGH_BOUND (range_type) != hi)
8676 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8677 a type following the GNAT encoding for describing array type
8678 indices, only carries redundant information. */
8681 ada_is_redundant_index_type_desc (struct type *array_type,
8682 struct type *desc_type)
8684 struct type *this_layer = check_typedef (array_type);
8687 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8689 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8690 TYPE_FIELD_TYPE (desc_type, i)))
8692 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8698 /* Assuming that TYPE0 is an array type describing the type of a value
8699 at ADDR, and that DVAL describes a record containing any
8700 discriminants used in TYPE0, returns a type for the value that
8701 contains no dynamic components (that is, no components whose sizes
8702 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8703 true, gives an error message if the resulting type's size is over
8706 static struct type *
8707 to_fixed_array_type (struct type *type0, struct value *dval,
8710 struct type *index_type_desc;
8711 struct type *result;
8712 int constrained_packed_array_p;
8713 static const char *xa_suffix = "___XA";
8715 type0 = ada_check_typedef (type0);
8716 if (TYPE_FIXED_INSTANCE (type0))
8719 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8720 if (constrained_packed_array_p)
8721 type0 = decode_constrained_packed_array_type (type0);
8723 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8725 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8726 encoding suffixed with 'P' may still be generated. If so,
8727 it should be used to find the XA type. */
8729 if (index_type_desc == NULL)
8731 const char *type_name = ada_type_name (type0);
8733 if (type_name != NULL)
8735 const int len = strlen (type_name);
8736 char *name = (char *) alloca (len + strlen (xa_suffix));
8738 if (type_name[len - 1] == 'P')
8740 strcpy (name, type_name);
8741 strcpy (name + len - 1, xa_suffix);
8742 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8747 ada_fixup_array_indexes_type (index_type_desc);
8748 if (index_type_desc != NULL
8749 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8751 /* Ignore this ___XA parallel type, as it does not bring any
8752 useful information. This allows us to avoid creating fixed
8753 versions of the array's index types, which would be identical
8754 to the original ones. This, in turn, can also help avoid
8755 the creation of fixed versions of the array itself. */
8756 index_type_desc = NULL;
8759 if (index_type_desc == NULL)
8761 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8763 /* NOTE: elt_type---the fixed version of elt_type0---should never
8764 depend on the contents of the array in properly constructed
8766 /* Create a fixed version of the array element type.
8767 We're not providing the address of an element here,
8768 and thus the actual object value cannot be inspected to do
8769 the conversion. This should not be a problem, since arrays of
8770 unconstrained objects are not allowed. In particular, all
8771 the elements of an array of a tagged type should all be of
8772 the same type specified in the debugging info. No need to
8773 consult the object tag. */
8774 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8776 /* Make sure we always create a new array type when dealing with
8777 packed array types, since we're going to fix-up the array
8778 type length and element bitsize a little further down. */
8779 if (elt_type0 == elt_type && !constrained_packed_array_p)
8782 result = create_array_type (alloc_type_copy (type0),
8783 elt_type, TYPE_INDEX_TYPE (type0));
8788 struct type *elt_type0;
8791 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
8792 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8794 /* NOTE: result---the fixed version of elt_type0---should never
8795 depend on the contents of the array in properly constructed
8797 /* Create a fixed version of the array element type.
8798 We're not providing the address of an element here,
8799 and thus the actual object value cannot be inspected to do
8800 the conversion. This should not be a problem, since arrays of
8801 unconstrained objects are not allowed. In particular, all
8802 the elements of an array of a tagged type should all be of
8803 the same type specified in the debugging info. No need to
8804 consult the object tag. */
8806 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8809 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
8811 struct type *range_type =
8812 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
8814 result = create_array_type (alloc_type_copy (elt_type0),
8815 result, range_type);
8816 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8818 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
8819 error (_("array type with dynamic size is larger than varsize-limit"));
8822 /* We want to preserve the type name. This can be useful when
8823 trying to get the type name of a value that has already been
8824 printed (for instance, if the user did "print VAR; whatis $". */
8825 TYPE_NAME (result) = TYPE_NAME (type0);
8827 if (constrained_packed_array_p)
8829 /* So far, the resulting type has been created as if the original
8830 type was a regular (non-packed) array type. As a result, the
8831 bitsize of the array elements needs to be set again, and the array
8832 length needs to be recomputed based on that bitsize. */
8833 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8834 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8836 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8837 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8838 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8839 TYPE_LENGTH (result)++;
8842 TYPE_FIXED_INSTANCE (result) = 1;
8847 /* A standard type (containing no dynamically sized components)
8848 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8849 DVAL describes a record containing any discriminants used in TYPE0,
8850 and may be NULL if there are none, or if the object of type TYPE at
8851 ADDRESS or in VALADDR contains these discriminants.
8853 If CHECK_TAG is not null, in the case of tagged types, this function
8854 attempts to locate the object's tag and use it to compute the actual
8855 type. However, when ADDRESS is null, we cannot use it to determine the
8856 location of the tag, and therefore compute the tagged type's actual type.
8857 So we return the tagged type without consulting the tag. */
8859 static struct type *
8860 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8861 CORE_ADDR address, struct value *dval, int check_tag)
8863 type = ada_check_typedef (type);
8864 switch (TYPE_CODE (type))
8868 case TYPE_CODE_STRUCT:
8870 struct type *static_type = to_static_fixed_type (type);
8871 struct type *fixed_record_type =
8872 to_fixed_record_type (type, valaddr, address, NULL);
8874 /* If STATIC_TYPE is a tagged type and we know the object's address,
8875 then we can determine its tag, and compute the object's actual
8876 type from there. Note that we have to use the fixed record
8877 type (the parent part of the record may have dynamic fields
8878 and the way the location of _tag is expressed may depend on
8881 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8884 value_tag_from_contents_and_address
8888 struct type *real_type = type_from_tag (tag);
8890 value_from_contents_and_address (fixed_record_type,
8893 fixed_record_type = value_type (obj);
8894 if (real_type != NULL)
8895 return to_fixed_record_type
8897 value_address (ada_tag_value_at_base_address (obj)), NULL);
8900 /* Check to see if there is a parallel ___XVZ variable.
8901 If there is, then it provides the actual size of our type. */
8902 else if (ada_type_name (fixed_record_type) != NULL)
8904 const char *name = ada_type_name (fixed_record_type);
8906 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
8909 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8910 if (get_int_var_value (xvz_name, size)
8911 && TYPE_LENGTH (fixed_record_type) != size)
8913 fixed_record_type = copy_type (fixed_record_type);
8914 TYPE_LENGTH (fixed_record_type) = size;
8916 /* The FIXED_RECORD_TYPE may have be a stub. We have
8917 observed this when the debugging info is STABS, and
8918 apparently it is something that is hard to fix.
8920 In practice, we don't need the actual type definition
8921 at all, because the presence of the XVZ variable allows us
8922 to assume that there must be a XVS type as well, which we
8923 should be able to use later, when we need the actual type
8926 In the meantime, pretend that the "fixed" type we are
8927 returning is NOT a stub, because this can cause trouble
8928 when using this type to create new types targeting it.
8929 Indeed, the associated creation routines often check
8930 whether the target type is a stub and will try to replace
8931 it, thus using a type with the wrong size. This, in turn,
8932 might cause the new type to have the wrong size too.
8933 Consider the case of an array, for instance, where the size
8934 of the array is computed from the number of elements in
8935 our array multiplied by the size of its element. */
8936 TYPE_STUB (fixed_record_type) = 0;
8939 return fixed_record_type;
8941 case TYPE_CODE_ARRAY:
8942 return to_fixed_array_type (type, dval, 1);
8943 case TYPE_CODE_UNION:
8947 return to_fixed_variant_branch_type (type, valaddr, address, dval);
8951 /* The same as ada_to_fixed_type_1, except that it preserves the type
8952 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8954 The typedef layer needs be preserved in order to differentiate between
8955 arrays and array pointers when both types are implemented using the same
8956 fat pointer. In the array pointer case, the pointer is encoded as
8957 a typedef of the pointer type. For instance, considering:
8959 type String_Access is access String;
8960 S1 : String_Access := null;
8962 To the debugger, S1 is defined as a typedef of type String. But
8963 to the user, it is a pointer. So if the user tries to print S1,
8964 we should not dereference the array, but print the array address
8967 If we didn't preserve the typedef layer, we would lose the fact that
8968 the type is to be presented as a pointer (needs de-reference before
8969 being printed). And we would also use the source-level type name. */
8972 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8973 CORE_ADDR address, struct value *dval, int check_tag)
8976 struct type *fixed_type =
8977 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8979 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8980 then preserve the typedef layer.
8982 Implementation note: We can only check the main-type portion of
8983 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8984 from TYPE now returns a type that has the same instance flags
8985 as TYPE. For instance, if TYPE is a "typedef const", and its
8986 target type is a "struct", then the typedef elimination will return
8987 a "const" version of the target type. See check_typedef for more
8988 details about how the typedef layer elimination is done.
8990 brobecker/2010-11-19: It seems to me that the only case where it is
8991 useful to preserve the typedef layer is when dealing with fat pointers.
8992 Perhaps, we could add a check for that and preserve the typedef layer
8993 only in that situation. But this seems unecessary so far, probably
8994 because we call check_typedef/ada_check_typedef pretty much everywhere.
8996 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8997 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8998 == TYPE_MAIN_TYPE (fixed_type)))
9004 /* A standard (static-sized) type corresponding as well as possible to
9005 TYPE0, but based on no runtime data. */
9007 static struct type *
9008 to_static_fixed_type (struct type *type0)
9015 if (TYPE_FIXED_INSTANCE (type0))
9018 type0 = ada_check_typedef (type0);
9020 switch (TYPE_CODE (type0))
9024 case TYPE_CODE_STRUCT:
9025 type = dynamic_template_type (type0);
9027 return template_to_static_fixed_type (type);
9029 return template_to_static_fixed_type (type0);
9030 case TYPE_CODE_UNION:
9031 type = ada_find_parallel_type (type0, "___XVU");
9033 return template_to_static_fixed_type (type);
9035 return template_to_static_fixed_type (type0);
9039 /* A static approximation of TYPE with all type wrappers removed. */
9041 static struct type *
9042 static_unwrap_type (struct type *type)
9044 if (ada_is_aligner_type (type))
9046 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
9047 if (ada_type_name (type1) == NULL)
9048 TYPE_NAME (type1) = ada_type_name (type);
9050 return static_unwrap_type (type1);
9054 struct type *raw_real_type = ada_get_base_type (type);
9056 if (raw_real_type == type)
9059 return to_static_fixed_type (raw_real_type);
9063 /* In some cases, incomplete and private types require
9064 cross-references that are not resolved as records (for example,
9066 type FooP is access Foo;
9068 type Foo is array ...;
9069 ). In these cases, since there is no mechanism for producing
9070 cross-references to such types, we instead substitute for FooP a
9071 stub enumeration type that is nowhere resolved, and whose tag is
9072 the name of the actual type. Call these types "non-record stubs". */
9074 /* A type equivalent to TYPE that is not a non-record stub, if one
9075 exists, otherwise TYPE. */
9078 ada_check_typedef (struct type *type)
9083 /* If our type is a typedef type of a fat pointer, then we're done.
9084 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9085 what allows us to distinguish between fat pointers that represent
9086 array types, and fat pointers that represent array access types
9087 (in both cases, the compiler implements them as fat pointers). */
9088 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9089 && is_thick_pntr (ada_typedef_target_type (type)))
9092 type = check_typedef (type);
9093 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
9094 || !TYPE_STUB (type)
9095 || TYPE_TAG_NAME (type) == NULL)
9099 const char *name = TYPE_TAG_NAME (type);
9100 struct type *type1 = ada_find_any_type (name);
9105 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9106 stubs pointing to arrays, as we don't create symbols for array
9107 types, only for the typedef-to-array types). If that's the case,
9108 strip the typedef layer. */
9109 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9110 type1 = ada_check_typedef (type1);
9116 /* A value representing the data at VALADDR/ADDRESS as described by
9117 type TYPE0, but with a standard (static-sized) type that correctly
9118 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9119 type, then return VAL0 [this feature is simply to avoid redundant
9120 creation of struct values]. */
9122 static struct value *
9123 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9126 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
9128 if (type == type0 && val0 != NULL)
9131 return value_from_contents_and_address (type, 0, address);
9134 /* A value representing VAL, but with a standard (static-sized) type
9135 that correctly describes it. Does not necessarily create a new
9139 ada_to_fixed_value (struct value *val)
9141 val = unwrap_value (val);
9142 val = ada_to_fixed_value_create (value_type (val),
9143 value_address (val),
9151 /* Table mapping attribute numbers to names.
9152 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
9154 static const char *attribute_names[] = {
9172 ada_attribute_name (enum exp_opcode n)
9174 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9175 return attribute_names[n - OP_ATR_FIRST + 1];
9177 return attribute_names[0];
9180 /* Evaluate the 'POS attribute applied to ARG. */
9183 pos_atr (struct value *arg)
9185 struct value *val = coerce_ref (arg);
9186 struct type *type = value_type (val);
9189 if (!discrete_type_p (type))
9190 error (_("'POS only defined on discrete types"));
9192 if (!discrete_position (type, value_as_long (val), &result))
9193 error (_("enumeration value is invalid: can't find 'POS"));
9198 static struct value *
9199 value_pos_atr (struct type *type, struct value *arg)
9201 return value_from_longest (type, pos_atr (arg));
9204 /* Evaluate the TYPE'VAL attribute applied to ARG. */
9206 static struct value *
9207 value_val_atr (struct type *type, struct value *arg)
9209 if (!discrete_type_p (type))
9210 error (_("'VAL only defined on discrete types"));
9211 if (!integer_type_p (value_type (arg)))
9212 error (_("'VAL requires integral argument"));
9214 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9216 long pos = value_as_long (arg);
9218 if (pos < 0 || pos >= TYPE_NFIELDS (type))
9219 error (_("argument to 'VAL out of range"));
9220 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
9223 return value_from_longest (type, value_as_long (arg));
9229 /* True if TYPE appears to be an Ada character type.
9230 [At the moment, this is true only for Character and Wide_Character;
9231 It is a heuristic test that could stand improvement]. */
9234 ada_is_character_type (struct type *type)
9238 /* If the type code says it's a character, then assume it really is,
9239 and don't check any further. */
9240 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9243 /* Otherwise, assume it's a character type iff it is a discrete type
9244 with a known character type name. */
9245 name = ada_type_name (type);
9246 return (name != NULL
9247 && (TYPE_CODE (type) == TYPE_CODE_INT
9248 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9249 && (strcmp (name, "character") == 0
9250 || strcmp (name, "wide_character") == 0
9251 || strcmp (name, "wide_wide_character") == 0
9252 || strcmp (name, "unsigned char") == 0));
9255 /* True if TYPE appears to be an Ada string type. */
9258 ada_is_string_type (struct type *type)
9260 type = ada_check_typedef (type);
9262 && TYPE_CODE (type) != TYPE_CODE_PTR
9263 && (ada_is_simple_array_type (type)
9264 || ada_is_array_descriptor_type (type))
9265 && ada_array_arity (type) == 1)
9267 struct type *elttype = ada_array_element_type (type, 1);
9269 return ada_is_character_type (elttype);
9275 /* The compiler sometimes provides a parallel XVS type for a given
9276 PAD type. Normally, it is safe to follow the PAD type directly,
9277 but older versions of the compiler have a bug that causes the offset
9278 of its "F" field to be wrong. Following that field in that case
9279 would lead to incorrect results, but this can be worked around
9280 by ignoring the PAD type and using the associated XVS type instead.
9282 Set to True if the debugger should trust the contents of PAD types.
9283 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9284 static int trust_pad_over_xvs = 1;
9286 /* True if TYPE is a struct type introduced by the compiler to force the
9287 alignment of a value. Such types have a single field with a
9288 distinctive name. */
9291 ada_is_aligner_type (struct type *type)
9293 type = ada_check_typedef (type);
9295 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9298 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
9299 && TYPE_NFIELDS (type) == 1
9300 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
9303 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9304 the parallel type. */
9307 ada_get_base_type (struct type *raw_type)
9309 struct type *real_type_namer;
9310 struct type *raw_real_type;
9312 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9315 if (ada_is_aligner_type (raw_type))
9316 /* The encoding specifies that we should always use the aligner type.
9317 So, even if this aligner type has an associated XVS type, we should
9320 According to the compiler gurus, an XVS type parallel to an aligner
9321 type may exist because of a stabs limitation. In stabs, aligner
9322 types are empty because the field has a variable-sized type, and
9323 thus cannot actually be used as an aligner type. As a result,
9324 we need the associated parallel XVS type to decode the type.
9325 Since the policy in the compiler is to not change the internal
9326 representation based on the debugging info format, we sometimes
9327 end up having a redundant XVS type parallel to the aligner type. */
9330 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9331 if (real_type_namer == NULL
9332 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9333 || TYPE_NFIELDS (real_type_namer) != 1)
9336 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9338 /* This is an older encoding form where the base type needs to be
9339 looked up by name. We prefer the newer enconding because it is
9341 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9342 if (raw_real_type == NULL)
9345 return raw_real_type;
9348 /* The field in our XVS type is a reference to the base type. */
9349 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
9352 /* The type of value designated by TYPE, with all aligners removed. */
9355 ada_aligned_type (struct type *type)
9357 if (ada_is_aligner_type (type))
9358 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9360 return ada_get_base_type (type);
9364 /* The address of the aligned value in an object at address VALADDR
9365 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9368 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9370 if (ada_is_aligner_type (type))
9371 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
9373 TYPE_FIELD_BITPOS (type,
9374 0) / TARGET_CHAR_BIT);
9381 /* The printed representation of an enumeration literal with encoded
9382 name NAME. The value is good to the next call of ada_enum_name. */
9384 ada_enum_name (const char *name)
9386 static char *result;
9387 static size_t result_len = 0;
9390 /* First, unqualify the enumeration name:
9391 1. Search for the last '.' character. If we find one, then skip
9392 all the preceding characters, the unqualified name starts
9393 right after that dot.
9394 2. Otherwise, we may be debugging on a target where the compiler
9395 translates dots into "__". Search forward for double underscores,
9396 but stop searching when we hit an overloading suffix, which is
9397 of the form "__" followed by digits. */
9399 tmp = strrchr (name, '.');
9404 while ((tmp = strstr (name, "__")) != NULL)
9406 if (isdigit (tmp[2]))
9417 if (name[1] == 'U' || name[1] == 'W')
9419 if (sscanf (name + 2, "%x", &v) != 1)
9425 GROW_VECT (result, result_len, 16);
9426 if (isascii (v) && isprint (v))
9427 xsnprintf (result, result_len, "'%c'", v);
9428 else if (name[1] == 'U')
9429 xsnprintf (result, result_len, "[\"%02x\"]", v);
9431 xsnprintf (result, result_len, "[\"%04x\"]", v);
9437 tmp = strstr (name, "__");
9439 tmp = strstr (name, "$");
9442 GROW_VECT (result, result_len, tmp - name + 1);
9443 strncpy (result, name, tmp - name);
9444 result[tmp - name] = '\0';
9452 /* Evaluate the subexpression of EXP starting at *POS as for
9453 evaluate_type, updating *POS to point just past the evaluated
9456 static struct value *
9457 evaluate_subexp_type (struct expression *exp, int *pos)
9459 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9462 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9465 static struct value *
9466 unwrap_value (struct value *val)
9468 struct type *type = ada_check_typedef (value_type (val));
9470 if (ada_is_aligner_type (type))
9472 struct value *v = ada_value_struct_elt (val, "F", 0);
9473 struct type *val_type = ada_check_typedef (value_type (v));
9475 if (ada_type_name (val_type) == NULL)
9476 TYPE_NAME (val_type) = ada_type_name (type);
9478 return unwrap_value (v);
9482 struct type *raw_real_type =
9483 ada_check_typedef (ada_get_base_type (type));
9485 /* If there is no parallel XVS or XVE type, then the value is
9486 already unwrapped. Return it without further modification. */
9487 if ((type == raw_real_type)
9488 && ada_find_parallel_type (type, "___XVE") == NULL)
9492 coerce_unspec_val_to_type
9493 (val, ada_to_fixed_type (raw_real_type, 0,
9494 value_address (val),
9499 static struct value *
9500 cast_from_fixed (struct type *type, struct value *arg)
9502 struct value *scale = ada_scaling_factor (value_type (arg));
9503 arg = value_cast (value_type (scale), arg);
9505 arg = value_binop (arg, scale, BINOP_MUL);
9506 return value_cast (type, arg);
9509 static struct value *
9510 cast_to_fixed (struct type *type, struct value *arg)
9512 if (type == value_type (arg))
9515 struct value *scale = ada_scaling_factor (type);
9516 if (ada_is_fixed_point_type (value_type (arg)))
9517 arg = cast_from_fixed (value_type (scale), arg);
9519 arg = value_cast (value_type (scale), arg);
9521 arg = value_binop (arg, scale, BINOP_DIV);
9522 return value_cast (type, arg);
9525 /* Given two array types T1 and T2, return nonzero iff both arrays
9526 contain the same number of elements. */
9529 ada_same_array_size_p (struct type *t1, struct type *t2)
9531 LONGEST lo1, hi1, lo2, hi2;
9533 /* Get the array bounds in order to verify that the size of
9534 the two arrays match. */
9535 if (!get_array_bounds (t1, &lo1, &hi1)
9536 || !get_array_bounds (t2, &lo2, &hi2))
9537 error (_("unable to determine array bounds"));
9539 /* To make things easier for size comparison, normalize a bit
9540 the case of empty arrays by making sure that the difference
9541 between upper bound and lower bound is always -1. */
9547 return (hi1 - lo1 == hi2 - lo2);
9550 /* Assuming that VAL is an array of integrals, and TYPE represents
9551 an array with the same number of elements, but with wider integral
9552 elements, return an array "casted" to TYPE. In practice, this
9553 means that the returned array is built by casting each element
9554 of the original array into TYPE's (wider) element type. */
9556 static struct value *
9557 ada_promote_array_of_integrals (struct type *type, struct value *val)
9559 struct type *elt_type = TYPE_TARGET_TYPE (type);
9564 /* Verify that both val and type are arrays of scalars, and
9565 that the size of val's elements is smaller than the size
9566 of type's element. */
9567 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9568 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9569 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9570 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9571 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9572 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9574 if (!get_array_bounds (type, &lo, &hi))
9575 error (_("unable to determine array bounds"));
9577 res = allocate_value (type);
9579 /* Promote each array element. */
9580 for (i = 0; i < hi - lo + 1; i++)
9582 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9584 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9585 value_contents_all (elt), TYPE_LENGTH (elt_type));
9591 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9592 return the converted value. */
9594 static struct value *
9595 coerce_for_assign (struct type *type, struct value *val)
9597 struct type *type2 = value_type (val);
9602 type2 = ada_check_typedef (type2);
9603 type = ada_check_typedef (type);
9605 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9606 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9608 val = ada_value_ind (val);
9609 type2 = value_type (val);
9612 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
9613 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9615 if (!ada_same_array_size_p (type, type2))
9616 error (_("cannot assign arrays of different length"));
9618 if (is_integral_type (TYPE_TARGET_TYPE (type))
9619 && is_integral_type (TYPE_TARGET_TYPE (type2))
9620 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9621 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9623 /* Allow implicit promotion of the array elements to
9625 return ada_promote_array_of_integrals (type, val);
9628 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9629 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9630 error (_("Incompatible types in assignment"));
9631 deprecated_set_value_type (val, type);
9636 static struct value *
9637 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9640 struct type *type1, *type2;
9643 arg1 = coerce_ref (arg1);
9644 arg2 = coerce_ref (arg2);
9645 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9646 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9648 if (TYPE_CODE (type1) != TYPE_CODE_INT
9649 || TYPE_CODE (type2) != TYPE_CODE_INT)
9650 return value_binop (arg1, arg2, op);
9659 return value_binop (arg1, arg2, op);
9662 v2 = value_as_long (arg2);
9664 error (_("second operand of %s must not be zero."), op_string (op));
9666 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9667 return value_binop (arg1, arg2, op);
9669 v1 = value_as_long (arg1);
9674 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9675 v += v > 0 ? -1 : 1;
9683 /* Should not reach this point. */
9687 val = allocate_value (type1);
9688 store_unsigned_integer (value_contents_raw (val),
9689 TYPE_LENGTH (value_type (val)),
9690 gdbarch_byte_order (get_type_arch (type1)), v);
9695 ada_value_equal (struct value *arg1, struct value *arg2)
9697 if (ada_is_direct_array_type (value_type (arg1))
9698 || ada_is_direct_array_type (value_type (arg2)))
9700 /* Automatically dereference any array reference before
9701 we attempt to perform the comparison. */
9702 arg1 = ada_coerce_ref (arg1);
9703 arg2 = ada_coerce_ref (arg2);
9705 arg1 = ada_coerce_to_simple_array (arg1);
9706 arg2 = ada_coerce_to_simple_array (arg2);
9707 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9708 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
9709 error (_("Attempt to compare array with non-array"));
9710 /* FIXME: The following works only for types whose
9711 representations use all bits (no padding or undefined bits)
9712 and do not have user-defined equality. */
9714 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
9715 && memcmp (value_contents (arg1), value_contents (arg2),
9716 TYPE_LENGTH (value_type (arg1))) == 0;
9718 return value_equal (arg1, arg2);
9721 /* Total number of component associations in the aggregate starting at
9722 index PC in EXP. Assumes that index PC is the start of an
9726 num_component_specs (struct expression *exp, int pc)
9730 m = exp->elts[pc + 1].longconst;
9733 for (i = 0; i < m; i += 1)
9735 switch (exp->elts[pc].opcode)
9741 n += exp->elts[pc + 1].longconst;
9744 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9749 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9750 component of LHS (a simple array or a record), updating *POS past
9751 the expression, assuming that LHS is contained in CONTAINER. Does
9752 not modify the inferior's memory, nor does it modify LHS (unless
9753 LHS == CONTAINER). */
9756 assign_component (struct value *container, struct value *lhs, LONGEST index,
9757 struct expression *exp, int *pos)
9759 struct value *mark = value_mark ();
9762 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9764 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9765 struct value *index_val = value_from_longest (index_type, index);
9767 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9771 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9772 elt = ada_to_fixed_value (elt);
9775 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9776 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9778 value_assign_to_component (container, elt,
9779 ada_evaluate_subexp (NULL, exp, pos,
9782 value_free_to_mark (mark);
9785 /* Assuming that LHS represents an lvalue having a record or array
9786 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9787 of that aggregate's value to LHS, advancing *POS past the
9788 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9789 lvalue containing LHS (possibly LHS itself). Does not modify
9790 the inferior's memory, nor does it modify the contents of
9791 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9793 static struct value *
9794 assign_aggregate (struct value *container,
9795 struct value *lhs, struct expression *exp,
9796 int *pos, enum noside noside)
9798 struct type *lhs_type;
9799 int n = exp->elts[*pos+1].longconst;
9800 LONGEST low_index, high_index;
9803 int max_indices, num_indices;
9807 if (noside != EVAL_NORMAL)
9809 for (i = 0; i < n; i += 1)
9810 ada_evaluate_subexp (NULL, exp, pos, noside);
9814 container = ada_coerce_ref (container);
9815 if (ada_is_direct_array_type (value_type (container)))
9816 container = ada_coerce_to_simple_array (container);
9817 lhs = ada_coerce_ref (lhs);
9818 if (!deprecated_value_modifiable (lhs))
9819 error (_("Left operand of assignment is not a modifiable lvalue."));
9821 lhs_type = value_type (lhs);
9822 if (ada_is_direct_array_type (lhs_type))
9824 lhs = ada_coerce_to_simple_array (lhs);
9825 lhs_type = value_type (lhs);
9826 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9827 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
9829 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9832 high_index = num_visible_fields (lhs_type) - 1;
9835 error (_("Left-hand side must be array or record."));
9837 num_specs = num_component_specs (exp, *pos - 3);
9838 max_indices = 4 * num_specs + 4;
9839 indices = XALLOCAVEC (LONGEST, max_indices);
9840 indices[0] = indices[1] = low_index - 1;
9841 indices[2] = indices[3] = high_index + 1;
9844 for (i = 0; i < n; i += 1)
9846 switch (exp->elts[*pos].opcode)
9849 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9850 &num_indices, max_indices,
9851 low_index, high_index);
9854 aggregate_assign_positional (container, lhs, exp, pos, indices,
9855 &num_indices, max_indices,
9856 low_index, high_index);
9860 error (_("Misplaced 'others' clause"));
9861 aggregate_assign_others (container, lhs, exp, pos, indices,
9862 num_indices, low_index, high_index);
9865 error (_("Internal error: bad aggregate clause"));
9872 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9873 construct at *POS, updating *POS past the construct, given that
9874 the positions are relative to lower bound LOW, where HIGH is the
9875 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9876 updating *NUM_INDICES as needed. CONTAINER is as for
9877 assign_aggregate. */
9879 aggregate_assign_positional (struct value *container,
9880 struct value *lhs, struct expression *exp,
9881 int *pos, LONGEST *indices, int *num_indices,
9882 int max_indices, LONGEST low, LONGEST high)
9884 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9886 if (ind - 1 == high)
9887 warning (_("Extra components in aggregate ignored."));
9890 add_component_interval (ind, ind, indices, num_indices, max_indices);
9892 assign_component (container, lhs, ind, exp, pos);
9895 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9898 /* Assign into the components of LHS indexed by the OP_CHOICES
9899 construct at *POS, updating *POS past the construct, given that
9900 the allowable indices are LOW..HIGH. Record the indices assigned
9901 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9902 needed. CONTAINER is as for assign_aggregate. */
9904 aggregate_assign_from_choices (struct value *container,
9905 struct value *lhs, struct expression *exp,
9906 int *pos, LONGEST *indices, int *num_indices,
9907 int max_indices, LONGEST low, LONGEST high)
9910 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9911 int choice_pos, expr_pc;
9912 int is_array = ada_is_direct_array_type (value_type (lhs));
9914 choice_pos = *pos += 3;
9916 for (j = 0; j < n_choices; j += 1)
9917 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9919 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9921 for (j = 0; j < n_choices; j += 1)
9923 LONGEST lower, upper;
9924 enum exp_opcode op = exp->elts[choice_pos].opcode;
9926 if (op == OP_DISCRETE_RANGE)
9929 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9931 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9936 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9948 name = &exp->elts[choice_pos + 2].string;
9951 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9954 error (_("Invalid record component association."));
9956 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9958 if (! find_struct_field (name, value_type (lhs), 0,
9959 NULL, NULL, NULL, NULL, &ind))
9960 error (_("Unknown component name: %s."), name);
9961 lower = upper = ind;
9964 if (lower <= upper && (lower < low || upper > high))
9965 error (_("Index in component association out of bounds."));
9967 add_component_interval (lower, upper, indices, num_indices,
9969 while (lower <= upper)
9974 assign_component (container, lhs, lower, exp, &pos1);
9980 /* Assign the value of the expression in the OP_OTHERS construct in
9981 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9982 have not been previously assigned. The index intervals already assigned
9983 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9984 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9986 aggregate_assign_others (struct value *container,
9987 struct value *lhs, struct expression *exp,
9988 int *pos, LONGEST *indices, int num_indices,
9989 LONGEST low, LONGEST high)
9992 int expr_pc = *pos + 1;
9994 for (i = 0; i < num_indices - 2; i += 2)
9998 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10002 localpos = expr_pc;
10003 assign_component (container, lhs, ind, exp, &localpos);
10006 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10009 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
10010 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10011 modifying *SIZE as needed. It is an error if *SIZE exceeds
10012 MAX_SIZE. The resulting intervals do not overlap. */
10014 add_component_interval (LONGEST low, LONGEST high,
10015 LONGEST* indices, int *size, int max_size)
10019 for (i = 0; i < *size; i += 2) {
10020 if (high >= indices[i] && low <= indices[i + 1])
10024 for (kh = i + 2; kh < *size; kh += 2)
10025 if (high < indices[kh])
10027 if (low < indices[i])
10029 indices[i + 1] = indices[kh - 1];
10030 if (high > indices[i + 1])
10031 indices[i + 1] = high;
10032 memcpy (indices + i + 2, indices + kh, *size - kh);
10033 *size -= kh - i - 2;
10036 else if (high < indices[i])
10040 if (*size == max_size)
10041 error (_("Internal error: miscounted aggregate components."));
10043 for (j = *size-1; j >= i+2; j -= 1)
10044 indices[j] = indices[j - 2];
10046 indices[i + 1] = high;
10049 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10052 static struct value *
10053 ada_value_cast (struct type *type, struct value *arg2)
10055 if (type == ada_check_typedef (value_type (arg2)))
10058 if (ada_is_fixed_point_type (type))
10059 return (cast_to_fixed (type, arg2));
10061 if (ada_is_fixed_point_type (value_type (arg2)))
10062 return cast_from_fixed (type, arg2);
10064 return value_cast (type, arg2);
10067 /* Evaluating Ada expressions, and printing their result.
10068 ------------------------------------------------------
10073 We usually evaluate an Ada expression in order to print its value.
10074 We also evaluate an expression in order to print its type, which
10075 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10076 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10077 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10078 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10081 Evaluating expressions is a little more complicated for Ada entities
10082 than it is for entities in languages such as C. The main reason for
10083 this is that Ada provides types whose definition might be dynamic.
10084 One example of such types is variant records. Or another example
10085 would be an array whose bounds can only be known at run time.
10087 The following description is a general guide as to what should be
10088 done (and what should NOT be done) in order to evaluate an expression
10089 involving such types, and when. This does not cover how the semantic
10090 information is encoded by GNAT as this is covered separatly. For the
10091 document used as the reference for the GNAT encoding, see exp_dbug.ads
10092 in the GNAT sources.
10094 Ideally, we should embed each part of this description next to its
10095 associated code. Unfortunately, the amount of code is so vast right
10096 now that it's hard to see whether the code handling a particular
10097 situation might be duplicated or not. One day, when the code is
10098 cleaned up, this guide might become redundant with the comments
10099 inserted in the code, and we might want to remove it.
10101 2. ``Fixing'' an Entity, the Simple Case:
10102 -----------------------------------------
10104 When evaluating Ada expressions, the tricky issue is that they may
10105 reference entities whose type contents and size are not statically
10106 known. Consider for instance a variant record:
10108 type Rec (Empty : Boolean := True) is record
10111 when False => Value : Integer;
10114 Yes : Rec := (Empty => False, Value => 1);
10115 No : Rec := (empty => True);
10117 The size and contents of that record depends on the value of the
10118 descriminant (Rec.Empty). At this point, neither the debugging
10119 information nor the associated type structure in GDB are able to
10120 express such dynamic types. So what the debugger does is to create
10121 "fixed" versions of the type that applies to the specific object.
10122 We also informally refer to this opperation as "fixing" an object,
10123 which means creating its associated fixed type.
10125 Example: when printing the value of variable "Yes" above, its fixed
10126 type would look like this:
10133 On the other hand, if we printed the value of "No", its fixed type
10140 Things become a little more complicated when trying to fix an entity
10141 with a dynamic type that directly contains another dynamic type,
10142 such as an array of variant records, for instance. There are
10143 two possible cases: Arrays, and records.
10145 3. ``Fixing'' Arrays:
10146 ---------------------
10148 The type structure in GDB describes an array in terms of its bounds,
10149 and the type of its elements. By design, all elements in the array
10150 have the same type and we cannot represent an array of variant elements
10151 using the current type structure in GDB. When fixing an array,
10152 we cannot fix the array element, as we would potentially need one
10153 fixed type per element of the array. As a result, the best we can do
10154 when fixing an array is to produce an array whose bounds and size
10155 are correct (allowing us to read it from memory), but without having
10156 touched its element type. Fixing each element will be done later,
10157 when (if) necessary.
10159 Arrays are a little simpler to handle than records, because the same
10160 amount of memory is allocated for each element of the array, even if
10161 the amount of space actually used by each element differs from element
10162 to element. Consider for instance the following array of type Rec:
10164 type Rec_Array is array (1 .. 2) of Rec;
10166 The actual amount of memory occupied by each element might be different
10167 from element to element, depending on the value of their discriminant.
10168 But the amount of space reserved for each element in the array remains
10169 fixed regardless. So we simply need to compute that size using
10170 the debugging information available, from which we can then determine
10171 the array size (we multiply the number of elements of the array by
10172 the size of each element).
10174 The simplest case is when we have an array of a constrained element
10175 type. For instance, consider the following type declarations:
10177 type Bounded_String (Max_Size : Integer) is
10179 Buffer : String (1 .. Max_Size);
10181 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10183 In this case, the compiler describes the array as an array of
10184 variable-size elements (identified by its XVS suffix) for which
10185 the size can be read in the parallel XVZ variable.
10187 In the case of an array of an unconstrained element type, the compiler
10188 wraps the array element inside a private PAD type. This type should not
10189 be shown to the user, and must be "unwrap"'ed before printing. Note
10190 that we also use the adjective "aligner" in our code to designate
10191 these wrapper types.
10193 In some cases, the size allocated for each element is statically
10194 known. In that case, the PAD type already has the correct size,
10195 and the array element should remain unfixed.
10197 But there are cases when this size is not statically known.
10198 For instance, assuming that "Five" is an integer variable:
10200 type Dynamic is array (1 .. Five) of Integer;
10201 type Wrapper (Has_Length : Boolean := False) is record
10204 when True => Length : Integer;
10205 when False => null;
10208 type Wrapper_Array is array (1 .. 2) of Wrapper;
10210 Hello : Wrapper_Array := (others => (Has_Length => True,
10211 Data => (others => 17),
10215 The debugging info would describe variable Hello as being an
10216 array of a PAD type. The size of that PAD type is not statically
10217 known, but can be determined using a parallel XVZ variable.
10218 In that case, a copy of the PAD type with the correct size should
10219 be used for the fixed array.
10221 3. ``Fixing'' record type objects:
10222 ----------------------------------
10224 Things are slightly different from arrays in the case of dynamic
10225 record types. In this case, in order to compute the associated
10226 fixed type, we need to determine the size and offset of each of
10227 its components. This, in turn, requires us to compute the fixed
10228 type of each of these components.
10230 Consider for instance the example:
10232 type Bounded_String (Max_Size : Natural) is record
10233 Str : String (1 .. Max_Size);
10236 My_String : Bounded_String (Max_Size => 10);
10238 In that case, the position of field "Length" depends on the size
10239 of field Str, which itself depends on the value of the Max_Size
10240 discriminant. In order to fix the type of variable My_String,
10241 we need to fix the type of field Str. Therefore, fixing a variant
10242 record requires us to fix each of its components.
10244 However, if a component does not have a dynamic size, the component
10245 should not be fixed. In particular, fields that use a PAD type
10246 should not fixed. Here is an example where this might happen
10247 (assuming type Rec above):
10249 type Container (Big : Boolean) is record
10253 when True => Another : Integer;
10254 when False => null;
10257 My_Container : Container := (Big => False,
10258 First => (Empty => True),
10261 In that example, the compiler creates a PAD type for component First,
10262 whose size is constant, and then positions the component After just
10263 right after it. The offset of component After is therefore constant
10266 The debugger computes the position of each field based on an algorithm
10267 that uses, among other things, the actual position and size of the field
10268 preceding it. Let's now imagine that the user is trying to print
10269 the value of My_Container. If the type fixing was recursive, we would
10270 end up computing the offset of field After based on the size of the
10271 fixed version of field First. And since in our example First has
10272 only one actual field, the size of the fixed type is actually smaller
10273 than the amount of space allocated to that field, and thus we would
10274 compute the wrong offset of field After.
10276 To make things more complicated, we need to watch out for dynamic
10277 components of variant records (identified by the ___XVL suffix in
10278 the component name). Even if the target type is a PAD type, the size
10279 of that type might not be statically known. So the PAD type needs
10280 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10281 we might end up with the wrong size for our component. This can be
10282 observed with the following type declarations:
10284 type Octal is new Integer range 0 .. 7;
10285 type Octal_Array is array (Positive range <>) of Octal;
10286 pragma Pack (Octal_Array);
10288 type Octal_Buffer (Size : Positive) is record
10289 Buffer : Octal_Array (1 .. Size);
10293 In that case, Buffer is a PAD type whose size is unset and needs
10294 to be computed by fixing the unwrapped type.
10296 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10297 ----------------------------------------------------------
10299 Lastly, when should the sub-elements of an entity that remained unfixed
10300 thus far, be actually fixed?
10302 The answer is: Only when referencing that element. For instance
10303 when selecting one component of a record, this specific component
10304 should be fixed at that point in time. Or when printing the value
10305 of a record, each component should be fixed before its value gets
10306 printed. Similarly for arrays, the element of the array should be
10307 fixed when printing each element of the array, or when extracting
10308 one element out of that array. On the other hand, fixing should
10309 not be performed on the elements when taking a slice of an array!
10311 Note that one of the side effects of miscomputing the offset and
10312 size of each field is that we end up also miscomputing the size
10313 of the containing type. This can have adverse results when computing
10314 the value of an entity. GDB fetches the value of an entity based
10315 on the size of its type, and thus a wrong size causes GDB to fetch
10316 the wrong amount of memory. In the case where the computed size is
10317 too small, GDB fetches too little data to print the value of our
10318 entity. Results in this case are unpredictable, as we usually read
10319 past the buffer containing the data =:-o. */
10321 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10322 for that subexpression cast to TO_TYPE. Advance *POS over the
10326 ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10327 enum noside noside, struct type *to_type)
10331 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10332 || exp->elts[pc].opcode == OP_VAR_VALUE)
10337 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10339 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10340 return value_zero (to_type, not_lval);
10342 val = evaluate_var_msym_value (noside,
10343 exp->elts[pc + 1].objfile,
10344 exp->elts[pc + 2].msymbol);
10347 val = evaluate_var_value (noside,
10348 exp->elts[pc + 1].block,
10349 exp->elts[pc + 2].symbol);
10351 if (noside == EVAL_SKIP)
10352 return eval_skip_value (exp);
10354 val = ada_value_cast (to_type, val);
10356 /* Follow the Ada language semantics that do not allow taking
10357 an address of the result of a cast (view conversion in Ada). */
10358 if (VALUE_LVAL (val) == lval_memory)
10360 if (value_lazy (val))
10361 value_fetch_lazy (val);
10362 VALUE_LVAL (val) = not_lval;
10367 value *val = evaluate_subexp (to_type, exp, pos, noside);
10368 if (noside == EVAL_SKIP)
10369 return eval_skip_value (exp);
10370 return ada_value_cast (to_type, val);
10373 /* Implement the evaluate_exp routine in the exp_descriptor structure
10374 for the Ada language. */
10376 static struct value *
10377 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
10378 int *pos, enum noside noside)
10380 enum exp_opcode op;
10384 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10387 struct value **argvec;
10391 op = exp->elts[pc].opcode;
10397 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10399 if (noside == EVAL_NORMAL)
10400 arg1 = unwrap_value (arg1);
10402 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10403 then we need to perform the conversion manually, because
10404 evaluate_subexp_standard doesn't do it. This conversion is
10405 necessary in Ada because the different kinds of float/fixed
10406 types in Ada have different representations.
10408 Similarly, we need to perform the conversion from OP_LONG
10410 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
10411 arg1 = ada_value_cast (expect_type, arg1);
10417 struct value *result;
10420 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10421 /* The result type will have code OP_STRING, bashed there from
10422 OP_ARRAY. Bash it back. */
10423 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10424 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
10430 type = exp->elts[pc + 1].type;
10431 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
10435 type = exp->elts[pc + 1].type;
10436 return ada_evaluate_subexp (type, exp, pos, noside);
10439 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10440 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10442 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10443 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10445 return ada_value_assign (arg1, arg1);
10447 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10448 except if the lhs of our assignment is a convenience variable.
10449 In the case of assigning to a convenience variable, the lhs
10450 should be exactly the result of the evaluation of the rhs. */
10451 type = value_type (arg1);
10452 if (VALUE_LVAL (arg1) == lval_internalvar)
10454 arg2 = evaluate_subexp (type, exp, pos, noside);
10455 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10457 if (ada_is_fixed_point_type (value_type (arg1)))
10458 arg2 = cast_to_fixed (value_type (arg1), arg2);
10459 else if (ada_is_fixed_point_type (value_type (arg2)))
10461 (_("Fixed-point values must be assigned to fixed-point variables"));
10463 arg2 = coerce_for_assign (value_type (arg1), arg2);
10464 return ada_value_assign (arg1, arg2);
10467 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10468 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10469 if (noside == EVAL_SKIP)
10471 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10472 return (value_from_longest
10473 (value_type (arg1),
10474 value_as_long (arg1) + value_as_long (arg2)));
10475 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10476 return (value_from_longest
10477 (value_type (arg2),
10478 value_as_long (arg1) + value_as_long (arg2)));
10479 if ((ada_is_fixed_point_type (value_type (arg1))
10480 || ada_is_fixed_point_type (value_type (arg2)))
10481 && value_type (arg1) != value_type (arg2))
10482 error (_("Operands of fixed-point addition must have the same type"));
10483 /* Do the addition, and cast the result to the type of the first
10484 argument. We cannot cast the result to a reference type, so if
10485 ARG1 is a reference type, find its underlying type. */
10486 type = value_type (arg1);
10487 while (TYPE_CODE (type) == TYPE_CODE_REF)
10488 type = TYPE_TARGET_TYPE (type);
10489 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10490 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
10493 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10494 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10495 if (noside == EVAL_SKIP)
10497 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10498 return (value_from_longest
10499 (value_type (arg1),
10500 value_as_long (arg1) - value_as_long (arg2)));
10501 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10502 return (value_from_longest
10503 (value_type (arg2),
10504 value_as_long (arg1) - value_as_long (arg2)));
10505 if ((ada_is_fixed_point_type (value_type (arg1))
10506 || ada_is_fixed_point_type (value_type (arg2)))
10507 && value_type (arg1) != value_type (arg2))
10508 error (_("Operands of fixed-point subtraction "
10509 "must have the same type"));
10510 /* Do the substraction, and cast the result to the type of the first
10511 argument. We cannot cast the result to a reference type, so if
10512 ARG1 is a reference type, find its underlying type. */
10513 type = value_type (arg1);
10514 while (TYPE_CODE (type) == TYPE_CODE_REF)
10515 type = TYPE_TARGET_TYPE (type);
10516 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10517 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
10523 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10524 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10525 if (noside == EVAL_SKIP)
10527 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10529 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10530 return value_zero (value_type (arg1), not_lval);
10534 type = builtin_type (exp->gdbarch)->builtin_double;
10535 if (ada_is_fixed_point_type (value_type (arg1)))
10536 arg1 = cast_from_fixed (type, arg1);
10537 if (ada_is_fixed_point_type (value_type (arg2)))
10538 arg2 = cast_from_fixed (type, arg2);
10539 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10540 return ada_value_binop (arg1, arg2, op);
10544 case BINOP_NOTEQUAL:
10545 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10546 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
10547 if (noside == EVAL_SKIP)
10549 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10553 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10554 tem = ada_value_equal (arg1, arg2);
10556 if (op == BINOP_NOTEQUAL)
10558 type = language_bool_type (exp->language_defn, exp->gdbarch);
10559 return value_from_longest (type, (LONGEST) tem);
10562 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10563 if (noside == EVAL_SKIP)
10565 else if (ada_is_fixed_point_type (value_type (arg1)))
10566 return value_cast (value_type (arg1), value_neg (arg1));
10569 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10570 return value_neg (arg1);
10573 case BINOP_LOGICAL_AND:
10574 case BINOP_LOGICAL_OR:
10575 case UNOP_LOGICAL_NOT:
10580 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10581 type = language_bool_type (exp->language_defn, exp->gdbarch);
10582 return value_cast (type, val);
10585 case BINOP_BITWISE_AND:
10586 case BINOP_BITWISE_IOR:
10587 case BINOP_BITWISE_XOR:
10591 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10593 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10595 return value_cast (value_type (arg1), val);
10601 if (noside == EVAL_SKIP)
10607 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
10608 /* Only encountered when an unresolved symbol occurs in a
10609 context other than a function call, in which case, it is
10611 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10612 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
10614 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10616 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
10617 /* Check to see if this is a tagged type. We also need to handle
10618 the case where the type is a reference to a tagged type, but
10619 we have to be careful to exclude pointers to tagged types.
10620 The latter should be shown as usual (as a pointer), whereas
10621 a reference should mostly be transparent to the user. */
10622 if (ada_is_tagged_type (type, 0)
10623 || (TYPE_CODE (type) == TYPE_CODE_REF
10624 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10626 /* Tagged types are a little special in the fact that the real
10627 type is dynamic and can only be determined by inspecting the
10628 object's tag. This means that we need to get the object's
10629 value first (EVAL_NORMAL) and then extract the actual object
10632 Note that we cannot skip the final step where we extract
10633 the object type from its tag, because the EVAL_NORMAL phase
10634 results in dynamic components being resolved into fixed ones.
10635 This can cause problems when trying to print the type
10636 description of tagged types whose parent has a dynamic size:
10637 We use the type name of the "_parent" component in order
10638 to print the name of the ancestor type in the type description.
10639 If that component had a dynamic size, the resolution into
10640 a fixed type would result in the loss of that type name,
10641 thus preventing us from printing the name of the ancestor
10642 type in the type description. */
10643 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10645 if (TYPE_CODE (type) != TYPE_CODE_REF)
10647 struct type *actual_type;
10649 actual_type = type_from_tag (ada_value_tag (arg1));
10650 if (actual_type == NULL)
10651 /* If, for some reason, we were unable to determine
10652 the actual type from the tag, then use the static
10653 approximation that we just computed as a fallback.
10654 This can happen if the debugging information is
10655 incomplete, for instance. */
10656 actual_type = type;
10657 return value_zero (actual_type, not_lval);
10661 /* In the case of a ref, ada_coerce_ref takes care
10662 of determining the actual type. But the evaluation
10663 should return a ref as it should be valid to ask
10664 for its address; so rebuild a ref after coerce. */
10665 arg1 = ada_coerce_ref (arg1);
10666 return value_ref (arg1, TYPE_CODE_REF);
10670 /* Records and unions for which GNAT encodings have been
10671 generated need to be statically fixed as well.
10672 Otherwise, non-static fixing produces a type where
10673 all dynamic properties are removed, which prevents "ptype"
10674 from being able to completely describe the type.
10675 For instance, a case statement in a variant record would be
10676 replaced by the relevant components based on the actual
10677 value of the discriminants. */
10678 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10679 && dynamic_template_type (type) != NULL)
10680 || (TYPE_CODE (type) == TYPE_CODE_UNION
10681 && ada_find_parallel_type (type, "___XVU") != NULL))
10684 return value_zero (to_static_fixed_type (type), not_lval);
10688 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10689 return ada_to_fixed_value (arg1);
10694 /* Allocate arg vector, including space for the function to be
10695 called in argvec[0] and a terminating NULL. */
10696 nargs = longest_to_int (exp->elts[pc + 1].longconst);
10697 argvec = XALLOCAVEC (struct value *, nargs + 2);
10699 if (exp->elts[*pos].opcode == OP_VAR_VALUE
10700 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
10701 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10702 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10705 for (tem = 0; tem <= nargs; tem += 1)
10706 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10709 if (noside == EVAL_SKIP)
10713 if (ada_is_constrained_packed_array_type
10714 (desc_base_type (value_type (argvec[0]))))
10715 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
10716 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10717 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10718 /* This is a packed array that has already been fixed, and
10719 therefore already coerced to a simple array. Nothing further
10722 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10724 /* Make sure we dereference references so that all the code below
10725 feels like it's really handling the referenced value. Wrapping
10726 types (for alignment) may be there, so make sure we strip them as
10728 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10730 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10731 && VALUE_LVAL (argvec[0]) == lval_memory)
10732 argvec[0] = value_addr (argvec[0]);
10734 type = ada_check_typedef (value_type (argvec[0]));
10736 /* Ada allows us to implicitly dereference arrays when subscripting
10737 them. So, if this is an array typedef (encoding use for array
10738 access types encoded as fat pointers), strip it now. */
10739 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10740 type = ada_typedef_target_type (type);
10742 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10744 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
10746 case TYPE_CODE_FUNC:
10747 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10749 case TYPE_CODE_ARRAY:
10751 case TYPE_CODE_STRUCT:
10752 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10753 argvec[0] = ada_value_ind (argvec[0]);
10754 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10757 error (_("cannot subscript or call something of type `%s'"),
10758 ada_type_name (value_type (argvec[0])));
10763 switch (TYPE_CODE (type))
10765 case TYPE_CODE_FUNC:
10766 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10768 if (TYPE_TARGET_TYPE (type) == NULL)
10769 error_call_unknown_return_type (NULL);
10770 return allocate_value (TYPE_TARGET_TYPE (type));
10772 return call_function_by_hand (argvec[0], NULL, nargs, argvec + 1);
10773 case TYPE_CODE_INTERNAL_FUNCTION:
10774 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10775 /* We don't know anything about what the internal
10776 function might return, but we have to return
10778 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10781 return call_internal_function (exp->gdbarch, exp->language_defn,
10782 argvec[0], nargs, argvec + 1);
10784 case TYPE_CODE_STRUCT:
10788 arity = ada_array_arity (type);
10789 type = ada_array_element_type (type, nargs);
10791 error (_("cannot subscript or call a record"));
10792 if (arity != nargs)
10793 error (_("wrong number of subscripts; expecting %d"), arity);
10794 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10795 return value_zero (ada_aligned_type (type), lval_memory);
10797 unwrap_value (ada_value_subscript
10798 (argvec[0], nargs, argvec + 1));
10800 case TYPE_CODE_ARRAY:
10801 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10803 type = ada_array_element_type (type, nargs);
10805 error (_("element type of array unknown"));
10807 return value_zero (ada_aligned_type (type), lval_memory);
10810 unwrap_value (ada_value_subscript
10811 (ada_coerce_to_simple_array (argvec[0]),
10812 nargs, argvec + 1));
10813 case TYPE_CODE_PTR: /* Pointer to array */
10814 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10816 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10817 type = ada_array_element_type (type, nargs);
10819 error (_("element type of array unknown"));
10821 return value_zero (ada_aligned_type (type), lval_memory);
10824 unwrap_value (ada_value_ptr_subscript (argvec[0],
10825 nargs, argvec + 1));
10828 error (_("Attempt to index or call something other than an "
10829 "array or function"));
10834 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10835 struct value *low_bound_val =
10836 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10837 struct value *high_bound_val =
10838 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10840 LONGEST high_bound;
10842 low_bound_val = coerce_ref (low_bound_val);
10843 high_bound_val = coerce_ref (high_bound_val);
10844 low_bound = value_as_long (low_bound_val);
10845 high_bound = value_as_long (high_bound_val);
10847 if (noside == EVAL_SKIP)
10850 /* If this is a reference to an aligner type, then remove all
10852 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10853 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10854 TYPE_TARGET_TYPE (value_type (array)) =
10855 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
10857 if (ada_is_constrained_packed_array_type (value_type (array)))
10858 error (_("cannot slice a packed array"));
10860 /* If this is a reference to an array or an array lvalue,
10861 convert to a pointer. */
10862 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10863 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
10864 && VALUE_LVAL (array) == lval_memory))
10865 array = value_addr (array);
10867 if (noside == EVAL_AVOID_SIDE_EFFECTS
10868 && ada_is_array_descriptor_type (ada_check_typedef
10869 (value_type (array))))
10870 return empty_array (ada_type_of_array (array, 0), low_bound);
10872 array = ada_coerce_to_simple_array_ptr (array);
10874 /* If we have more than one level of pointer indirection,
10875 dereference the value until we get only one level. */
10876 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10877 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
10879 array = value_ind (array);
10881 /* Make sure we really do have an array type before going further,
10882 to avoid a SEGV when trying to get the index type or the target
10883 type later down the road if the debug info generated by
10884 the compiler is incorrect or incomplete. */
10885 if (!ada_is_simple_array_type (value_type (array)))
10886 error (_("cannot take slice of non-array"));
10888 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10891 struct type *type0 = ada_check_typedef (value_type (array));
10893 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10894 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
10897 struct type *arr_type0 =
10898 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
10900 return ada_value_slice_from_ptr (array, arr_type0,
10901 longest_to_int (low_bound),
10902 longest_to_int (high_bound));
10905 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10907 else if (high_bound < low_bound)
10908 return empty_array (value_type (array), low_bound);
10910 return ada_value_slice (array, longest_to_int (low_bound),
10911 longest_to_int (high_bound));
10914 case UNOP_IN_RANGE:
10916 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10917 type = check_typedef (exp->elts[pc + 1].type);
10919 if (noside == EVAL_SKIP)
10922 switch (TYPE_CODE (type))
10925 lim_warning (_("Membership test incompletely implemented; "
10926 "always returns true"));
10927 type = language_bool_type (exp->language_defn, exp->gdbarch);
10928 return value_from_longest (type, (LONGEST) 1);
10930 case TYPE_CODE_RANGE:
10931 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10932 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
10933 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10934 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10935 type = language_bool_type (exp->language_defn, exp->gdbarch);
10937 value_from_longest (type,
10938 (value_less (arg1, arg3)
10939 || value_equal (arg1, arg3))
10940 && (value_less (arg2, arg1)
10941 || value_equal (arg2, arg1)));
10944 case BINOP_IN_BOUNDS:
10946 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10947 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10949 if (noside == EVAL_SKIP)
10952 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10954 type = language_bool_type (exp->language_defn, exp->gdbarch);
10955 return value_zero (type, not_lval);
10958 tem = longest_to_int (exp->elts[pc + 1].longconst);
10960 type = ada_index_type (value_type (arg2), tem, "range");
10962 type = value_type (arg1);
10964 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10965 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
10967 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10968 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10969 type = language_bool_type (exp->language_defn, exp->gdbarch);
10971 value_from_longest (type,
10972 (value_less (arg1, arg3)
10973 || value_equal (arg1, arg3))
10974 && (value_less (arg2, arg1)
10975 || value_equal (arg2, arg1)));
10977 case TERNOP_IN_RANGE:
10978 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10979 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10980 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10982 if (noside == EVAL_SKIP)
10985 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10986 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10987 type = language_bool_type (exp->language_defn, exp->gdbarch);
10989 value_from_longest (type,
10990 (value_less (arg1, arg3)
10991 || value_equal (arg1, arg3))
10992 && (value_less (arg2, arg1)
10993 || value_equal (arg2, arg1)));
10997 case OP_ATR_LENGTH:
10999 struct type *type_arg;
11001 if (exp->elts[*pos].opcode == OP_TYPE)
11003 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11005 type_arg = check_typedef (exp->elts[pc + 2].type);
11009 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11013 if (exp->elts[*pos].opcode != OP_LONG)
11014 error (_("Invalid operand to '%s"), ada_attribute_name (op));
11015 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11018 if (noside == EVAL_SKIP)
11021 if (type_arg == NULL)
11023 arg1 = ada_coerce_ref (arg1);
11025 if (ada_is_constrained_packed_array_type (value_type (arg1)))
11026 arg1 = ada_coerce_to_simple_array (arg1);
11028 if (op == OP_ATR_LENGTH)
11029 type = builtin_type (exp->gdbarch)->builtin_int;
11032 type = ada_index_type (value_type (arg1), tem,
11033 ada_attribute_name (op));
11035 type = builtin_type (exp->gdbarch)->builtin_int;
11038 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11039 return allocate_value (type);
11043 default: /* Should never happen. */
11044 error (_("unexpected attribute encountered"));
11046 return value_from_longest
11047 (type, ada_array_bound (arg1, tem, 0));
11049 return value_from_longest
11050 (type, ada_array_bound (arg1, tem, 1));
11051 case OP_ATR_LENGTH:
11052 return value_from_longest
11053 (type, ada_array_length (arg1, tem));
11056 else if (discrete_type_p (type_arg))
11058 struct type *range_type;
11059 const char *name = ada_type_name (type_arg);
11062 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
11063 range_type = to_fixed_range_type (type_arg, NULL);
11064 if (range_type == NULL)
11065 range_type = type_arg;
11069 error (_("unexpected attribute encountered"));
11071 return value_from_longest
11072 (range_type, ada_discrete_type_low_bound (range_type));
11074 return value_from_longest
11075 (range_type, ada_discrete_type_high_bound (range_type));
11076 case OP_ATR_LENGTH:
11077 error (_("the 'length attribute applies only to array types"));
11080 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
11081 error (_("unimplemented type attribute"));
11086 if (ada_is_constrained_packed_array_type (type_arg))
11087 type_arg = decode_constrained_packed_array_type (type_arg);
11089 if (op == OP_ATR_LENGTH)
11090 type = builtin_type (exp->gdbarch)->builtin_int;
11093 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11095 type = builtin_type (exp->gdbarch)->builtin_int;
11098 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11099 return allocate_value (type);
11104 error (_("unexpected attribute encountered"));
11106 low = ada_array_bound_from_type (type_arg, tem, 0);
11107 return value_from_longest (type, low);
11109 high = ada_array_bound_from_type (type_arg, tem, 1);
11110 return value_from_longest (type, high);
11111 case OP_ATR_LENGTH:
11112 low = ada_array_bound_from_type (type_arg, tem, 0);
11113 high = ada_array_bound_from_type (type_arg, tem, 1);
11114 return value_from_longest (type, high - low + 1);
11120 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11121 if (noside == EVAL_SKIP)
11124 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11125 return value_zero (ada_tag_type (arg1), not_lval);
11127 return ada_value_tag (arg1);
11131 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11132 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11133 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11134 if (noside == EVAL_SKIP)
11136 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11137 return value_zero (value_type (arg1), not_lval);
11140 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11141 return value_binop (arg1, arg2,
11142 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11145 case OP_ATR_MODULUS:
11147 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
11149 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11150 if (noside == EVAL_SKIP)
11153 if (!ada_is_modular_type (type_arg))
11154 error (_("'modulus must be applied to modular type"));
11156 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11157 ada_modulus (type_arg));
11162 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11163 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11164 if (noside == EVAL_SKIP)
11166 type = builtin_type (exp->gdbarch)->builtin_int;
11167 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11168 return value_zero (type, not_lval);
11170 return value_pos_atr (type, arg1);
11173 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11174 type = value_type (arg1);
11176 /* If the argument is a reference, then dereference its type, since
11177 the user is really asking for the size of the actual object,
11178 not the size of the pointer. */
11179 if (TYPE_CODE (type) == TYPE_CODE_REF)
11180 type = TYPE_TARGET_TYPE (type);
11182 if (noside == EVAL_SKIP)
11184 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11185 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
11187 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
11188 TARGET_CHAR_BIT * TYPE_LENGTH (type));
11191 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11192 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11193 type = exp->elts[pc + 2].type;
11194 if (noside == EVAL_SKIP)
11196 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11197 return value_zero (type, not_lval);
11199 return value_val_atr (type, arg1);
11202 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11203 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11204 if (noside == EVAL_SKIP)
11206 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11207 return value_zero (value_type (arg1), not_lval);
11210 /* For integer exponentiation operations,
11211 only promote the first argument. */
11212 if (is_integral_type (value_type (arg2)))
11213 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11215 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11217 return value_binop (arg1, arg2, op);
11221 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11222 if (noside == EVAL_SKIP)
11228 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11229 if (noside == EVAL_SKIP)
11231 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11232 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
11233 return value_neg (arg1);
11238 preeval_pos = *pos;
11239 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11240 if (noside == EVAL_SKIP)
11242 type = ada_check_typedef (value_type (arg1));
11243 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11245 if (ada_is_array_descriptor_type (type))
11246 /* GDB allows dereferencing GNAT array descriptors. */
11248 struct type *arrType = ada_type_of_array (arg1, 0);
11250 if (arrType == NULL)
11251 error (_("Attempt to dereference null array pointer."));
11252 return value_at_lazy (arrType, 0);
11254 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11255 || TYPE_CODE (type) == TYPE_CODE_REF
11256 /* In C you can dereference an array to get the 1st elt. */
11257 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
11259 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11260 only be determined by inspecting the object's tag.
11261 This means that we need to evaluate completely the
11262 expression in order to get its type. */
11264 if ((TYPE_CODE (type) == TYPE_CODE_REF
11265 || TYPE_CODE (type) == TYPE_CODE_PTR)
11266 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11268 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11270 type = value_type (ada_value_ind (arg1));
11274 type = to_static_fixed_type
11276 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11278 ada_ensure_varsize_limit (type);
11279 return value_zero (type, lval_memory);
11281 else if (TYPE_CODE (type) == TYPE_CODE_INT)
11283 /* GDB allows dereferencing an int. */
11284 if (expect_type == NULL)
11285 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11290 to_static_fixed_type (ada_aligned_type (expect_type));
11291 return value_zero (expect_type, lval_memory);
11295 error (_("Attempt to take contents of a non-pointer value."));
11297 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
11298 type = ada_check_typedef (value_type (arg1));
11300 if (TYPE_CODE (type) == TYPE_CODE_INT)
11301 /* GDB allows dereferencing an int. If we were given
11302 the expect_type, then use that as the target type.
11303 Otherwise, assume that the target type is an int. */
11305 if (expect_type != NULL)
11306 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11309 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11310 (CORE_ADDR) value_as_address (arg1));
11313 if (ada_is_array_descriptor_type (type))
11314 /* GDB allows dereferencing GNAT array descriptors. */
11315 return ada_coerce_to_simple_array (arg1);
11317 return ada_value_ind (arg1);
11319 case STRUCTOP_STRUCT:
11320 tem = longest_to_int (exp->elts[pc + 1].longconst);
11321 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
11322 preeval_pos = *pos;
11323 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11324 if (noside == EVAL_SKIP)
11326 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11328 struct type *type1 = value_type (arg1);
11330 if (ada_is_tagged_type (type1, 1))
11332 type = ada_lookup_struct_elt_type (type1,
11333 &exp->elts[pc + 2].string,
11336 /* If the field is not found, check if it exists in the
11337 extension of this object's type. This means that we
11338 need to evaluate completely the expression. */
11342 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11344 arg1 = ada_value_struct_elt (arg1,
11345 &exp->elts[pc + 2].string,
11347 arg1 = unwrap_value (arg1);
11348 type = value_type (ada_to_fixed_value (arg1));
11353 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
11356 return value_zero (ada_aligned_type (type), lval_memory);
11360 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11361 arg1 = unwrap_value (arg1);
11362 return ada_to_fixed_value (arg1);
11366 /* The value is not supposed to be used. This is here to make it
11367 easier to accommodate expressions that contain types. */
11369 if (noside == EVAL_SKIP)
11371 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11372 return allocate_value (exp->elts[pc + 1].type);
11374 error (_("Attempt to use a type name as an expression"));
11379 case OP_DISCRETE_RANGE:
11380 case OP_POSITIONAL:
11382 if (noside == EVAL_NORMAL)
11386 error (_("Undefined name, ambiguous name, or renaming used in "
11387 "component association: %s."), &exp->elts[pc+2].string);
11389 error (_("Aggregates only allowed on the right of an assignment"));
11391 internal_error (__FILE__, __LINE__,
11392 _("aggregate apparently mangled"));
11395 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11397 for (tem = 0; tem < nargs; tem += 1)
11398 ada_evaluate_subexp (NULL, exp, pos, noside);
11403 return eval_skip_value (exp);
11409 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11410 type name that encodes the 'small and 'delta information.
11411 Otherwise, return NULL. */
11413 static const char *
11414 fixed_type_info (struct type *type)
11416 const char *name = ada_type_name (type);
11417 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11419 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11421 const char *tail = strstr (name, "___XF_");
11428 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11429 return fixed_type_info (TYPE_TARGET_TYPE (type));
11434 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11437 ada_is_fixed_point_type (struct type *type)
11439 return fixed_type_info (type) != NULL;
11442 /* Return non-zero iff TYPE represents a System.Address type. */
11445 ada_is_system_address_type (struct type *type)
11447 return (TYPE_NAME (type)
11448 && strcmp (TYPE_NAME (type), "system__address") == 0);
11451 /* Assuming that TYPE is the representation of an Ada fixed-point
11452 type, return the target floating-point type to be used to represent
11453 of this type during internal computation. */
11455 static struct type *
11456 ada_scaling_type (struct type *type)
11458 return builtin_type (get_type_arch (type))->builtin_long_double;
11461 /* Assuming that TYPE is the representation of an Ada fixed-point
11462 type, return its delta, or NULL if the type is malformed and the
11463 delta cannot be determined. */
11466 ada_delta (struct type *type)
11468 const char *encoding = fixed_type_info (type);
11469 struct type *scale_type = ada_scaling_type (type);
11471 long long num, den;
11473 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11476 return value_binop (value_from_longest (scale_type, num),
11477 value_from_longest (scale_type, den), BINOP_DIV);
11480 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11481 factor ('SMALL value) associated with the type. */
11484 ada_scaling_factor (struct type *type)
11486 const char *encoding = fixed_type_info (type);
11487 struct type *scale_type = ada_scaling_type (type);
11489 long long num0, den0, num1, den1;
11492 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
11493 &num0, &den0, &num1, &den1);
11496 return value_from_longest (scale_type, 1);
11498 return value_binop (value_from_longest (scale_type, num1),
11499 value_from_longest (scale_type, den1), BINOP_DIV);
11501 return value_binop (value_from_longest (scale_type, num0),
11502 value_from_longest (scale_type, den0), BINOP_DIV);
11509 /* Scan STR beginning at position K for a discriminant name, and
11510 return the value of that discriminant field of DVAL in *PX. If
11511 PNEW_K is not null, put the position of the character beyond the
11512 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11513 not alter *PX and *PNEW_K if unsuccessful. */
11516 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11519 static char *bound_buffer = NULL;
11520 static size_t bound_buffer_len = 0;
11521 const char *pstart, *pend, *bound;
11522 struct value *bound_val;
11524 if (dval == NULL || str == NULL || str[k] == '\0')
11528 pend = strstr (pstart, "__");
11532 k += strlen (bound);
11536 int len = pend - pstart;
11538 /* Strip __ and beyond. */
11539 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11540 strncpy (bound_buffer, pstart, len);
11541 bound_buffer[len] = '\0';
11543 bound = bound_buffer;
11547 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11548 if (bound_val == NULL)
11551 *px = value_as_long (bound_val);
11552 if (pnew_k != NULL)
11557 /* Value of variable named NAME in the current environment. If
11558 no such variable found, then if ERR_MSG is null, returns 0, and
11559 otherwise causes an error with message ERR_MSG. */
11561 static struct value *
11562 get_var_value (const char *name, const char *err_msg)
11564 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
11566 struct block_symbol *syms;
11567 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11568 get_selected_block (0),
11569 VAR_DOMAIN, &syms, 1);
11573 if (err_msg == NULL)
11576 error (("%s"), err_msg);
11579 return value_of_variable (syms[0].symbol, syms[0].block);
11582 /* Value of integer variable named NAME in the current environment.
11583 If no such variable is found, returns false. Otherwise, sets VALUE
11584 to the variable's value and returns true. */
11587 get_int_var_value (const char *name, LONGEST &value)
11589 struct value *var_val = get_var_value (name, 0);
11594 value = value_as_long (var_val);
11599 /* Return a range type whose base type is that of the range type named
11600 NAME in the current environment, and whose bounds are calculated
11601 from NAME according to the GNAT range encoding conventions.
11602 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11603 corresponding range type from debug information; fall back to using it
11604 if symbol lookup fails. If a new type must be created, allocate it
11605 like ORIG_TYPE was. The bounds information, in general, is encoded
11606 in NAME, the base type given in the named range type. */
11608 static struct type *
11609 to_fixed_range_type (struct type *raw_type, struct value *dval)
11612 struct type *base_type;
11613 const char *subtype_info;
11615 gdb_assert (raw_type != NULL);
11616 gdb_assert (TYPE_NAME (raw_type) != NULL);
11618 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
11619 base_type = TYPE_TARGET_TYPE (raw_type);
11621 base_type = raw_type;
11623 name = TYPE_NAME (raw_type);
11624 subtype_info = strstr (name, "___XD");
11625 if (subtype_info == NULL)
11627 LONGEST L = ada_discrete_type_low_bound (raw_type);
11628 LONGEST U = ada_discrete_type_high_bound (raw_type);
11630 if (L < INT_MIN || U > INT_MAX)
11633 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11638 static char *name_buf = NULL;
11639 static size_t name_len = 0;
11640 int prefix_len = subtype_info - name;
11643 const char *bounds_str;
11646 GROW_VECT (name_buf, name_len, prefix_len + 5);
11647 strncpy (name_buf, name, prefix_len);
11648 name_buf[prefix_len] = '\0';
11651 bounds_str = strchr (subtype_info, '_');
11654 if (*subtype_info == 'L')
11656 if (!ada_scan_number (bounds_str, n, &L, &n)
11657 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11659 if (bounds_str[n] == '_')
11661 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
11667 strcpy (name_buf + prefix_len, "___L");
11668 if (!get_int_var_value (name_buf, L))
11670 lim_warning (_("Unknown lower bound, using 1."));
11675 if (*subtype_info == 'U')
11677 if (!ada_scan_number (bounds_str, n, &U, &n)
11678 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11683 strcpy (name_buf + prefix_len, "___U");
11684 if (!get_int_var_value (name_buf, U))
11686 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11691 type = create_static_range_type (alloc_type_copy (raw_type),
11693 TYPE_NAME (type) = name;
11698 /* True iff NAME is the name of a range type. */
11701 ada_is_range_type_name (const char *name)
11703 return (name != NULL && strstr (name, "___XD"));
11707 /* Modular types */
11709 /* True iff TYPE is an Ada modular type. */
11712 ada_is_modular_type (struct type *type)
11714 struct type *subranged_type = get_base_type (type);
11716 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
11717 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
11718 && TYPE_UNSIGNED (subranged_type));
11721 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11724 ada_modulus (struct type *type)
11726 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
11730 /* Ada exception catchpoint support:
11731 ---------------------------------
11733 We support 3 kinds of exception catchpoints:
11734 . catchpoints on Ada exceptions
11735 . catchpoints on unhandled Ada exceptions
11736 . catchpoints on failed assertions
11738 Exceptions raised during failed assertions, or unhandled exceptions
11739 could perfectly be caught with the general catchpoint on Ada exceptions.
11740 However, we can easily differentiate these two special cases, and having
11741 the option to distinguish these two cases from the rest can be useful
11742 to zero-in on certain situations.
11744 Exception catchpoints are a specialized form of breakpoint,
11745 since they rely on inserting breakpoints inside known routines
11746 of the GNAT runtime. The implementation therefore uses a standard
11747 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11750 Support in the runtime for exception catchpoints have been changed
11751 a few times already, and these changes affect the implementation
11752 of these catchpoints. In order to be able to support several
11753 variants of the runtime, we use a sniffer that will determine
11754 the runtime variant used by the program being debugged. */
11756 /* Ada's standard exceptions.
11758 The Ada 83 standard also defined Numeric_Error. But there so many
11759 situations where it was unclear from the Ada 83 Reference Manual
11760 (RM) whether Constraint_Error or Numeric_Error should be raised,
11761 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11762 Interpretation saying that anytime the RM says that Numeric_Error
11763 should be raised, the implementation may raise Constraint_Error.
11764 Ada 95 went one step further and pretty much removed Numeric_Error
11765 from the list of standard exceptions (it made it a renaming of
11766 Constraint_Error, to help preserve compatibility when compiling
11767 an Ada83 compiler). As such, we do not include Numeric_Error from
11768 this list of standard exceptions. */
11770 static const char *standard_exc[] = {
11771 "constraint_error",
11777 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
11779 /* A structure that describes how to support exception catchpoints
11780 for a given executable. */
11782 struct exception_support_info
11784 /* The name of the symbol to break on in order to insert
11785 a catchpoint on exceptions. */
11786 const char *catch_exception_sym;
11788 /* The name of the symbol to break on in order to insert
11789 a catchpoint on unhandled exceptions. */
11790 const char *catch_exception_unhandled_sym;
11792 /* The name of the symbol to break on in order to insert
11793 a catchpoint on failed assertions. */
11794 const char *catch_assert_sym;
11796 /* Assuming that the inferior just triggered an unhandled exception
11797 catchpoint, this function is responsible for returning the address
11798 in inferior memory where the name of that exception is stored.
11799 Return zero if the address could not be computed. */
11800 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11803 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11804 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11806 /* The following exception support info structure describes how to
11807 implement exception catchpoints with the latest version of the
11808 Ada runtime (as of 2007-03-06). */
11810 static const struct exception_support_info default_exception_support_info =
11812 "__gnat_debug_raise_exception", /* catch_exception_sym */
11813 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11814 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11815 ada_unhandled_exception_name_addr
11818 /* The following exception support info structure describes how to
11819 implement exception catchpoints with a slightly older version
11820 of the Ada runtime. */
11822 static const struct exception_support_info exception_support_info_fallback =
11824 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11825 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11826 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11827 ada_unhandled_exception_name_addr_from_raise
11830 /* Return nonzero if we can detect the exception support routines
11831 described in EINFO.
11833 This function errors out if an abnormal situation is detected
11834 (for instance, if we find the exception support routines, but
11835 that support is found to be incomplete). */
11838 ada_has_this_exception_support (const struct exception_support_info *einfo)
11840 struct symbol *sym;
11842 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11843 that should be compiled with debugging information. As a result, we
11844 expect to find that symbol in the symtabs. */
11846 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11849 /* Perhaps we did not find our symbol because the Ada runtime was
11850 compiled without debugging info, or simply stripped of it.
11851 It happens on some GNU/Linux distributions for instance, where
11852 users have to install a separate debug package in order to get
11853 the runtime's debugging info. In that situation, let the user
11854 know why we cannot insert an Ada exception catchpoint.
11856 Note: Just for the purpose of inserting our Ada exception
11857 catchpoint, we could rely purely on the associated minimal symbol.
11858 But we would be operating in degraded mode anyway, since we are
11859 still lacking the debugging info needed later on to extract
11860 the name of the exception being raised (this name is printed in
11861 the catchpoint message, and is also used when trying to catch
11862 a specific exception). We do not handle this case for now. */
11863 struct bound_minimal_symbol msym
11864 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11866 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11867 error (_("Your Ada runtime appears to be missing some debugging "
11868 "information.\nCannot insert Ada exception catchpoint "
11869 "in this configuration."));
11874 /* Make sure that the symbol we found corresponds to a function. */
11876 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11877 error (_("Symbol \"%s\" is not a function (class = %d)"),
11878 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11883 /* Inspect the Ada runtime and determine which exception info structure
11884 should be used to provide support for exception catchpoints.
11886 This function will always set the per-inferior exception_info,
11887 or raise an error. */
11890 ada_exception_support_info_sniffer (void)
11892 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11894 /* If the exception info is already known, then no need to recompute it. */
11895 if (data->exception_info != NULL)
11898 /* Check the latest (default) exception support info. */
11899 if (ada_has_this_exception_support (&default_exception_support_info))
11901 data->exception_info = &default_exception_support_info;
11905 /* Try our fallback exception suport info. */
11906 if (ada_has_this_exception_support (&exception_support_info_fallback))
11908 data->exception_info = &exception_support_info_fallback;
11912 /* Sometimes, it is normal for us to not be able to find the routine
11913 we are looking for. This happens when the program is linked with
11914 the shared version of the GNAT runtime, and the program has not been
11915 started yet. Inform the user of these two possible causes if
11918 if (ada_update_initial_language (language_unknown) != language_ada)
11919 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11921 /* If the symbol does not exist, then check that the program is
11922 already started, to make sure that shared libraries have been
11923 loaded. If it is not started, this may mean that the symbol is
11924 in a shared library. */
11926 if (ptid_get_pid (inferior_ptid) == 0)
11927 error (_("Unable to insert catchpoint. Try to start the program first."));
11929 /* At this point, we know that we are debugging an Ada program and
11930 that the inferior has been started, but we still are not able to
11931 find the run-time symbols. That can mean that we are in
11932 configurable run time mode, or that a-except as been optimized
11933 out by the linker... In any case, at this point it is not worth
11934 supporting this feature. */
11936 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11939 /* True iff FRAME is very likely to be that of a function that is
11940 part of the runtime system. This is all very heuristic, but is
11941 intended to be used as advice as to what frames are uninteresting
11945 is_known_support_routine (struct frame_info *frame)
11947 enum language func_lang;
11949 const char *fullname;
11951 /* If this code does not have any debugging information (no symtab),
11952 This cannot be any user code. */
11954 symtab_and_line sal = find_frame_sal (frame);
11955 if (sal.symtab == NULL)
11958 /* If there is a symtab, but the associated source file cannot be
11959 located, then assume this is not user code: Selecting a frame
11960 for which we cannot display the code would not be very helpful
11961 for the user. This should also take care of case such as VxWorks
11962 where the kernel has some debugging info provided for a few units. */
11964 fullname = symtab_to_fullname (sal.symtab);
11965 if (access (fullname, R_OK) != 0)
11968 /* Check the unit filename againt the Ada runtime file naming.
11969 We also check the name of the objfile against the name of some
11970 known system libraries that sometimes come with debugging info
11973 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11975 re_comp (known_runtime_file_name_patterns[i]);
11976 if (re_exec (lbasename (sal.symtab->filename)))
11978 if (SYMTAB_OBJFILE (sal.symtab) != NULL
11979 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
11983 /* Check whether the function is a GNAT-generated entity. */
11985 gdb::unique_xmalloc_ptr<char> func_name
11986 = find_frame_funname (frame, &func_lang, NULL);
11987 if (func_name == NULL)
11990 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11992 re_comp (known_auxiliary_function_name_patterns[i]);
11993 if (re_exec (func_name.get ()))
12000 /* Find the first frame that contains debugging information and that is not
12001 part of the Ada run-time, starting from FI and moving upward. */
12004 ada_find_printable_frame (struct frame_info *fi)
12006 for (; fi != NULL; fi = get_prev_frame (fi))
12008 if (!is_known_support_routine (fi))
12017 /* Assuming that the inferior just triggered an unhandled exception
12018 catchpoint, return the address in inferior memory where the name
12019 of the exception is stored.
12021 Return zero if the address could not be computed. */
12024 ada_unhandled_exception_name_addr (void)
12026 return parse_and_eval_address ("e.full_name");
12029 /* Same as ada_unhandled_exception_name_addr, except that this function
12030 should be used when the inferior uses an older version of the runtime,
12031 where the exception name needs to be extracted from a specific frame
12032 several frames up in the callstack. */
12035 ada_unhandled_exception_name_addr_from_raise (void)
12038 struct frame_info *fi;
12039 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12041 /* To determine the name of this exception, we need to select
12042 the frame corresponding to RAISE_SYM_NAME. This frame is
12043 at least 3 levels up, so we simply skip the first 3 frames
12044 without checking the name of their associated function. */
12045 fi = get_current_frame ();
12046 for (frame_level = 0; frame_level < 3; frame_level += 1)
12048 fi = get_prev_frame (fi);
12052 enum language func_lang;
12054 gdb::unique_xmalloc_ptr<char> func_name
12055 = find_frame_funname (fi, &func_lang, NULL);
12056 if (func_name != NULL)
12058 if (strcmp (func_name.get (),
12059 data->exception_info->catch_exception_sym) == 0)
12060 break; /* We found the frame we were looking for... */
12061 fi = get_prev_frame (fi);
12069 return parse_and_eval_address ("id.full_name");
12072 /* Assuming the inferior just triggered an Ada exception catchpoint
12073 (of any type), return the address in inferior memory where the name
12074 of the exception is stored, if applicable.
12076 Assumes the selected frame is the current frame.
12078 Return zero if the address could not be computed, or if not relevant. */
12081 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
12082 struct breakpoint *b)
12084 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12088 case ada_catch_exception:
12089 return (parse_and_eval_address ("e.full_name"));
12092 case ada_catch_exception_unhandled:
12093 return data->exception_info->unhandled_exception_name_addr ();
12096 case ada_catch_assert:
12097 return 0; /* Exception name is not relevant in this case. */
12101 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12105 return 0; /* Should never be reached. */
12108 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12109 any error that ada_exception_name_addr_1 might cause to be thrown.
12110 When an error is intercepted, a warning with the error message is printed,
12111 and zero is returned. */
12114 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
12115 struct breakpoint *b)
12117 CORE_ADDR result = 0;
12121 result = ada_exception_name_addr_1 (ex, b);
12124 CATCH (e, RETURN_MASK_ERROR)
12126 warning (_("failed to get exception name: %s"), e.message);
12134 static char *ada_exception_catchpoint_cond_string (const char *excep_string);
12136 /* Ada catchpoints.
12138 In the case of catchpoints on Ada exceptions, the catchpoint will
12139 stop the target on every exception the program throws. When a user
12140 specifies the name of a specific exception, we translate this
12141 request into a condition expression (in text form), and then parse
12142 it into an expression stored in each of the catchpoint's locations.
12143 We then use this condition to check whether the exception that was
12144 raised is the one the user is interested in. If not, then the
12145 target is resumed again. We store the name of the requested
12146 exception, in order to be able to re-set the condition expression
12147 when symbols change. */
12149 /* An instance of this type is used to represent an Ada catchpoint
12150 breakpoint location. */
12152 class ada_catchpoint_location : public bp_location
12155 ada_catchpoint_location (const bp_location_ops *ops, breakpoint *owner)
12156 : bp_location (ops, owner)
12159 /* The condition that checks whether the exception that was raised
12160 is the specific exception the user specified on catchpoint
12162 expression_up excep_cond_expr;
12165 /* Implement the DTOR method in the bp_location_ops structure for all
12166 Ada exception catchpoint kinds. */
12169 ada_catchpoint_location_dtor (struct bp_location *bl)
12171 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12173 al->excep_cond_expr.reset ();
12176 /* The vtable to be used in Ada catchpoint locations. */
12178 static const struct bp_location_ops ada_catchpoint_location_ops =
12180 ada_catchpoint_location_dtor
12183 /* An instance of this type is used to represent an Ada catchpoint. */
12185 struct ada_catchpoint : public breakpoint
12187 ~ada_catchpoint () override;
12189 /* The name of the specific exception the user specified. */
12190 char *excep_string;
12193 /* Parse the exception condition string in the context of each of the
12194 catchpoint's locations, and store them for later evaluation. */
12197 create_excep_cond_exprs (struct ada_catchpoint *c)
12199 struct cleanup *old_chain;
12200 struct bp_location *bl;
12203 /* Nothing to do if there's no specific exception to catch. */
12204 if (c->excep_string == NULL)
12207 /* Same if there are no locations... */
12208 if (c->loc == NULL)
12211 /* Compute the condition expression in text form, from the specific
12212 expection we want to catch. */
12213 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
12214 old_chain = make_cleanup (xfree, cond_string);
12216 /* Iterate over all the catchpoint's locations, and parse an
12217 expression for each. */
12218 for (bl = c->loc; bl != NULL; bl = bl->next)
12220 struct ada_catchpoint_location *ada_loc
12221 = (struct ada_catchpoint_location *) bl;
12224 if (!bl->shlib_disabled)
12231 exp = parse_exp_1 (&s, bl->address,
12232 block_for_pc (bl->address),
12235 CATCH (e, RETURN_MASK_ERROR)
12237 warning (_("failed to reevaluate internal exception condition "
12238 "for catchpoint %d: %s"),
12239 c->number, e.message);
12244 ada_loc->excep_cond_expr = std::move (exp);
12247 do_cleanups (old_chain);
12250 /* ada_catchpoint destructor. */
12252 ada_catchpoint::~ada_catchpoint ()
12254 xfree (this->excep_string);
12257 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12258 structure for all exception catchpoint kinds. */
12260 static struct bp_location *
12261 allocate_location_exception (enum ada_exception_catchpoint_kind ex,
12262 struct breakpoint *self)
12264 return new ada_catchpoint_location (&ada_catchpoint_location_ops, self);
12267 /* Implement the RE_SET method in the breakpoint_ops structure for all
12268 exception catchpoint kinds. */
12271 re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
12273 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12275 /* Call the base class's method. This updates the catchpoint's
12277 bkpt_breakpoint_ops.re_set (b);
12279 /* Reparse the exception conditional expressions. One for each
12281 create_excep_cond_exprs (c);
12284 /* Returns true if we should stop for this breakpoint hit. If the
12285 user specified a specific exception, we only want to cause a stop
12286 if the program thrown that exception. */
12289 should_stop_exception (const struct bp_location *bl)
12291 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12292 const struct ada_catchpoint_location *ada_loc
12293 = (const struct ada_catchpoint_location *) bl;
12296 /* With no specific exception, should always stop. */
12297 if (c->excep_string == NULL)
12300 if (ada_loc->excep_cond_expr == NULL)
12302 /* We will have a NULL expression if back when we were creating
12303 the expressions, this location's had failed to parse. */
12310 struct value *mark;
12312 mark = value_mark ();
12313 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12314 value_free_to_mark (mark);
12316 CATCH (ex, RETURN_MASK_ALL)
12318 exception_fprintf (gdb_stderr, ex,
12319 _("Error in testing exception condition:\n"));
12326 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12327 for all exception catchpoint kinds. */
12330 check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12332 bs->stop = should_stop_exception (bs->bp_location_at);
12335 /* Implement the PRINT_IT method in the breakpoint_ops structure
12336 for all exception catchpoint kinds. */
12338 static enum print_stop_action
12339 print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12341 struct ui_out *uiout = current_uiout;
12342 struct breakpoint *b = bs->breakpoint_at;
12344 annotate_catchpoint (b->number);
12346 if (uiout->is_mi_like_p ())
12348 uiout->field_string ("reason",
12349 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12350 uiout->field_string ("disp", bpdisp_text (b->disposition));
12353 uiout->text (b->disposition == disp_del
12354 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12355 uiout->field_int ("bkptno", b->number);
12356 uiout->text (", ");
12358 /* ada_exception_name_addr relies on the selected frame being the
12359 current frame. Need to do this here because this function may be
12360 called more than once when printing a stop, and below, we'll
12361 select the first frame past the Ada run-time (see
12362 ada_find_printable_frame). */
12363 select_frame (get_current_frame ());
12367 case ada_catch_exception:
12368 case ada_catch_exception_unhandled:
12370 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12371 char exception_name[256];
12375 read_memory (addr, (gdb_byte *) exception_name,
12376 sizeof (exception_name) - 1);
12377 exception_name [sizeof (exception_name) - 1] = '\0';
12381 /* For some reason, we were unable to read the exception
12382 name. This could happen if the Runtime was compiled
12383 without debugging info, for instance. In that case,
12384 just replace the exception name by the generic string
12385 "exception" - it will read as "an exception" in the
12386 notification we are about to print. */
12387 memcpy (exception_name, "exception", sizeof ("exception"));
12389 /* In the case of unhandled exception breakpoints, we print
12390 the exception name as "unhandled EXCEPTION_NAME", to make
12391 it clearer to the user which kind of catchpoint just got
12392 hit. We used ui_out_text to make sure that this extra
12393 info does not pollute the exception name in the MI case. */
12394 if (ex == ada_catch_exception_unhandled)
12395 uiout->text ("unhandled ");
12396 uiout->field_string ("exception-name", exception_name);
12399 case ada_catch_assert:
12400 /* In this case, the name of the exception is not really
12401 important. Just print "failed assertion" to make it clearer
12402 that his program just hit an assertion-failure catchpoint.
12403 We used ui_out_text because this info does not belong in
12405 uiout->text ("failed assertion");
12408 uiout->text (" at ");
12409 ada_find_printable_frame (get_current_frame ());
12411 return PRINT_SRC_AND_LOC;
12414 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12415 for all exception catchpoint kinds. */
12418 print_one_exception (enum ada_exception_catchpoint_kind ex,
12419 struct breakpoint *b, struct bp_location **last_loc)
12421 struct ui_out *uiout = current_uiout;
12422 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12423 struct value_print_options opts;
12425 get_user_print_options (&opts);
12426 if (opts.addressprint)
12428 annotate_field (4);
12429 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
12432 annotate_field (5);
12433 *last_loc = b->loc;
12436 case ada_catch_exception:
12437 if (c->excep_string != NULL)
12439 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12441 uiout->field_string ("what", msg);
12445 uiout->field_string ("what", "all Ada exceptions");
12449 case ada_catch_exception_unhandled:
12450 uiout->field_string ("what", "unhandled Ada exceptions");
12453 case ada_catch_assert:
12454 uiout->field_string ("what", "failed Ada assertions");
12458 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12463 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12464 for all exception catchpoint kinds. */
12467 print_mention_exception (enum ada_exception_catchpoint_kind ex,
12468 struct breakpoint *b)
12470 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12471 struct ui_out *uiout = current_uiout;
12473 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
12474 : _("Catchpoint "));
12475 uiout->field_int ("bkptno", b->number);
12476 uiout->text (": ");
12480 case ada_catch_exception:
12481 if (c->excep_string != NULL)
12483 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12484 struct cleanup *old_chain = make_cleanup (xfree, info);
12486 uiout->text (info);
12487 do_cleanups (old_chain);
12490 uiout->text (_("all Ada exceptions"));
12493 case ada_catch_exception_unhandled:
12494 uiout->text (_("unhandled Ada exceptions"));
12497 case ada_catch_assert:
12498 uiout->text (_("failed Ada assertions"));
12502 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12507 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12508 for all exception catchpoint kinds. */
12511 print_recreate_exception (enum ada_exception_catchpoint_kind ex,
12512 struct breakpoint *b, struct ui_file *fp)
12514 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12518 case ada_catch_exception:
12519 fprintf_filtered (fp, "catch exception");
12520 if (c->excep_string != NULL)
12521 fprintf_filtered (fp, " %s", c->excep_string);
12524 case ada_catch_exception_unhandled:
12525 fprintf_filtered (fp, "catch exception unhandled");
12528 case ada_catch_assert:
12529 fprintf_filtered (fp, "catch assert");
12533 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12535 print_recreate_thread (b, fp);
12538 /* Virtual table for "catch exception" breakpoints. */
12540 static struct bp_location *
12541 allocate_location_catch_exception (struct breakpoint *self)
12543 return allocate_location_exception (ada_catch_exception, self);
12547 re_set_catch_exception (struct breakpoint *b)
12549 re_set_exception (ada_catch_exception, b);
12553 check_status_catch_exception (bpstat bs)
12555 check_status_exception (ada_catch_exception, bs);
12558 static enum print_stop_action
12559 print_it_catch_exception (bpstat bs)
12561 return print_it_exception (ada_catch_exception, bs);
12565 print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
12567 print_one_exception (ada_catch_exception, b, last_loc);
12571 print_mention_catch_exception (struct breakpoint *b)
12573 print_mention_exception (ada_catch_exception, b);
12577 print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12579 print_recreate_exception (ada_catch_exception, b, fp);
12582 static struct breakpoint_ops catch_exception_breakpoint_ops;
12584 /* Virtual table for "catch exception unhandled" breakpoints. */
12586 static struct bp_location *
12587 allocate_location_catch_exception_unhandled (struct breakpoint *self)
12589 return allocate_location_exception (ada_catch_exception_unhandled, self);
12593 re_set_catch_exception_unhandled (struct breakpoint *b)
12595 re_set_exception (ada_catch_exception_unhandled, b);
12599 check_status_catch_exception_unhandled (bpstat bs)
12601 check_status_exception (ada_catch_exception_unhandled, bs);
12604 static enum print_stop_action
12605 print_it_catch_exception_unhandled (bpstat bs)
12607 return print_it_exception (ada_catch_exception_unhandled, bs);
12611 print_one_catch_exception_unhandled (struct breakpoint *b,
12612 struct bp_location **last_loc)
12614 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
12618 print_mention_catch_exception_unhandled (struct breakpoint *b)
12620 print_mention_exception (ada_catch_exception_unhandled, b);
12624 print_recreate_catch_exception_unhandled (struct breakpoint *b,
12625 struct ui_file *fp)
12627 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
12630 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
12632 /* Virtual table for "catch assert" breakpoints. */
12634 static struct bp_location *
12635 allocate_location_catch_assert (struct breakpoint *self)
12637 return allocate_location_exception (ada_catch_assert, self);
12641 re_set_catch_assert (struct breakpoint *b)
12643 re_set_exception (ada_catch_assert, b);
12647 check_status_catch_assert (bpstat bs)
12649 check_status_exception (ada_catch_assert, bs);
12652 static enum print_stop_action
12653 print_it_catch_assert (bpstat bs)
12655 return print_it_exception (ada_catch_assert, bs);
12659 print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
12661 print_one_exception (ada_catch_assert, b, last_loc);
12665 print_mention_catch_assert (struct breakpoint *b)
12667 print_mention_exception (ada_catch_assert, b);
12671 print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
12673 print_recreate_exception (ada_catch_assert, b, fp);
12676 static struct breakpoint_ops catch_assert_breakpoint_ops;
12678 /* Return a newly allocated copy of the first space-separated token
12679 in ARGSP, and then adjust ARGSP to point immediately after that
12682 Return NULL if ARGPS does not contain any more tokens. */
12685 ada_get_next_arg (const char **argsp)
12687 const char *args = *argsp;
12691 args = skip_spaces (args);
12692 if (args[0] == '\0')
12693 return NULL; /* No more arguments. */
12695 /* Find the end of the current argument. */
12697 end = skip_to_space (args);
12699 /* Adjust ARGSP to point to the start of the next argument. */
12703 /* Make a copy of the current argument and return it. */
12705 result = (char *) xmalloc (end - args + 1);
12706 strncpy (result, args, end - args);
12707 result[end - args] = '\0';
12712 /* Split the arguments specified in a "catch exception" command.
12713 Set EX to the appropriate catchpoint type.
12714 Set EXCEP_STRING to the name of the specific exception if
12715 specified by the user.
12716 If a condition is found at the end of the arguments, the condition
12717 expression is stored in COND_STRING (memory must be deallocated
12718 after use). Otherwise COND_STRING is set to NULL. */
12721 catch_ada_exception_command_split (const char *args,
12722 enum ada_exception_catchpoint_kind *ex,
12723 char **excep_string,
12724 char **cond_string)
12726 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
12727 char *exception_name;
12730 exception_name = ada_get_next_arg (&args);
12731 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
12733 /* This is not an exception name; this is the start of a condition
12734 expression for a catchpoint on all exceptions. So, "un-get"
12735 this token, and set exception_name to NULL. */
12736 xfree (exception_name);
12737 exception_name = NULL;
12740 make_cleanup (xfree, exception_name);
12742 /* Check to see if we have a condition. */
12744 args = skip_spaces (args);
12745 if (startswith (args, "if")
12746 && (isspace (args[2]) || args[2] == '\0'))
12749 args = skip_spaces (args);
12751 if (args[0] == '\0')
12752 error (_("Condition missing after `if' keyword"));
12753 cond = xstrdup (args);
12754 make_cleanup (xfree, cond);
12756 args += strlen (args);
12759 /* Check that we do not have any more arguments. Anything else
12762 if (args[0] != '\0')
12763 error (_("Junk at end of expression"));
12765 discard_cleanups (old_chain);
12767 if (exception_name == NULL)
12769 /* Catch all exceptions. */
12770 *ex = ada_catch_exception;
12771 *excep_string = NULL;
12773 else if (strcmp (exception_name, "unhandled") == 0)
12775 /* Catch unhandled exceptions. */
12776 *ex = ada_catch_exception_unhandled;
12777 *excep_string = NULL;
12781 /* Catch a specific exception. */
12782 *ex = ada_catch_exception;
12783 *excep_string = exception_name;
12785 *cond_string = cond;
12788 /* Return the name of the symbol on which we should break in order to
12789 implement a catchpoint of the EX kind. */
12791 static const char *
12792 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12794 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12796 gdb_assert (data->exception_info != NULL);
12800 case ada_catch_exception:
12801 return (data->exception_info->catch_exception_sym);
12803 case ada_catch_exception_unhandled:
12804 return (data->exception_info->catch_exception_unhandled_sym);
12806 case ada_catch_assert:
12807 return (data->exception_info->catch_assert_sym);
12810 internal_error (__FILE__, __LINE__,
12811 _("unexpected catchpoint kind (%d)"), ex);
12815 /* Return the breakpoint ops "virtual table" used for catchpoints
12818 static const struct breakpoint_ops *
12819 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
12823 case ada_catch_exception:
12824 return (&catch_exception_breakpoint_ops);
12826 case ada_catch_exception_unhandled:
12827 return (&catch_exception_unhandled_breakpoint_ops);
12829 case ada_catch_assert:
12830 return (&catch_assert_breakpoint_ops);
12833 internal_error (__FILE__, __LINE__,
12834 _("unexpected catchpoint kind (%d)"), ex);
12838 /* Return the condition that will be used to match the current exception
12839 being raised with the exception that the user wants to catch. This
12840 assumes that this condition is used when the inferior just triggered
12841 an exception catchpoint.
12843 The string returned is a newly allocated string that needs to be
12844 deallocated later. */
12847 ada_exception_catchpoint_cond_string (const char *excep_string)
12851 /* The standard exceptions are a special case. They are defined in
12852 runtime units that have been compiled without debugging info; if
12853 EXCEP_STRING is the not-fully-qualified name of a standard
12854 exception (e.g. "constraint_error") then, during the evaluation
12855 of the condition expression, the symbol lookup on this name would
12856 *not* return this standard exception. The catchpoint condition
12857 may then be set only on user-defined exceptions which have the
12858 same not-fully-qualified name (e.g. my_package.constraint_error).
12860 To avoid this unexcepted behavior, these standard exceptions are
12861 systematically prefixed by "standard". This means that "catch
12862 exception constraint_error" is rewritten into "catch exception
12863 standard.constraint_error".
12865 If an exception named contraint_error is defined in another package of
12866 the inferior program, then the only way to specify this exception as a
12867 breakpoint condition is to use its fully-qualified named:
12868 e.g. my_package.constraint_error. */
12870 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12872 if (strcmp (standard_exc [i], excep_string) == 0)
12874 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
12878 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
12881 /* Return the symtab_and_line that should be used to insert an exception
12882 catchpoint of the TYPE kind.
12884 EXCEP_STRING should contain the name of a specific exception that
12885 the catchpoint should catch, or NULL otherwise.
12887 ADDR_STRING returns the name of the function where the real
12888 breakpoint that implements the catchpoints is set, depending on the
12889 type of catchpoint we need to create. */
12891 static struct symtab_and_line
12892 ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
12893 const char **addr_string, const struct breakpoint_ops **ops)
12895 const char *sym_name;
12896 struct symbol *sym;
12898 /* First, find out which exception support info to use. */
12899 ada_exception_support_info_sniffer ();
12901 /* Then lookup the function on which we will break in order to catch
12902 the Ada exceptions requested by the user. */
12903 sym_name = ada_exception_sym_name (ex);
12904 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12906 /* We can assume that SYM is not NULL at this stage. If the symbol
12907 did not exist, ada_exception_support_info_sniffer would have
12908 raised an exception.
12910 Also, ada_exception_support_info_sniffer should have already
12911 verified that SYM is a function symbol. */
12912 gdb_assert (sym != NULL);
12913 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
12915 /* Set ADDR_STRING. */
12916 *addr_string = xstrdup (sym_name);
12919 *ops = ada_exception_breakpoint_ops (ex);
12921 return find_function_start_sal (sym, 1);
12924 /* Create an Ada exception catchpoint.
12926 EX_KIND is the kind of exception catchpoint to be created.
12928 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12929 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12930 of the exception to which this catchpoint applies. When not NULL,
12931 the string must be allocated on the heap, and its deallocation
12932 is no longer the responsibility of the caller.
12934 COND_STRING, if not NULL, is the catchpoint condition. This string
12935 must be allocated on the heap, and its deallocation is no longer
12936 the responsibility of the caller.
12938 TEMPFLAG, if nonzero, means that the underlying breakpoint
12939 should be temporary.
12941 FROM_TTY is the usual argument passed to all commands implementations. */
12944 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12945 enum ada_exception_catchpoint_kind ex_kind,
12946 char *excep_string,
12952 const char *addr_string = NULL;
12953 const struct breakpoint_ops *ops = NULL;
12954 struct symtab_and_line sal
12955 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
12957 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
12958 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string,
12959 ops, tempflag, disabled, from_tty);
12960 c->excep_string = excep_string;
12961 create_excep_cond_exprs (c.get ());
12962 if (cond_string != NULL)
12963 set_breakpoint_condition (c.get (), cond_string, from_tty);
12964 install_breakpoint (0, std::move (c), 1);
12967 /* Implement the "catch exception" command. */
12970 catch_ada_exception_command (const char *arg_entry, int from_tty,
12971 struct cmd_list_element *command)
12973 const char *arg = arg_entry;
12974 struct gdbarch *gdbarch = get_current_arch ();
12976 enum ada_exception_catchpoint_kind ex_kind;
12977 char *excep_string = NULL;
12978 char *cond_string = NULL;
12980 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12984 catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
12986 create_ada_exception_catchpoint (gdbarch, ex_kind,
12987 excep_string, cond_string,
12988 tempflag, 1 /* enabled */,
12992 /* Split the arguments specified in a "catch assert" command.
12994 ARGS contains the command's arguments (or the empty string if
12995 no arguments were passed).
12997 If ARGS contains a condition, set COND_STRING to that condition
12998 (the memory needs to be deallocated after use). */
13001 catch_ada_assert_command_split (const char *args, char **cond_string)
13003 args = skip_spaces (args);
13005 /* Check whether a condition was provided. */
13006 if (startswith (args, "if")
13007 && (isspace (args[2]) || args[2] == '\0'))
13010 args = skip_spaces (args);
13011 if (args[0] == '\0')
13012 error (_("condition missing after `if' keyword"));
13013 *cond_string = xstrdup (args);
13016 /* Otherwise, there should be no other argument at the end of
13018 else if (args[0] != '\0')
13019 error (_("Junk at end of arguments."));
13022 /* Implement the "catch assert" command. */
13025 catch_assert_command (const char *arg_entry, int from_tty,
13026 struct cmd_list_element *command)
13028 const char *arg = arg_entry;
13029 struct gdbarch *gdbarch = get_current_arch ();
13031 char *cond_string = NULL;
13033 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13037 catch_ada_assert_command_split (arg, &cond_string);
13038 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
13040 tempflag, 1 /* enabled */,
13044 /* Return non-zero if the symbol SYM is an Ada exception object. */
13047 ada_is_exception_sym (struct symbol *sym)
13049 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
13051 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13052 && SYMBOL_CLASS (sym) != LOC_BLOCK
13053 && SYMBOL_CLASS (sym) != LOC_CONST
13054 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13055 && type_name != NULL && strcmp (type_name, "exception") == 0);
13058 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13059 Ada exception object. This matches all exceptions except the ones
13060 defined by the Ada language. */
13063 ada_is_non_standard_exception_sym (struct symbol *sym)
13067 if (!ada_is_exception_sym (sym))
13070 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13071 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13072 return 0; /* A standard exception. */
13074 /* Numeric_Error is also a standard exception, so exclude it.
13075 See the STANDARD_EXC description for more details as to why
13076 this exception is not listed in that array. */
13077 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13083 /* A helper function for std::sort, comparing two struct ada_exc_info
13086 The comparison is determined first by exception name, and then
13087 by exception address. */
13090 ada_exc_info::operator< (const ada_exc_info &other) const
13094 result = strcmp (name, other.name);
13097 if (result == 0 && addr < other.addr)
13103 ada_exc_info::operator== (const ada_exc_info &other) const
13105 return addr == other.addr && strcmp (name, other.name) == 0;
13108 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13109 routine, but keeping the first SKIP elements untouched.
13111 All duplicates are also removed. */
13114 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13117 std::sort (exceptions->begin () + skip, exceptions->end ());
13118 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13119 exceptions->end ());
13122 /* Add all exceptions defined by the Ada standard whose name match
13123 a regular expression.
13125 If PREG is not NULL, then this regexp_t object is used to
13126 perform the symbol name matching. Otherwise, no name-based
13127 filtering is performed.
13129 EXCEPTIONS is a vector of exceptions to which matching exceptions
13133 ada_add_standard_exceptions (compiled_regex *preg,
13134 std::vector<ada_exc_info> *exceptions)
13138 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13141 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
13143 struct bound_minimal_symbol msymbol
13144 = ada_lookup_simple_minsym (standard_exc[i]);
13146 if (msymbol.minsym != NULL)
13148 struct ada_exc_info info
13149 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
13151 exceptions->push_back (info);
13157 /* Add all Ada exceptions defined locally and accessible from the given
13160 If PREG is not NULL, then this regexp_t object is used to
13161 perform the symbol name matching. Otherwise, no name-based
13162 filtering is performed.
13164 EXCEPTIONS is a vector of exceptions to which matching exceptions
13168 ada_add_exceptions_from_frame (compiled_regex *preg,
13169 struct frame_info *frame,
13170 std::vector<ada_exc_info> *exceptions)
13172 const struct block *block = get_frame_block (frame, 0);
13176 struct block_iterator iter;
13177 struct symbol *sym;
13179 ALL_BLOCK_SYMBOLS (block, iter, sym)
13181 switch (SYMBOL_CLASS (sym))
13188 if (ada_is_exception_sym (sym))
13190 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13191 SYMBOL_VALUE_ADDRESS (sym)};
13193 exceptions->push_back (info);
13197 if (BLOCK_FUNCTION (block) != NULL)
13199 block = BLOCK_SUPERBLOCK (block);
13203 /* Return true if NAME matches PREG or if PREG is NULL. */
13206 name_matches_regex (const char *name, compiled_regex *preg)
13208 return (preg == NULL
13209 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
13212 /* Add all exceptions defined globally whose name name match
13213 a regular expression, excluding standard exceptions.
13215 The reason we exclude standard exceptions is that they need
13216 to be handled separately: Standard exceptions are defined inside
13217 a runtime unit which is normally not compiled with debugging info,
13218 and thus usually do not show up in our symbol search. However,
13219 if the unit was in fact built with debugging info, we need to
13220 exclude them because they would duplicate the entry we found
13221 during the special loop that specifically searches for those
13222 standard exceptions.
13224 If PREG is not NULL, then this regexp_t object is used to
13225 perform the symbol name matching. Otherwise, no name-based
13226 filtering is performed.
13228 EXCEPTIONS is a vector of exceptions to which matching exceptions
13232 ada_add_global_exceptions (compiled_regex *preg,
13233 std::vector<ada_exc_info> *exceptions)
13235 struct objfile *objfile;
13236 struct compunit_symtab *s;
13238 /* In Ada, the symbol "search name" is a linkage name, whereas the
13239 regular expression used to do the matching refers to the natural
13240 name. So match against the decoded name. */
13241 expand_symtabs_matching (NULL,
13242 lookup_name_info::match_any (),
13243 [&] (const char *search_name)
13245 const char *decoded = ada_decode (search_name);
13246 return name_matches_regex (decoded, preg);
13251 ALL_COMPUNITS (objfile, s)
13253 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
13256 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13258 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13259 struct block_iterator iter;
13260 struct symbol *sym;
13262 ALL_BLOCK_SYMBOLS (b, iter, sym)
13263 if (ada_is_non_standard_exception_sym (sym)
13264 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
13266 struct ada_exc_info info
13267 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13269 exceptions->push_back (info);
13275 /* Implements ada_exceptions_list with the regular expression passed
13276 as a regex_t, rather than a string.
13278 If not NULL, PREG is used to filter out exceptions whose names
13279 do not match. Otherwise, all exceptions are listed. */
13281 static std::vector<ada_exc_info>
13282 ada_exceptions_list_1 (compiled_regex *preg)
13284 std::vector<ada_exc_info> result;
13287 /* First, list the known standard exceptions. These exceptions
13288 need to be handled separately, as they are usually defined in
13289 runtime units that have been compiled without debugging info. */
13291 ada_add_standard_exceptions (preg, &result);
13293 /* Next, find all exceptions whose scope is local and accessible
13294 from the currently selected frame. */
13296 if (has_stack_frames ())
13298 prev_len = result.size ();
13299 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13301 if (result.size () > prev_len)
13302 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13305 /* Add all exceptions whose scope is global. */
13307 prev_len = result.size ();
13308 ada_add_global_exceptions (preg, &result);
13309 if (result.size () > prev_len)
13310 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13315 /* Return a vector of ada_exc_info.
13317 If REGEXP is NULL, all exceptions are included in the result.
13318 Otherwise, it should contain a valid regular expression,
13319 and only the exceptions whose names match that regular expression
13320 are included in the result.
13322 The exceptions are sorted in the following order:
13323 - Standard exceptions (defined by the Ada language), in
13324 alphabetical order;
13325 - Exceptions only visible from the current frame, in
13326 alphabetical order;
13327 - Exceptions whose scope is global, in alphabetical order. */
13329 std::vector<ada_exc_info>
13330 ada_exceptions_list (const char *regexp)
13332 if (regexp == NULL)
13333 return ada_exceptions_list_1 (NULL);
13335 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13336 return ada_exceptions_list_1 (®);
13339 /* Implement the "info exceptions" command. */
13342 info_exceptions_command (const char *regexp, int from_tty)
13344 struct gdbarch *gdbarch = get_current_arch ();
13346 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13348 if (regexp != NULL)
13350 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13352 printf_filtered (_("All defined Ada exceptions:\n"));
13354 for (const ada_exc_info &info : exceptions)
13355 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13359 /* Information about operators given special treatment in functions
13361 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13363 #define ADA_OPERATORS \
13364 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13365 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13366 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13367 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13368 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13369 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13370 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13371 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13372 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13373 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13374 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13375 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13376 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13377 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13378 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13379 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13380 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13381 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13382 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13385 ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13388 switch (exp->elts[pc - 1].opcode)
13391 operator_length_standard (exp, pc, oplenp, argsp);
13394 #define OP_DEFN(op, len, args, binop) \
13395 case op: *oplenp = len; *argsp = args; break;
13401 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13406 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13411 /* Implementation of the exp_descriptor method operator_check. */
13414 ada_operator_check (struct expression *exp, int pos,
13415 int (*objfile_func) (struct objfile *objfile, void *data),
13418 const union exp_element *const elts = exp->elts;
13419 struct type *type = NULL;
13421 switch (elts[pos].opcode)
13423 case UNOP_IN_RANGE:
13425 type = elts[pos + 1].type;
13429 return operator_check_standard (exp, pos, objfile_func, data);
13432 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13434 if (type && TYPE_OBJFILE (type)
13435 && (*objfile_func) (TYPE_OBJFILE (type), data))
13441 static const char *
13442 ada_op_name (enum exp_opcode opcode)
13447 return op_name_standard (opcode);
13449 #define OP_DEFN(op, len, args, binop) case op: return #op;
13454 return "OP_AGGREGATE";
13456 return "OP_CHOICES";
13462 /* As for operator_length, but assumes PC is pointing at the first
13463 element of the operator, and gives meaningful results only for the
13464 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13467 ada_forward_operator_length (struct expression *exp, int pc,
13468 int *oplenp, int *argsp)
13470 switch (exp->elts[pc].opcode)
13473 *oplenp = *argsp = 0;
13476 #define OP_DEFN(op, len, args, binop) \
13477 case op: *oplenp = len; *argsp = args; break;
13483 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13488 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13494 int len = longest_to_int (exp->elts[pc + 1].longconst);
13496 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13504 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13506 enum exp_opcode op = exp->elts[elt].opcode;
13511 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13515 /* Ada attributes ('Foo). */
13518 case OP_ATR_LENGTH:
13522 case OP_ATR_MODULUS:
13529 case UNOP_IN_RANGE:
13531 /* XXX: gdb_sprint_host_address, type_sprint */
13532 fprintf_filtered (stream, _("Type @"));
13533 gdb_print_host_address (exp->elts[pc + 1].type, stream);
13534 fprintf_filtered (stream, " (");
13535 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13536 fprintf_filtered (stream, ")");
13538 case BINOP_IN_BOUNDS:
13539 fprintf_filtered (stream, " (%d)",
13540 longest_to_int (exp->elts[pc + 2].longconst));
13542 case TERNOP_IN_RANGE:
13547 case OP_DISCRETE_RANGE:
13548 case OP_POSITIONAL:
13555 char *name = &exp->elts[elt + 2].string;
13556 int len = longest_to_int (exp->elts[elt + 1].longconst);
13558 fprintf_filtered (stream, "Text: `%.*s'", len, name);
13563 return dump_subexp_body_standard (exp, stream, elt);
13567 for (i = 0; i < nargs; i += 1)
13568 elt = dump_subexp (exp, stream, elt);
13573 /* The Ada extension of print_subexp (q.v.). */
13576 ada_print_subexp (struct expression *exp, int *pos,
13577 struct ui_file *stream, enum precedence prec)
13579 int oplen, nargs, i;
13581 enum exp_opcode op = exp->elts[pc].opcode;
13583 ada_forward_operator_length (exp, pc, &oplen, &nargs);
13590 print_subexp_standard (exp, pos, stream, prec);
13594 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13597 case BINOP_IN_BOUNDS:
13598 /* XXX: sprint_subexp */
13599 print_subexp (exp, pos, stream, PREC_SUFFIX);
13600 fputs_filtered (" in ", stream);
13601 print_subexp (exp, pos, stream, PREC_SUFFIX);
13602 fputs_filtered ("'range", stream);
13603 if (exp->elts[pc + 1].longconst > 1)
13604 fprintf_filtered (stream, "(%ld)",
13605 (long) exp->elts[pc + 1].longconst);
13608 case TERNOP_IN_RANGE:
13609 if (prec >= PREC_EQUAL)
13610 fputs_filtered ("(", stream);
13611 /* XXX: sprint_subexp */
13612 print_subexp (exp, pos, stream, PREC_SUFFIX);
13613 fputs_filtered (" in ", stream);
13614 print_subexp (exp, pos, stream, PREC_EQUAL);
13615 fputs_filtered (" .. ", stream);
13616 print_subexp (exp, pos, stream, PREC_EQUAL);
13617 if (prec >= PREC_EQUAL)
13618 fputs_filtered (")", stream);
13623 case OP_ATR_LENGTH:
13627 case OP_ATR_MODULUS:
13632 if (exp->elts[*pos].opcode == OP_TYPE)
13634 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
13635 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13636 &type_print_raw_options);
13640 print_subexp (exp, pos, stream, PREC_SUFFIX);
13641 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13646 for (tem = 1; tem < nargs; tem += 1)
13648 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13649 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13651 fputs_filtered (")", stream);
13656 type_print (exp->elts[pc + 1].type, "", stream, 0);
13657 fputs_filtered ("'(", stream);
13658 print_subexp (exp, pos, stream, PREC_PREFIX);
13659 fputs_filtered (")", stream);
13662 case UNOP_IN_RANGE:
13663 /* XXX: sprint_subexp */
13664 print_subexp (exp, pos, stream, PREC_SUFFIX);
13665 fputs_filtered (" in ", stream);
13666 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13667 &type_print_raw_options);
13670 case OP_DISCRETE_RANGE:
13671 print_subexp (exp, pos, stream, PREC_SUFFIX);
13672 fputs_filtered ("..", stream);
13673 print_subexp (exp, pos, stream, PREC_SUFFIX);
13677 fputs_filtered ("others => ", stream);
13678 print_subexp (exp, pos, stream, PREC_SUFFIX);
13682 for (i = 0; i < nargs-1; i += 1)
13685 fputs_filtered ("|", stream);
13686 print_subexp (exp, pos, stream, PREC_SUFFIX);
13688 fputs_filtered (" => ", stream);
13689 print_subexp (exp, pos, stream, PREC_SUFFIX);
13692 case OP_POSITIONAL:
13693 print_subexp (exp, pos, stream, PREC_SUFFIX);
13697 fputs_filtered ("(", stream);
13698 for (i = 0; i < nargs; i += 1)
13701 fputs_filtered (", ", stream);
13702 print_subexp (exp, pos, stream, PREC_SUFFIX);
13704 fputs_filtered (")", stream);
13709 /* Table mapping opcodes into strings for printing operators
13710 and precedences of the operators. */
13712 static const struct op_print ada_op_print_tab[] = {
13713 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13714 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13715 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13716 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13717 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13718 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13719 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13720 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13721 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13722 {">=", BINOP_GEQ, PREC_ORDER, 0},
13723 {">", BINOP_GTR, PREC_ORDER, 0},
13724 {"<", BINOP_LESS, PREC_ORDER, 0},
13725 {">>", BINOP_RSH, PREC_SHIFT, 0},
13726 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13727 {"+", BINOP_ADD, PREC_ADD, 0},
13728 {"-", BINOP_SUB, PREC_ADD, 0},
13729 {"&", BINOP_CONCAT, PREC_ADD, 0},
13730 {"*", BINOP_MUL, PREC_MUL, 0},
13731 {"/", BINOP_DIV, PREC_MUL, 0},
13732 {"rem", BINOP_REM, PREC_MUL, 0},
13733 {"mod", BINOP_MOD, PREC_MUL, 0},
13734 {"**", BINOP_EXP, PREC_REPEAT, 0},
13735 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13736 {"-", UNOP_NEG, PREC_PREFIX, 0},
13737 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13738 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13739 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13740 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
13741 {".all", UNOP_IND, PREC_SUFFIX, 1},
13742 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13743 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
13744 {NULL, OP_NULL, PREC_SUFFIX, 0}
13747 enum ada_primitive_types {
13748 ada_primitive_type_int,
13749 ada_primitive_type_long,
13750 ada_primitive_type_short,
13751 ada_primitive_type_char,
13752 ada_primitive_type_float,
13753 ada_primitive_type_double,
13754 ada_primitive_type_void,
13755 ada_primitive_type_long_long,
13756 ada_primitive_type_long_double,
13757 ada_primitive_type_natural,
13758 ada_primitive_type_positive,
13759 ada_primitive_type_system_address,
13760 nr_ada_primitive_types
13764 ada_language_arch_info (struct gdbarch *gdbarch,
13765 struct language_arch_info *lai)
13767 const struct builtin_type *builtin = builtin_type (gdbarch);
13769 lai->primitive_type_vector
13770 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
13773 lai->primitive_type_vector [ada_primitive_type_int]
13774 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13776 lai->primitive_type_vector [ada_primitive_type_long]
13777 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13778 0, "long_integer");
13779 lai->primitive_type_vector [ada_primitive_type_short]
13780 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13781 0, "short_integer");
13782 lai->string_char_type
13783 = lai->primitive_type_vector [ada_primitive_type_char]
13784 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
13785 lai->primitive_type_vector [ada_primitive_type_float]
13786 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13787 "float", gdbarch_float_format (gdbarch));
13788 lai->primitive_type_vector [ada_primitive_type_double]
13789 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13790 "long_float", gdbarch_double_format (gdbarch));
13791 lai->primitive_type_vector [ada_primitive_type_long_long]
13792 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13793 0, "long_long_integer");
13794 lai->primitive_type_vector [ada_primitive_type_long_double]
13795 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
13796 "long_long_float", gdbarch_long_double_format (gdbarch));
13797 lai->primitive_type_vector [ada_primitive_type_natural]
13798 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13800 lai->primitive_type_vector [ada_primitive_type_positive]
13801 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13803 lai->primitive_type_vector [ada_primitive_type_void]
13804 = builtin->builtin_void;
13806 lai->primitive_type_vector [ada_primitive_type_system_address]
13807 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
13809 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
13810 = "system__address";
13812 lai->bool_type_symbol = NULL;
13813 lai->bool_type_default = builtin->builtin_bool;
13816 /* Language vector */
13818 /* Not really used, but needed in the ada_language_defn. */
13821 emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
13823 ada_emit_char (c, type, stream, quoter, 1);
13827 parse (struct parser_state *ps)
13829 warnings_issued = 0;
13830 return ada_parse (ps);
13833 static const struct exp_descriptor ada_exp_descriptor = {
13835 ada_operator_length,
13836 ada_operator_check,
13838 ada_dump_subexp_body,
13839 ada_evaluate_subexp
13842 /* symbol_name_matcher_ftype adapter for wild_match. */
13845 do_wild_match (const char *symbol_search_name,
13846 const lookup_name_info &lookup_name,
13847 completion_match *match)
13849 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
13852 /* symbol_name_matcher_ftype adapter for full_match. */
13855 do_full_match (const char *symbol_search_name,
13856 const lookup_name_info &lookup_name,
13857 completion_match *match)
13859 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
13862 /* Build the Ada lookup name for LOOKUP_NAME. */
13864 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
13866 const std::string &user_name = lookup_name.name ();
13868 if (user_name[0] == '<')
13870 if (user_name.back () == '>')
13871 m_encoded_name = user_name.substr (1, user_name.size () - 2);
13873 m_encoded_name = user_name.substr (1, user_name.size () - 1);
13874 m_encoded_p = true;
13875 m_verbatim_p = true;
13876 m_wild_match_p = false;
13877 m_standard_p = false;
13881 m_verbatim_p = false;
13883 m_encoded_p = user_name.find ("__") != std::string::npos;
13887 const char *folded = ada_fold_name (user_name.c_str ());
13888 const char *encoded = ada_encode_1 (folded, false);
13889 if (encoded != NULL)
13890 m_encoded_name = encoded;
13892 m_encoded_name = user_name;
13895 m_encoded_name = user_name;
13897 /* Handle the 'package Standard' special case. See description
13898 of m_standard_p. */
13899 if (startswith (m_encoded_name.c_str (), "standard__"))
13901 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
13902 m_standard_p = true;
13905 m_standard_p = false;
13907 /* If the name contains a ".", then the user is entering a fully
13908 qualified entity name, and the match must not be done in wild
13909 mode. Similarly, if the user wants to complete what looks
13910 like an encoded name, the match must not be done in wild
13911 mode. Also, in the standard__ special case always do
13912 non-wild matching. */
13914 = (lookup_name.match_type () != symbol_name_match_type::FULL
13917 && user_name.find ('.') == std::string::npos);
13921 /* symbol_name_matcher_ftype method for Ada. This only handles
13922 completion mode. */
13925 ada_symbol_name_matches (const char *symbol_search_name,
13926 const lookup_name_info &lookup_name,
13927 completion_match *match)
13929 return lookup_name.ada ().matches (symbol_search_name,
13930 lookup_name.match_type (),
13934 /* Implement the "la_get_symbol_name_matcher" language_defn method for
13937 static symbol_name_matcher_ftype *
13938 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
13940 if (lookup_name.completion_mode ())
13941 return ada_symbol_name_matches;
13944 if (lookup_name.ada ().wild_match_p ())
13945 return do_wild_match;
13947 return do_full_match;
13951 /* Implement the "la_read_var_value" language_defn method for Ada. */
13953 static struct value *
13954 ada_read_var_value (struct symbol *var, const struct block *var_block,
13955 struct frame_info *frame)
13957 const struct block *frame_block = NULL;
13958 struct symbol *renaming_sym = NULL;
13960 /* The only case where default_read_var_value is not sufficient
13961 is when VAR is a renaming... */
13963 frame_block = get_frame_block (frame, NULL);
13965 renaming_sym = ada_find_renaming_symbol (var, frame_block);
13966 if (renaming_sym != NULL)
13967 return ada_read_renaming_var_value (renaming_sym, frame_block);
13969 /* This is a typical case where we expect the default_read_var_value
13970 function to work. */
13971 return default_read_var_value (var, var_block, frame);
13974 static const char *ada_extensions[] =
13976 ".adb", ".ads", ".a", ".ada", ".dg", NULL
13979 extern const struct language_defn ada_language_defn = {
13980 "ada", /* Language name */
13984 case_sensitive_on, /* Yes, Ada is case-insensitive, but
13985 that's not quite what this means. */
13987 macro_expansion_no,
13989 &ada_exp_descriptor,
13993 ada_printchar, /* Print a character constant */
13994 ada_printstr, /* Function to print string constant */
13995 emit_char, /* Function to print single char (not used) */
13996 ada_print_type, /* Print a type using appropriate syntax */
13997 ada_print_typedef, /* Print a typedef using appropriate syntax */
13998 ada_val_print, /* Print a value using appropriate syntax */
13999 ada_value_print, /* Print a top-level value */
14000 ada_read_var_value, /* la_read_var_value */
14001 NULL, /* Language specific skip_trampoline */
14002 NULL, /* name_of_this */
14003 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14004 basic_lookup_transparent_type, /* lookup_transparent_type */
14005 ada_la_decode, /* Language specific symbol demangler */
14006 ada_sniff_from_mangled_name,
14007 NULL, /* Language specific
14008 class_name_from_physname */
14009 ada_op_print_tab, /* expression operators for printing */
14010 0, /* c-style arrays */
14011 1, /* String lower bound */
14012 ada_get_gdb_completer_word_break_characters,
14013 ada_collect_symbol_completion_matches,
14014 ada_language_arch_info,
14015 ada_print_array_index,
14016 default_pass_by_reference,
14018 c_watch_location_expression,
14019 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
14020 ada_iterate_over_symbols,
14021 default_search_name_hash,
14028 /* Command-list for the "set/show ada" prefix command. */
14029 static struct cmd_list_element *set_ada_list;
14030 static struct cmd_list_element *show_ada_list;
14032 /* Implement the "set ada" prefix command. */
14035 set_ada_command (const char *arg, int from_tty)
14037 printf_unfiltered (_(\
14038 "\"set ada\" must be followed by the name of a setting.\n"));
14039 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
14042 /* Implement the "show ada" prefix command. */
14045 show_ada_command (const char *args, int from_tty)
14047 cmd_show_list (show_ada_list, from_tty, "");
14051 initialize_ada_catchpoint_ops (void)
14053 struct breakpoint_ops *ops;
14055 initialize_breakpoint_ops ();
14057 ops = &catch_exception_breakpoint_ops;
14058 *ops = bkpt_breakpoint_ops;
14059 ops->allocate_location = allocate_location_catch_exception;
14060 ops->re_set = re_set_catch_exception;
14061 ops->check_status = check_status_catch_exception;
14062 ops->print_it = print_it_catch_exception;
14063 ops->print_one = print_one_catch_exception;
14064 ops->print_mention = print_mention_catch_exception;
14065 ops->print_recreate = print_recreate_catch_exception;
14067 ops = &catch_exception_unhandled_breakpoint_ops;
14068 *ops = bkpt_breakpoint_ops;
14069 ops->allocate_location = allocate_location_catch_exception_unhandled;
14070 ops->re_set = re_set_catch_exception_unhandled;
14071 ops->check_status = check_status_catch_exception_unhandled;
14072 ops->print_it = print_it_catch_exception_unhandled;
14073 ops->print_one = print_one_catch_exception_unhandled;
14074 ops->print_mention = print_mention_catch_exception_unhandled;
14075 ops->print_recreate = print_recreate_catch_exception_unhandled;
14077 ops = &catch_assert_breakpoint_ops;
14078 *ops = bkpt_breakpoint_ops;
14079 ops->allocate_location = allocate_location_catch_assert;
14080 ops->re_set = re_set_catch_assert;
14081 ops->check_status = check_status_catch_assert;
14082 ops->print_it = print_it_catch_assert;
14083 ops->print_one = print_one_catch_assert;
14084 ops->print_mention = print_mention_catch_assert;
14085 ops->print_recreate = print_recreate_catch_assert;
14088 /* This module's 'new_objfile' observer. */
14091 ada_new_objfile_observer (struct objfile *objfile)
14093 ada_clear_symbol_cache ();
14096 /* This module's 'free_objfile' observer. */
14099 ada_free_objfile_observer (struct objfile *objfile)
14101 ada_clear_symbol_cache ();
14105 _initialize_ada_language (void)
14107 initialize_ada_catchpoint_ops ();
14109 add_prefix_cmd ("ada", no_class, set_ada_command,
14110 _("Prefix command for changing Ada-specfic settings"),
14111 &set_ada_list, "set ada ", 0, &setlist);
14113 add_prefix_cmd ("ada", no_class, show_ada_command,
14114 _("Generic command for showing Ada-specific settings."),
14115 &show_ada_list, "show ada ", 0, &showlist);
14117 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14118 &trust_pad_over_xvs, _("\
14119 Enable or disable an optimization trusting PAD types over XVS types"), _("\
14120 Show whether an optimization trusting PAD types over XVS types is activated"),
14122 This is related to the encoding used by the GNAT compiler. The debugger\n\
14123 should normally trust the contents of PAD types, but certain older versions\n\
14124 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14125 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14126 work around this bug. It is always safe to turn this option \"off\", but\n\
14127 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14128 this option to \"off\" unless necessary."),
14129 NULL, NULL, &set_ada_list, &show_ada_list);
14131 add_setshow_boolean_cmd ("print-signatures", class_vars,
14132 &print_signatures, _("\
14133 Enable or disable the output of formal and return types for functions in the \
14134 overloads selection menu"), _("\
14135 Show whether the output of formal and return types for functions in the \
14136 overloads selection menu is activated"),
14137 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14139 add_catch_command ("exception", _("\
14140 Catch Ada exceptions, when raised.\n\
14141 With an argument, catch only exceptions with the given name."),
14142 catch_ada_exception_command,
14146 add_catch_command ("assert", _("\
14147 Catch failed Ada assertions, when raised.\n\
14148 With an argument, catch only exceptions with the given name."),
14149 catch_assert_command,
14154 varsize_limit = 65536;
14156 add_info ("exceptions", info_exceptions_command,
14158 List all Ada exception names.\n\
14159 If a regular expression is passed as an argument, only those matching\n\
14160 the regular expression are listed."));
14162 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14163 _("Set Ada maintenance-related variables."),
14164 &maint_set_ada_cmdlist, "maintenance set ada ",
14165 0/*allow-unknown*/, &maintenance_set_cmdlist);
14167 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14168 _("Show Ada maintenance-related variables"),
14169 &maint_show_ada_cmdlist, "maintenance show ada ",
14170 0/*allow-unknown*/, &maintenance_show_cmdlist);
14172 add_setshow_boolean_cmd
14173 ("ignore-descriptive-types", class_maintenance,
14174 &ada_ignore_descriptive_types_p,
14175 _("Set whether descriptive types generated by GNAT should be ignored."),
14176 _("Show whether descriptive types generated by GNAT should be ignored."),
14178 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14179 DWARF attribute."),
14180 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14182 obstack_init (&symbol_list_obstack);
14184 decoded_names_store = htab_create_alloc
14185 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
14186 NULL, xcalloc, xfree);
14188 /* The ada-lang observers. */
14189 observer_attach_new_objfile (ada_new_objfile_observer);
14190 observer_attach_free_objfile (ada_free_objfile_observer);
14191 observer_attach_inferior_exit (ada_inferior_exit);
14193 /* Setup various context-specific data. */
14195 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
14196 ada_pspace_data_handle
14197 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);