1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2014 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/>. */
27 #include "gdb_regex.h"
32 #include "expression.h"
33 #include "parser-defs.h"
40 #include "breakpoint.h"
43 #include "gdb_obstack.h"
45 #include "completer.h"
50 #include "dictionary.h"
51 #include "exceptions.h"
59 #include "typeprint.h"
63 #include "mi/mi-common.h"
64 #include "arch-utils.h"
65 #include "cli/cli-utils.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 int full_match (const char *, const char *);
109 static struct value *make_array_descriptor (struct type *, struct value *);
111 static void ada_add_block_symbols (struct obstack *,
112 struct block *, const char *,
113 domain_enum, struct objfile *, int);
115 static int is_nonfunction (struct ada_symbol_info *, int);
117 static void add_defn_to_vec (struct obstack *, struct symbol *,
120 static int num_defns_collected (struct obstack *);
122 static struct ada_symbol_info *defns_collected (struct obstack *, int);
124 static struct value *resolve_subexp (struct expression **, int *, int,
127 static void replace_operator_with_call (struct expression **, int, int, int,
128 struct symbol *, const struct block *);
130 static int possible_user_operator_p (enum exp_opcode, struct value **);
132 static char *ada_op_name (enum exp_opcode);
134 static const char *ada_decoded_op_name (enum exp_opcode);
136 static int numeric_type_p (struct type *);
138 static int integer_type_p (struct type *);
140 static int scalar_type_p (struct type *);
142 static int discrete_type_p (struct type *);
144 static enum ada_renaming_category parse_old_style_renaming (struct type *,
149 static struct symbol *find_old_style_renaming_symbol (const char *,
150 const struct block *);
152 static struct type *ada_lookup_struct_elt_type (struct type *, char *,
155 static struct value *evaluate_subexp_type (struct expression *, int *);
157 static struct type *ada_find_parallel_type_with_name (struct type *,
160 static int is_dynamic_field (struct type *, int);
162 static struct type *to_fixed_variant_branch_type (struct type *,
164 CORE_ADDR, struct value *);
166 static struct type *to_fixed_array_type (struct type *, struct value *, int);
168 static struct type *to_fixed_range_type (struct type *, struct value *);
170 static struct type *to_static_fixed_type (struct type *);
171 static struct type *static_unwrap_type (struct type *type);
173 static struct value *unwrap_value (struct value *);
175 static struct type *constrained_packed_array_type (struct type *, long *);
177 static struct type *decode_constrained_packed_array_type (struct type *);
179 static long decode_packed_array_bitsize (struct type *);
181 static struct value *decode_constrained_packed_array (struct value *);
183 static int ada_is_packed_array_type (struct type *);
185 static int ada_is_unconstrained_packed_array_type (struct type *);
187 static struct value *value_subscript_packed (struct value *, int,
190 static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
192 static struct value *coerce_unspec_val_to_type (struct value *,
195 static struct value *get_var_value (char *, char *);
197 static int lesseq_defined_than (struct symbol *, struct symbol *);
199 static int equiv_types (struct type *, struct type *);
201 static int is_name_suffix (const char *);
203 static int advance_wild_match (const char **, const char *, int);
205 static int wild_match (const char *, const char *);
207 static struct value *ada_coerce_ref (struct value *);
209 static LONGEST pos_atr (struct value *);
211 static struct value *value_pos_atr (struct type *, struct value *);
213 static struct value *value_val_atr (struct type *, struct value *);
215 static struct symbol *standard_lookup (const char *, const struct block *,
218 static struct value *ada_search_struct_field (char *, struct value *, int,
221 static struct value *ada_value_primitive_field (struct value *, int, int,
224 static int find_struct_field (const char *, struct type *, int,
225 struct type **, int *, int *, int *, int *);
227 static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
230 static int ada_resolve_function (struct ada_symbol_info *, int,
231 struct value **, int, const char *,
234 static int ada_is_direct_array_type (struct type *);
236 static void ada_language_arch_info (struct gdbarch *,
237 struct language_arch_info *);
239 static void check_size (const struct type *);
241 static struct value *ada_index_struct_field (int, struct value *, int,
244 static struct value *assign_aggregate (struct value *, struct value *,
248 static void aggregate_assign_from_choices (struct value *, struct value *,
250 int *, LONGEST *, int *,
251 int, LONGEST, LONGEST);
253 static void aggregate_assign_positional (struct value *, struct value *,
255 int *, LONGEST *, int *, int,
259 static void aggregate_assign_others (struct value *, struct value *,
261 int *, LONGEST *, int, LONGEST, LONGEST);
264 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
267 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
270 static void ada_forward_operator_length (struct expression *, int, int *,
273 static struct type *ada_find_any_type (const char *name);
277 /* Maximum-sized dynamic type. */
278 static unsigned int varsize_limit;
280 /* FIXME: brobecker/2003-09-17: No longer a const because it is
281 returned by a function that does not return a const char *. */
282 static char *ada_completer_word_break_characters =
284 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
286 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
289 /* The name of the symbol to use to get the name of the main subprogram. */
290 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
291 = "__gnat_ada_main_program_name";
293 /* Limit on the number of warnings to raise per expression evaluation. */
294 static int warning_limit = 2;
296 /* Number of warning messages issued; reset to 0 by cleanups after
297 expression evaluation. */
298 static int warnings_issued = 0;
300 static const char *known_runtime_file_name_patterns[] = {
301 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
304 static const char *known_auxiliary_function_name_patterns[] = {
305 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
308 /* Space for allocating results of ada_lookup_symbol_list. */
309 static struct obstack symbol_list_obstack;
311 /* Inferior-specific data. */
313 /* Per-inferior data for this module. */
315 struct ada_inferior_data
317 /* The ada__tags__type_specific_data type, which is used when decoding
318 tagged types. With older versions of GNAT, this type was directly
319 accessible through a component ("tsd") in the object tag. But this
320 is no longer the case, so we cache it for each inferior. */
321 struct type *tsd_type;
323 /* The exception_support_info data. This data is used to determine
324 how to implement support for Ada exception catchpoints in a given
326 const struct exception_support_info *exception_info;
329 /* Our key to this module's inferior data. */
330 static const struct inferior_data *ada_inferior_data;
332 /* A cleanup routine for our inferior data. */
334 ada_inferior_data_cleanup (struct inferior *inf, void *arg)
336 struct ada_inferior_data *data;
338 data = inferior_data (inf, ada_inferior_data);
343 /* Return our inferior data for the given inferior (INF).
345 This function always returns a valid pointer to an allocated
346 ada_inferior_data structure. If INF's inferior data has not
347 been previously set, this functions creates a new one with all
348 fields set to zero, sets INF's inferior to it, and then returns
349 a pointer to that newly allocated ada_inferior_data. */
351 static struct ada_inferior_data *
352 get_ada_inferior_data (struct inferior *inf)
354 struct ada_inferior_data *data;
356 data = inferior_data (inf, ada_inferior_data);
359 data = XCNEW (struct ada_inferior_data);
360 set_inferior_data (inf, ada_inferior_data, data);
366 /* Perform all necessary cleanups regarding our module's inferior data
367 that is required after the inferior INF just exited. */
370 ada_inferior_exit (struct inferior *inf)
372 ada_inferior_data_cleanup (inf, NULL);
373 set_inferior_data (inf, ada_inferior_data, NULL);
378 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
379 all typedef layers have been peeled. Otherwise, return TYPE.
381 Normally, we really expect a typedef type to only have 1 typedef layer.
382 In other words, we really expect the target type of a typedef type to be
383 a non-typedef type. This is particularly true for Ada units, because
384 the language does not have a typedef vs not-typedef distinction.
385 In that respect, the Ada compiler has been trying to eliminate as many
386 typedef definitions in the debugging information, since they generally
387 do not bring any extra information (we still use typedef under certain
388 circumstances related mostly to the GNAT encoding).
390 Unfortunately, we have seen situations where the debugging information
391 generated by the compiler leads to such multiple typedef layers. For
392 instance, consider the following example with stabs:
394 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
395 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
397 This is an error in the debugging information which causes type
398 pck__float_array___XUP to be defined twice, and the second time,
399 it is defined as a typedef of a typedef.
401 This is on the fringe of legality as far as debugging information is
402 concerned, and certainly unexpected. But it is easy to handle these
403 situations correctly, so we can afford to be lenient in this case. */
406 ada_typedef_target_type (struct type *type)
408 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
409 type = TYPE_TARGET_TYPE (type);
413 /* Given DECODED_NAME a string holding a symbol name in its
414 decoded form (ie using the Ada dotted notation), returns
415 its unqualified name. */
418 ada_unqualified_name (const char *decoded_name)
420 const char *result = strrchr (decoded_name, '.');
423 result++; /* Skip the dot... */
425 result = decoded_name;
430 /* Return a string starting with '<', followed by STR, and '>'.
431 The result is good until the next call. */
434 add_angle_brackets (const char *str)
436 static char *result = NULL;
439 result = xstrprintf ("<%s>", str);
444 ada_get_gdb_completer_word_break_characters (void)
446 return ada_completer_word_break_characters;
449 /* Print an array element index using the Ada syntax. */
452 ada_print_array_index (struct value *index_value, struct ui_file *stream,
453 const struct value_print_options *options)
455 LA_VALUE_PRINT (index_value, stream, options);
456 fprintf_filtered (stream, " => ");
459 /* Assuming VECT points to an array of *SIZE objects of size
460 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
461 updating *SIZE as necessary and returning the (new) array. */
464 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
466 if (*size < min_size)
469 if (*size < min_size)
471 vect = xrealloc (vect, *size * element_size);
476 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
477 suffix of FIELD_NAME beginning "___". */
480 field_name_match (const char *field_name, const char *target)
482 int len = strlen (target);
485 (strncmp (field_name, target, len) == 0
486 && (field_name[len] == '\0'
487 || (strncmp (field_name + len, "___", 3) == 0
488 && strcmp (field_name + strlen (field_name) - 6,
493 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
494 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
495 and return its index. This function also handles fields whose name
496 have ___ suffixes because the compiler sometimes alters their name
497 by adding such a suffix to represent fields with certain constraints.
498 If the field could not be found, return a negative number if
499 MAYBE_MISSING is set. Otherwise raise an error. */
502 ada_get_field_index (const struct type *type, const char *field_name,
506 struct type *struct_type = check_typedef ((struct type *) type);
508 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
509 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
513 error (_("Unable to find field %s in struct %s. Aborting"),
514 field_name, TYPE_NAME (struct_type));
519 /* The length of the prefix of NAME prior to any "___" suffix. */
522 ada_name_prefix_len (const char *name)
528 const char *p = strstr (name, "___");
531 return strlen (name);
537 /* Return non-zero if SUFFIX is a suffix of STR.
538 Return zero if STR is null. */
541 is_suffix (const char *str, const char *suffix)
548 len2 = strlen (suffix);
549 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
552 /* The contents of value VAL, treated as a value of type TYPE. The
553 result is an lval in memory if VAL is. */
555 static struct value *
556 coerce_unspec_val_to_type (struct value *val, struct type *type)
558 type = ada_check_typedef (type);
559 if (value_type (val) == type)
563 struct value *result;
565 /* Make sure that the object size is not unreasonable before
566 trying to allocate some memory for it. */
570 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
571 result = allocate_value_lazy (type);
574 result = allocate_value (type);
575 memcpy (value_contents_raw (result), value_contents (val),
578 set_value_component_location (result, val);
579 set_value_bitsize (result, value_bitsize (val));
580 set_value_bitpos (result, value_bitpos (val));
581 set_value_address (result, value_address (val));
582 set_value_optimized_out (result, value_optimized_out_const (val));
587 static const gdb_byte *
588 cond_offset_host (const gdb_byte *valaddr, long offset)
593 return valaddr + offset;
597 cond_offset_target (CORE_ADDR address, long offset)
602 return address + offset;
605 /* Issue a warning (as for the definition of warning in utils.c, but
606 with exactly one argument rather than ...), unless the limit on the
607 number of warnings has passed during the evaluation of the current
610 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
611 provided by "complaint". */
612 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
615 lim_warning (const char *format, ...)
619 va_start (args, format);
620 warnings_issued += 1;
621 if (warnings_issued <= warning_limit)
622 vwarning (format, args);
627 /* Issue an error if the size of an object of type T is unreasonable,
628 i.e. if it would be a bad idea to allocate a value of this type in
632 check_size (const struct type *type)
634 if (TYPE_LENGTH (type) > varsize_limit)
635 error (_("object size is larger than varsize-limit"));
638 /* Maximum value of a SIZE-byte signed integer type. */
640 max_of_size (int size)
642 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
644 return top_bit | (top_bit - 1);
647 /* Minimum value of a SIZE-byte signed integer type. */
649 min_of_size (int size)
651 return -max_of_size (size) - 1;
654 /* Maximum value of a SIZE-byte unsigned integer type. */
656 umax_of_size (int size)
658 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
660 return top_bit | (top_bit - 1);
663 /* Maximum value of integral type T, as a signed quantity. */
665 max_of_type (struct type *t)
667 if (TYPE_UNSIGNED (t))
668 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
670 return max_of_size (TYPE_LENGTH (t));
673 /* Minimum value of integral type T, as a signed quantity. */
675 min_of_type (struct type *t)
677 if (TYPE_UNSIGNED (t))
680 return min_of_size (TYPE_LENGTH (t));
683 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
685 ada_discrete_type_high_bound (struct type *type)
687 switch (TYPE_CODE (type))
689 case TYPE_CODE_RANGE:
690 return TYPE_HIGH_BOUND (type);
692 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
697 return max_of_type (type);
699 error (_("Unexpected type in ada_discrete_type_high_bound."));
703 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
705 ada_discrete_type_low_bound (struct type *type)
707 switch (TYPE_CODE (type))
709 case TYPE_CODE_RANGE:
710 return TYPE_LOW_BOUND (type);
712 return TYPE_FIELD_ENUMVAL (type, 0);
717 return min_of_type (type);
719 error (_("Unexpected type in ada_discrete_type_low_bound."));
723 /* The identity on non-range types. For range types, the underlying
724 non-range scalar type. */
727 get_base_type (struct type *type)
729 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
731 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
733 type = TYPE_TARGET_TYPE (type);
738 /* Return a decoded version of the given VALUE. This means returning
739 a value whose type is obtained by applying all the GNAT-specific
740 encondings, making the resulting type a static but standard description
741 of the initial type. */
744 ada_get_decoded_value (struct value *value)
746 struct type *type = ada_check_typedef (value_type (value));
748 if (ada_is_array_descriptor_type (type)
749 || (ada_is_constrained_packed_array_type (type)
750 && TYPE_CODE (type) != TYPE_CODE_PTR))
752 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
753 value = ada_coerce_to_simple_array_ptr (value);
755 value = ada_coerce_to_simple_array (value);
758 value = ada_to_fixed_value (value);
763 /* Same as ada_get_decoded_value, but with the given TYPE.
764 Because there is no associated actual value for this type,
765 the resulting type might be a best-effort approximation in
766 the case of dynamic types. */
769 ada_get_decoded_type (struct type *type)
771 type = to_static_fixed_type (type);
772 if (ada_is_constrained_packed_array_type (type))
773 type = ada_coerce_to_simple_array_type (type);
779 /* Language Selection */
781 /* If the main program is in Ada, return language_ada, otherwise return LANG
782 (the main program is in Ada iif the adainit symbol is found). */
785 ada_update_initial_language (enum language lang)
787 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
788 (struct objfile *) NULL) != NULL)
794 /* If the main procedure is written in Ada, then return its name.
795 The result is good until the next call. Return NULL if the main
796 procedure doesn't appear to be in Ada. */
801 struct minimal_symbol *msym;
802 static char *main_program_name = NULL;
804 /* For Ada, the name of the main procedure is stored in a specific
805 string constant, generated by the binder. Look for that symbol,
806 extract its address, and then read that string. If we didn't find
807 that string, then most probably the main procedure is not written
809 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
813 CORE_ADDR main_program_name_addr;
816 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
817 if (main_program_name_addr == 0)
818 error (_("Invalid address for Ada main program name."));
820 xfree (main_program_name);
821 target_read_string (main_program_name_addr, &main_program_name,
826 return main_program_name;
829 /* The main procedure doesn't seem to be in Ada. */
835 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
838 const struct ada_opname_map ada_opname_table[] = {
839 {"Oadd", "\"+\"", BINOP_ADD},
840 {"Osubtract", "\"-\"", BINOP_SUB},
841 {"Omultiply", "\"*\"", BINOP_MUL},
842 {"Odivide", "\"/\"", BINOP_DIV},
843 {"Omod", "\"mod\"", BINOP_MOD},
844 {"Orem", "\"rem\"", BINOP_REM},
845 {"Oexpon", "\"**\"", BINOP_EXP},
846 {"Olt", "\"<\"", BINOP_LESS},
847 {"Ole", "\"<=\"", BINOP_LEQ},
848 {"Ogt", "\">\"", BINOP_GTR},
849 {"Oge", "\">=\"", BINOP_GEQ},
850 {"Oeq", "\"=\"", BINOP_EQUAL},
851 {"One", "\"/=\"", BINOP_NOTEQUAL},
852 {"Oand", "\"and\"", BINOP_BITWISE_AND},
853 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
854 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
855 {"Oconcat", "\"&\"", BINOP_CONCAT},
856 {"Oabs", "\"abs\"", UNOP_ABS},
857 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
858 {"Oadd", "\"+\"", UNOP_PLUS},
859 {"Osubtract", "\"-\"", UNOP_NEG},
863 /* The "encoded" form of DECODED, according to GNAT conventions.
864 The result is valid until the next call to ada_encode. */
867 ada_encode (const char *decoded)
869 static char *encoding_buffer = NULL;
870 static size_t encoding_buffer_size = 0;
877 GROW_VECT (encoding_buffer, encoding_buffer_size,
878 2 * strlen (decoded) + 10);
881 for (p = decoded; *p != '\0'; p += 1)
885 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
890 const struct ada_opname_map *mapping;
892 for (mapping = ada_opname_table;
893 mapping->encoded != NULL
894 && strncmp (mapping->decoded, p,
895 strlen (mapping->decoded)) != 0; mapping += 1)
897 if (mapping->encoded == NULL)
898 error (_("invalid Ada operator name: %s"), p);
899 strcpy (encoding_buffer + k, mapping->encoded);
900 k += strlen (mapping->encoded);
905 encoding_buffer[k] = *p;
910 encoding_buffer[k] = '\0';
911 return encoding_buffer;
914 /* Return NAME folded to lower case, or, if surrounded by single
915 quotes, unfolded, but with the quotes stripped away. Result good
919 ada_fold_name (const char *name)
921 static char *fold_buffer = NULL;
922 static size_t fold_buffer_size = 0;
924 int len = strlen (name);
925 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
929 strncpy (fold_buffer, name + 1, len - 2);
930 fold_buffer[len - 2] = '\000';
936 for (i = 0; i <= len; i += 1)
937 fold_buffer[i] = tolower (name[i]);
943 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
946 is_lower_alphanum (const char c)
948 return (isdigit (c) || (isalpha (c) && islower (c)));
951 /* ENCODED is the linkage name of a symbol and LEN contains its length.
952 This function saves in LEN the length of that same symbol name but
953 without either of these suffixes:
959 These are suffixes introduced by the compiler for entities such as
960 nested subprogram for instance, in order to avoid name clashes.
961 They do not serve any purpose for the debugger. */
964 ada_remove_trailing_digits (const char *encoded, int *len)
966 if (*len > 1 && isdigit (encoded[*len - 1]))
970 while (i > 0 && isdigit (encoded[i]))
972 if (i >= 0 && encoded[i] == '.')
974 else if (i >= 0 && encoded[i] == '$')
976 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
978 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
983 /* Remove the suffix introduced by the compiler for protected object
987 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
989 /* Remove trailing N. */
991 /* Protected entry subprograms are broken into two
992 separate subprograms: The first one is unprotected, and has
993 a 'N' suffix; the second is the protected version, and has
994 the 'P' suffix. The second calls the first one after handling
995 the protection. Since the P subprograms are internally generated,
996 we leave these names undecoded, giving the user a clue that this
997 entity is internal. */
1000 && encoded[*len - 1] == 'N'
1001 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1005 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1008 ada_remove_Xbn_suffix (const char *encoded, int *len)
1012 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1015 if (encoded[i] != 'X')
1021 if (isalnum (encoded[i-1]))
1025 /* If ENCODED follows the GNAT entity encoding conventions, then return
1026 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1027 replaced by ENCODED.
1029 The resulting string is valid until the next call of ada_decode.
1030 If the string is unchanged by decoding, the original string pointer
1034 ada_decode (const char *encoded)
1041 static char *decoding_buffer = NULL;
1042 static size_t decoding_buffer_size = 0;
1044 /* The name of the Ada main procedure starts with "_ada_".
1045 This prefix is not part of the decoded name, so skip this part
1046 if we see this prefix. */
1047 if (strncmp (encoded, "_ada_", 5) == 0)
1050 /* If the name starts with '_', then it is not a properly encoded
1051 name, so do not attempt to decode it. Similarly, if the name
1052 starts with '<', the name should not be decoded. */
1053 if (encoded[0] == '_' || encoded[0] == '<')
1056 len0 = strlen (encoded);
1058 ada_remove_trailing_digits (encoded, &len0);
1059 ada_remove_po_subprogram_suffix (encoded, &len0);
1061 /* Remove the ___X.* suffix if present. Do not forget to verify that
1062 the suffix is located before the current "end" of ENCODED. We want
1063 to avoid re-matching parts of ENCODED that have previously been
1064 marked as discarded (by decrementing LEN0). */
1065 p = strstr (encoded, "___");
1066 if (p != NULL && p - encoded < len0 - 3)
1074 /* Remove any trailing TKB suffix. It tells us that this symbol
1075 is for the body of a task, but that information does not actually
1076 appear in the decoded name. */
1078 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
1081 /* Remove any trailing TB suffix. The TB suffix is slightly different
1082 from the TKB suffix because it is used for non-anonymous task
1085 if (len0 > 2 && strncmp (encoded + len0 - 2, "TB", 2) == 0)
1088 /* Remove trailing "B" suffixes. */
1089 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1091 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
1094 /* Make decoded big enough for possible expansion by operator name. */
1096 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1097 decoded = decoding_buffer;
1099 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1101 if (len0 > 1 && isdigit (encoded[len0 - 1]))
1104 while ((i >= 0 && isdigit (encoded[i]))
1105 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1107 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1109 else if (encoded[i] == '$')
1113 /* The first few characters that are not alphabetic are not part
1114 of any encoding we use, so we can copy them over verbatim. */
1116 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1117 decoded[j] = encoded[i];
1122 /* Is this a symbol function? */
1123 if (at_start_name && encoded[i] == 'O')
1127 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1129 int op_len = strlen (ada_opname_table[k].encoded);
1130 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1132 && !isalnum (encoded[i + op_len]))
1134 strcpy (decoded + j, ada_opname_table[k].decoded);
1137 j += strlen (ada_opname_table[k].decoded);
1141 if (ada_opname_table[k].encoded != NULL)
1146 /* Replace "TK__" with "__", which will eventually be translated
1147 into "." (just below). */
1149 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1152 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1153 be translated into "." (just below). These are internal names
1154 generated for anonymous blocks inside which our symbol is nested. */
1156 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1157 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1158 && isdigit (encoded [i+4]))
1162 while (k < len0 && isdigit (encoded[k]))
1163 k++; /* Skip any extra digit. */
1165 /* Double-check that the "__B_{DIGITS}+" sequence we found
1166 is indeed followed by "__". */
1167 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1171 /* Remove _E{DIGITS}+[sb] */
1173 /* Just as for protected object subprograms, there are 2 categories
1174 of subprograms created by the compiler for each entry. The first
1175 one implements the actual entry code, and has a suffix following
1176 the convention above; the second one implements the barrier and
1177 uses the same convention as above, except that the 'E' is replaced
1180 Just as above, we do not decode the name of barrier functions
1181 to give the user a clue that the code he is debugging has been
1182 internally generated. */
1184 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1185 && isdigit (encoded[i+2]))
1189 while (k < len0 && isdigit (encoded[k]))
1193 && (encoded[k] == 'b' || encoded[k] == 's'))
1196 /* Just as an extra precaution, make sure that if this
1197 suffix is followed by anything else, it is a '_'.
1198 Otherwise, we matched this sequence by accident. */
1200 || (k < len0 && encoded[k] == '_'))
1205 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1206 the GNAT front-end in protected object subprograms. */
1209 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1211 /* Backtrack a bit up until we reach either the begining of
1212 the encoded name, or "__". Make sure that we only find
1213 digits or lowercase characters. */
1214 const char *ptr = encoded + i - 1;
1216 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1219 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1223 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1225 /* This is a X[bn]* sequence not separated from the previous
1226 part of the name with a non-alpha-numeric character (in other
1227 words, immediately following an alpha-numeric character), then
1228 verify that it is placed at the end of the encoded name. If
1229 not, then the encoding is not valid and we should abort the
1230 decoding. Otherwise, just skip it, it is used in body-nested
1234 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1238 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1240 /* Replace '__' by '.'. */
1248 /* It's a character part of the decoded name, so just copy it
1250 decoded[j] = encoded[i];
1255 decoded[j] = '\000';
1257 /* Decoded names should never contain any uppercase character.
1258 Double-check this, and abort the decoding if we find one. */
1260 for (i = 0; decoded[i] != '\0'; i += 1)
1261 if (isupper (decoded[i]) || decoded[i] == ' ')
1264 if (strcmp (decoded, encoded) == 0)
1270 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1271 decoded = decoding_buffer;
1272 if (encoded[0] == '<')
1273 strcpy (decoded, encoded);
1275 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
1280 /* Table for keeping permanent unique copies of decoded names. Once
1281 allocated, names in this table are never released. While this is a
1282 storage leak, it should not be significant unless there are massive
1283 changes in the set of decoded names in successive versions of a
1284 symbol table loaded during a single session. */
1285 static struct htab *decoded_names_store;
1287 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1288 in the language-specific part of GSYMBOL, if it has not been
1289 previously computed. Tries to save the decoded name in the same
1290 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1291 in any case, the decoded symbol has a lifetime at least that of
1293 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1294 const, but nevertheless modified to a semantically equivalent form
1295 when a decoded name is cached in it. */
1298 ada_decode_symbol (const struct general_symbol_info *arg)
1300 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1301 const char **resultp =
1302 &gsymbol->language_specific.mangled_lang.demangled_name;
1304 if (!gsymbol->ada_mangled)
1306 const char *decoded = ada_decode (gsymbol->name);
1307 struct obstack *obstack = gsymbol->language_specific.obstack;
1309 gsymbol->ada_mangled = 1;
1311 if (obstack != NULL)
1312 *resultp = obstack_copy0 (obstack, decoded, strlen (decoded));
1315 /* Sometimes, we can't find a corresponding objfile, in
1316 which case, we put the result on the heap. Since we only
1317 decode when needed, we hope this usually does not cause a
1318 significant memory leak (FIXME). */
1320 char **slot = (char **) htab_find_slot (decoded_names_store,
1324 *slot = xstrdup (decoded);
1333 ada_la_decode (const char *encoded, int options)
1335 return xstrdup (ada_decode (encoded));
1338 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1339 suffixes that encode debugging information or leading _ada_ on
1340 SYM_NAME (see is_name_suffix commentary for the debugging
1341 information that is ignored). If WILD, then NAME need only match a
1342 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1343 either argument is NULL. */
1346 match_name (const char *sym_name, const char *name, int wild)
1348 if (sym_name == NULL || name == NULL)
1351 return wild_match (sym_name, name) == 0;
1354 int len_name = strlen (name);
1356 return (strncmp (sym_name, name, len_name) == 0
1357 && is_name_suffix (sym_name + len_name))
1358 || (strncmp (sym_name, "_ada_", 5) == 0
1359 && strncmp (sym_name + 5, name, len_name) == 0
1360 && is_name_suffix (sym_name + len_name + 5));
1367 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1368 generated by the GNAT compiler to describe the index type used
1369 for each dimension of an array, check whether it follows the latest
1370 known encoding. If not, fix it up to conform to the latest encoding.
1371 Otherwise, do nothing. This function also does nothing if
1372 INDEX_DESC_TYPE is NULL.
1374 The GNAT encoding used to describle the array index type evolved a bit.
1375 Initially, the information would be provided through the name of each
1376 field of the structure type only, while the type of these fields was
1377 described as unspecified and irrelevant. The debugger was then expected
1378 to perform a global type lookup using the name of that field in order
1379 to get access to the full index type description. Because these global
1380 lookups can be very expensive, the encoding was later enhanced to make
1381 the global lookup unnecessary by defining the field type as being
1382 the full index type description.
1384 The purpose of this routine is to allow us to support older versions
1385 of the compiler by detecting the use of the older encoding, and by
1386 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1387 we essentially replace each field's meaningless type by the associated
1391 ada_fixup_array_indexes_type (struct type *index_desc_type)
1395 if (index_desc_type == NULL)
1397 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1399 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1400 to check one field only, no need to check them all). If not, return
1403 If our INDEX_DESC_TYPE was generated using the older encoding,
1404 the field type should be a meaningless integer type whose name
1405 is not equal to the field name. */
1406 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1407 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1408 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1411 /* Fixup each field of INDEX_DESC_TYPE. */
1412 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1414 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1415 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1418 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1422 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1424 static char *bound_name[] = {
1425 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1426 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1429 /* Maximum number of array dimensions we are prepared to handle. */
1431 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1434 /* The desc_* routines return primitive portions of array descriptors
1437 /* The descriptor or array type, if any, indicated by TYPE; removes
1438 level of indirection, if needed. */
1440 static struct type *
1441 desc_base_type (struct type *type)
1445 type = ada_check_typedef (type);
1446 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1447 type = ada_typedef_target_type (type);
1450 && (TYPE_CODE (type) == TYPE_CODE_PTR
1451 || TYPE_CODE (type) == TYPE_CODE_REF))
1452 return ada_check_typedef (TYPE_TARGET_TYPE (type));
1457 /* True iff TYPE indicates a "thin" array pointer type. */
1460 is_thin_pntr (struct type *type)
1463 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1464 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1467 /* The descriptor type for thin pointer type TYPE. */
1469 static struct type *
1470 thin_descriptor_type (struct type *type)
1472 struct type *base_type = desc_base_type (type);
1474 if (base_type == NULL)
1476 if (is_suffix (ada_type_name (base_type), "___XVE"))
1480 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1482 if (alt_type == NULL)
1489 /* A pointer to the array data for thin-pointer value VAL. */
1491 static struct value *
1492 thin_data_pntr (struct value *val)
1494 struct type *type = ada_check_typedef (value_type (val));
1495 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1497 data_type = lookup_pointer_type (data_type);
1499 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1500 return value_cast (data_type, value_copy (val));
1502 return value_from_longest (data_type, value_address (val));
1505 /* True iff TYPE indicates a "thick" array pointer type. */
1508 is_thick_pntr (struct type *type)
1510 type = desc_base_type (type);
1511 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1512 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1515 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1516 pointer to one, the type of its bounds data; otherwise, NULL. */
1518 static struct type *
1519 desc_bounds_type (struct type *type)
1523 type = desc_base_type (type);
1527 else if (is_thin_pntr (type))
1529 type = thin_descriptor_type (type);
1532 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1534 return ada_check_typedef (r);
1536 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1538 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1540 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1545 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1546 one, a pointer to its bounds data. Otherwise NULL. */
1548 static struct value *
1549 desc_bounds (struct value *arr)
1551 struct type *type = ada_check_typedef (value_type (arr));
1553 if (is_thin_pntr (type))
1555 struct type *bounds_type =
1556 desc_bounds_type (thin_descriptor_type (type));
1559 if (bounds_type == NULL)
1560 error (_("Bad GNAT array descriptor"));
1562 /* NOTE: The following calculation is not really kosher, but
1563 since desc_type is an XVE-encoded type (and shouldn't be),
1564 the correct calculation is a real pain. FIXME (and fix GCC). */
1565 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1566 addr = value_as_long (arr);
1568 addr = value_address (arr);
1571 value_from_longest (lookup_pointer_type (bounds_type),
1572 addr - TYPE_LENGTH (bounds_type));
1575 else if (is_thick_pntr (type))
1577 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1578 _("Bad GNAT array descriptor"));
1579 struct type *p_bounds_type = value_type (p_bounds);
1582 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1584 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1586 if (TYPE_STUB (target_type))
1587 p_bounds = value_cast (lookup_pointer_type
1588 (ada_check_typedef (target_type)),
1592 error (_("Bad GNAT array descriptor"));
1600 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1601 position of the field containing the address of the bounds data. */
1604 fat_pntr_bounds_bitpos (struct type *type)
1606 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1609 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1610 size of the field containing the address of the bounds data. */
1613 fat_pntr_bounds_bitsize (struct type *type)
1615 type = desc_base_type (type);
1617 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1618 return TYPE_FIELD_BITSIZE (type, 1);
1620 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1623 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1624 pointer to one, the type of its array data (a array-with-no-bounds type);
1625 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1628 static struct type *
1629 desc_data_target_type (struct type *type)
1631 type = desc_base_type (type);
1633 /* NOTE: The following is bogus; see comment in desc_bounds. */
1634 if (is_thin_pntr (type))
1635 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
1636 else if (is_thick_pntr (type))
1638 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1641 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
1642 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1648 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1651 static struct value *
1652 desc_data (struct value *arr)
1654 struct type *type = value_type (arr);
1656 if (is_thin_pntr (type))
1657 return thin_data_pntr (arr);
1658 else if (is_thick_pntr (type))
1659 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1660 _("Bad GNAT array descriptor"));
1666 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1667 position of the field containing the address of the data. */
1670 fat_pntr_data_bitpos (struct type *type)
1672 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1675 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1676 size of the field containing the address of the data. */
1679 fat_pntr_data_bitsize (struct type *type)
1681 type = desc_base_type (type);
1683 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1684 return TYPE_FIELD_BITSIZE (type, 0);
1686 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1689 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1690 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1691 bound, if WHICH is 1. The first bound is I=1. */
1693 static struct value *
1694 desc_one_bound (struct value *bounds, int i, int which)
1696 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1697 _("Bad GNAT array descriptor bounds"));
1700 /* If BOUNDS is an array-bounds structure type, return the bit position
1701 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1702 bound, if WHICH is 1. The first bound is I=1. */
1705 desc_bound_bitpos (struct type *type, int i, int which)
1707 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1710 /* If BOUNDS is an array-bounds structure type, return the bit field size
1711 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1712 bound, if WHICH is 1. The first bound is I=1. */
1715 desc_bound_bitsize (struct type *type, int i, int which)
1717 type = desc_base_type (type);
1719 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1720 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1722 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1725 /* If TYPE is the type of an array-bounds structure, the type of its
1726 Ith bound (numbering from 1). Otherwise, NULL. */
1728 static struct type *
1729 desc_index_type (struct type *type, int i)
1731 type = desc_base_type (type);
1733 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1734 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1739 /* The number of index positions in the array-bounds type TYPE.
1740 Return 0 if TYPE is NULL. */
1743 desc_arity (struct type *type)
1745 type = desc_base_type (type);
1748 return TYPE_NFIELDS (type) / 2;
1752 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1753 an array descriptor type (representing an unconstrained array
1757 ada_is_direct_array_type (struct type *type)
1761 type = ada_check_typedef (type);
1762 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1763 || ada_is_array_descriptor_type (type));
1766 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1770 ada_is_array_type (struct type *type)
1773 && (TYPE_CODE (type) == TYPE_CODE_PTR
1774 || TYPE_CODE (type) == TYPE_CODE_REF))
1775 type = TYPE_TARGET_TYPE (type);
1776 return ada_is_direct_array_type (type);
1779 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1782 ada_is_simple_array_type (struct type *type)
1786 type = ada_check_typedef (type);
1787 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1788 || (TYPE_CODE (type) == TYPE_CODE_PTR
1789 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1790 == TYPE_CODE_ARRAY));
1793 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1796 ada_is_array_descriptor_type (struct type *type)
1798 struct type *data_type = desc_data_target_type (type);
1802 type = ada_check_typedef (type);
1803 return (data_type != NULL
1804 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1805 && desc_arity (desc_bounds_type (type)) > 0);
1808 /* Non-zero iff type is a partially mal-formed GNAT array
1809 descriptor. FIXME: This is to compensate for some problems with
1810 debugging output from GNAT. Re-examine periodically to see if it
1814 ada_is_bogus_array_descriptor (struct type *type)
1818 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1819 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1820 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1821 && !ada_is_array_descriptor_type (type);
1825 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1826 (fat pointer) returns the type of the array data described---specifically,
1827 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1828 in from the descriptor; otherwise, they are left unspecified. If
1829 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1830 returns NULL. The result is simply the type of ARR if ARR is not
1833 ada_type_of_array (struct value *arr, int bounds)
1835 if (ada_is_constrained_packed_array_type (value_type (arr)))
1836 return decode_constrained_packed_array_type (value_type (arr));
1838 if (!ada_is_array_descriptor_type (value_type (arr)))
1839 return value_type (arr);
1843 struct type *array_type =
1844 ada_check_typedef (desc_data_target_type (value_type (arr)));
1846 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1847 TYPE_FIELD_BITSIZE (array_type, 0) =
1848 decode_packed_array_bitsize (value_type (arr));
1854 struct type *elt_type;
1856 struct value *descriptor;
1858 elt_type = ada_array_element_type (value_type (arr), -1);
1859 arity = ada_array_arity (value_type (arr));
1861 if (elt_type == NULL || arity == 0)
1862 return ada_check_typedef (value_type (arr));
1864 descriptor = desc_bounds (arr);
1865 if (value_as_long (descriptor) == 0)
1869 struct type *range_type = alloc_type_copy (value_type (arr));
1870 struct type *array_type = alloc_type_copy (value_type (arr));
1871 struct value *low = desc_one_bound (descriptor, arity, 0);
1872 struct value *high = desc_one_bound (descriptor, arity, 1);
1875 create_range_type (range_type, value_type (low),
1876 longest_to_int (value_as_long (low)),
1877 longest_to_int (value_as_long (high)));
1878 elt_type = create_array_type (array_type, elt_type, range_type);
1880 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1882 /* We need to store the element packed bitsize, as well as
1883 recompute the array size, because it was previously
1884 computed based on the unpacked element size. */
1885 LONGEST lo = value_as_long (low);
1886 LONGEST hi = value_as_long (high);
1888 TYPE_FIELD_BITSIZE (elt_type, 0) =
1889 decode_packed_array_bitsize (value_type (arr));
1890 /* If the array has no element, then the size is already
1891 zero, and does not need to be recomputed. */
1895 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
1897 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
1902 return lookup_pointer_type (elt_type);
1906 /* If ARR does not represent an array, returns ARR unchanged.
1907 Otherwise, returns either a standard GDB array with bounds set
1908 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1909 GDB array. Returns NULL if ARR is a null fat pointer. */
1912 ada_coerce_to_simple_array_ptr (struct value *arr)
1914 if (ada_is_array_descriptor_type (value_type (arr)))
1916 struct type *arrType = ada_type_of_array (arr, 1);
1918 if (arrType == NULL)
1920 return value_cast (arrType, value_copy (desc_data (arr)));
1922 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1923 return decode_constrained_packed_array (arr);
1928 /* If ARR does not represent an array, returns ARR unchanged.
1929 Otherwise, returns a standard GDB array describing ARR (which may
1930 be ARR itself if it already is in the proper form). */
1933 ada_coerce_to_simple_array (struct value *arr)
1935 if (ada_is_array_descriptor_type (value_type (arr)))
1937 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1940 error (_("Bounds unavailable for null array pointer."));
1941 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
1942 return value_ind (arrVal);
1944 else if (ada_is_constrained_packed_array_type (value_type (arr)))
1945 return decode_constrained_packed_array (arr);
1950 /* If TYPE represents a GNAT array type, return it translated to an
1951 ordinary GDB array type (possibly with BITSIZE fields indicating
1952 packing). For other types, is the identity. */
1955 ada_coerce_to_simple_array_type (struct type *type)
1957 if (ada_is_constrained_packed_array_type (type))
1958 return decode_constrained_packed_array_type (type);
1960 if (ada_is_array_descriptor_type (type))
1961 return ada_check_typedef (desc_data_target_type (type));
1966 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1969 ada_is_packed_array_type (struct type *type)
1973 type = desc_base_type (type);
1974 type = ada_check_typedef (type);
1976 ada_type_name (type) != NULL
1977 && strstr (ada_type_name (type), "___XP") != NULL;
1980 /* Non-zero iff TYPE represents a standard GNAT constrained
1981 packed-array type. */
1984 ada_is_constrained_packed_array_type (struct type *type)
1986 return ada_is_packed_array_type (type)
1987 && !ada_is_array_descriptor_type (type);
1990 /* Non-zero iff TYPE represents an array descriptor for a
1991 unconstrained packed-array type. */
1994 ada_is_unconstrained_packed_array_type (struct type *type)
1996 return ada_is_packed_array_type (type)
1997 && ada_is_array_descriptor_type (type);
2000 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2001 return the size of its elements in bits. */
2004 decode_packed_array_bitsize (struct type *type)
2006 const char *raw_name;
2010 /* Access to arrays implemented as fat pointers are encoded as a typedef
2011 of the fat pointer type. We need the name of the fat pointer type
2012 to do the decoding, so strip the typedef layer. */
2013 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2014 type = ada_typedef_target_type (type);
2016 raw_name = ada_type_name (ada_check_typedef (type));
2018 raw_name = ada_type_name (desc_base_type (type));
2023 tail = strstr (raw_name, "___XP");
2024 gdb_assert (tail != NULL);
2026 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2029 (_("could not understand bit size information on packed array"));
2036 /* Given that TYPE is a standard GDB array type with all bounds filled
2037 in, and that the element size of its ultimate scalar constituents
2038 (that is, either its elements, or, if it is an array of arrays, its
2039 elements' elements, etc.) is *ELT_BITS, return an identical type,
2040 but with the bit sizes of its elements (and those of any
2041 constituent arrays) recorded in the BITSIZE components of its
2042 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2045 static struct type *
2046 constrained_packed_array_type (struct type *type, long *elt_bits)
2048 struct type *new_elt_type;
2049 struct type *new_type;
2050 struct type *index_type_desc;
2051 struct type *index_type;
2052 LONGEST low_bound, high_bound;
2054 type = ada_check_typedef (type);
2055 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2058 index_type_desc = ada_find_parallel_type (type, "___XA");
2059 if (index_type_desc)
2060 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2063 index_type = TYPE_INDEX_TYPE (type);
2065 new_type = alloc_type_copy (type);
2067 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2069 create_array_type (new_type, new_elt_type, index_type);
2070 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2071 TYPE_NAME (new_type) = ada_type_name (type);
2073 if (get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
2074 low_bound = high_bound = 0;
2075 if (high_bound < low_bound)
2076 *elt_bits = TYPE_LENGTH (new_type) = 0;
2079 *elt_bits *= (high_bound - low_bound + 1);
2080 TYPE_LENGTH (new_type) =
2081 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2084 TYPE_FIXED_INSTANCE (new_type) = 1;
2088 /* The array type encoded by TYPE, where
2089 ada_is_constrained_packed_array_type (TYPE). */
2091 static struct type *
2092 decode_constrained_packed_array_type (struct type *type)
2094 const char *raw_name = ada_type_name (ada_check_typedef (type));
2097 struct type *shadow_type;
2101 raw_name = ada_type_name (desc_base_type (type));
2106 name = (char *) alloca (strlen (raw_name) + 1);
2107 tail = strstr (raw_name, "___XP");
2108 type = desc_base_type (type);
2110 memcpy (name, raw_name, tail - raw_name);
2111 name[tail - raw_name] = '\000';
2113 shadow_type = ada_find_parallel_type_with_name (type, name);
2115 if (shadow_type == NULL)
2117 lim_warning (_("could not find bounds information on packed array"));
2120 CHECK_TYPEDEF (shadow_type);
2122 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2124 lim_warning (_("could not understand bounds "
2125 "information on packed array"));
2129 bits = decode_packed_array_bitsize (type);
2130 return constrained_packed_array_type (shadow_type, &bits);
2133 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2134 array, returns a simple array that denotes that array. Its type is a
2135 standard GDB array type except that the BITSIZEs of the array
2136 target types are set to the number of bits in each element, and the
2137 type length is set appropriately. */
2139 static struct value *
2140 decode_constrained_packed_array (struct value *arr)
2144 arr = ada_coerce_ref (arr);
2146 /* If our value is a pointer, then dererence it. Make sure that
2147 this operation does not cause the target type to be fixed, as
2148 this would indirectly cause this array to be decoded. The rest
2149 of the routine assumes that the array hasn't been decoded yet,
2150 so we use the basic "value_ind" routine to perform the dereferencing,
2151 as opposed to using "ada_value_ind". */
2152 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
2153 arr = value_ind (arr);
2155 type = decode_constrained_packed_array_type (value_type (arr));
2158 error (_("can't unpack array"));
2162 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
2163 && ada_is_modular_type (value_type (arr)))
2165 /* This is a (right-justified) modular type representing a packed
2166 array with no wrapper. In order to interpret the value through
2167 the (left-justified) packed array type we just built, we must
2168 first left-justify it. */
2169 int bit_size, bit_pos;
2172 mod = ada_modulus (value_type (arr)) - 1;
2179 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2180 arr = ada_value_primitive_packed_val (arr, NULL,
2181 bit_pos / HOST_CHAR_BIT,
2182 bit_pos % HOST_CHAR_BIT,
2187 return coerce_unspec_val_to_type (arr, type);
2191 /* The value of the element of packed array ARR at the ARITY indices
2192 given in IND. ARR must be a simple array. */
2194 static struct value *
2195 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2198 int bits, elt_off, bit_off;
2199 long elt_total_bit_offset;
2200 struct type *elt_type;
2204 elt_total_bit_offset = 0;
2205 elt_type = ada_check_typedef (value_type (arr));
2206 for (i = 0; i < arity; i += 1)
2208 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
2209 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2211 (_("attempt to do packed indexing of "
2212 "something other than a packed array"));
2215 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2216 LONGEST lowerbound, upperbound;
2219 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2221 lim_warning (_("don't know bounds of array"));
2222 lowerbound = upperbound = 0;
2225 idx = pos_atr (ind[i]);
2226 if (idx < lowerbound || idx > upperbound)
2227 lim_warning (_("packed array index %ld out of bounds"),
2229 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2230 elt_total_bit_offset += (idx - lowerbound) * bits;
2231 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2234 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2235 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2237 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2242 /* Non-zero iff TYPE includes negative integer values. */
2245 has_negatives (struct type *type)
2247 switch (TYPE_CODE (type))
2252 return !TYPE_UNSIGNED (type);
2253 case TYPE_CODE_RANGE:
2254 return TYPE_LOW_BOUND (type) < 0;
2259 /* Create a new value of type TYPE from the contents of OBJ starting
2260 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2261 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2262 assigning through the result will set the field fetched from.
2263 VALADDR is ignored unless OBJ is NULL, in which case,
2264 VALADDR+OFFSET must address the start of storage containing the
2265 packed value. The value returned in this case is never an lval.
2266 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2269 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2270 long offset, int bit_offset, int bit_size,
2274 int src, /* Index into the source area */
2275 targ, /* Index into the target area */
2276 srcBitsLeft, /* Number of source bits left to move */
2277 nsrc, ntarg, /* Number of source and target bytes */
2278 unusedLS, /* Number of bits in next significant
2279 byte of source that are unused */
2280 accumSize; /* Number of meaningful bits in accum */
2281 unsigned char *bytes; /* First byte containing data to unpack */
2282 unsigned char *unpacked;
2283 unsigned long accum; /* Staging area for bits being transferred */
2285 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2286 /* Transmit bytes from least to most significant; delta is the direction
2287 the indices move. */
2288 int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
2290 type = ada_check_typedef (type);
2294 v = allocate_value (type);
2295 bytes = (unsigned char *) (valaddr + offset);
2297 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2299 v = value_at (type, value_address (obj));
2300 bytes = (unsigned char *) alloca (len);
2301 read_memory (value_address (v) + offset, bytes, len);
2305 v = allocate_value (type);
2306 bytes = (unsigned char *) value_contents (obj) + offset;
2311 long new_offset = offset;
2313 set_value_component_location (v, obj);
2314 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2315 set_value_bitsize (v, bit_size);
2316 if (value_bitpos (v) >= HOST_CHAR_BIT)
2319 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2321 set_value_offset (v, new_offset);
2323 /* Also set the parent value. This is needed when trying to
2324 assign a new value (in inferior memory). */
2325 set_value_parent (v, obj);
2328 set_value_bitsize (v, bit_size);
2329 unpacked = (unsigned char *) value_contents (v);
2331 srcBitsLeft = bit_size;
2333 ntarg = TYPE_LENGTH (type);
2337 memset (unpacked, 0, TYPE_LENGTH (type));
2340 else if (gdbarch_bits_big_endian (get_type_arch (type)))
2343 if (has_negatives (type)
2344 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2348 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2351 switch (TYPE_CODE (type))
2353 case TYPE_CODE_ARRAY:
2354 case TYPE_CODE_UNION:
2355 case TYPE_CODE_STRUCT:
2356 /* Non-scalar values must be aligned at a byte boundary... */
2358 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2359 /* ... And are placed at the beginning (most-significant) bytes
2361 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2366 targ = TYPE_LENGTH (type) - 1;
2372 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2375 unusedLS = bit_offset;
2378 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
2385 /* Mask for removing bits of the next source byte that are not
2386 part of the value. */
2387 unsigned int unusedMSMask =
2388 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2390 /* Sign-extend bits for this byte. */
2391 unsigned int signMask = sign & ~unusedMSMask;
2394 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2395 accumSize += HOST_CHAR_BIT - unusedLS;
2396 if (accumSize >= HOST_CHAR_BIT)
2398 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2399 accumSize -= HOST_CHAR_BIT;
2400 accum >>= HOST_CHAR_BIT;
2404 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2411 accum |= sign << accumSize;
2412 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2413 accumSize -= HOST_CHAR_BIT;
2414 accum >>= HOST_CHAR_BIT;
2422 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2423 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2426 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2427 int src_offset, int n, int bits_big_endian_p)
2429 unsigned int accum, mask;
2430 int accum_bits, chunk_size;
2432 target += targ_offset / HOST_CHAR_BIT;
2433 targ_offset %= HOST_CHAR_BIT;
2434 source += src_offset / HOST_CHAR_BIT;
2435 src_offset %= HOST_CHAR_BIT;
2436 if (bits_big_endian_p)
2438 accum = (unsigned char) *source;
2440 accum_bits = HOST_CHAR_BIT - src_offset;
2446 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2447 accum_bits += HOST_CHAR_BIT;
2449 chunk_size = HOST_CHAR_BIT - targ_offset;
2452 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2453 mask = ((1 << chunk_size) - 1) << unused_right;
2456 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2458 accum_bits -= chunk_size;
2465 accum = (unsigned char) *source >> src_offset;
2467 accum_bits = HOST_CHAR_BIT - src_offset;
2471 accum = accum + ((unsigned char) *source << accum_bits);
2472 accum_bits += HOST_CHAR_BIT;
2474 chunk_size = HOST_CHAR_BIT - targ_offset;
2477 mask = ((1 << chunk_size) - 1) << targ_offset;
2478 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2480 accum_bits -= chunk_size;
2481 accum >>= chunk_size;
2488 /* Store the contents of FROMVAL into the location of TOVAL.
2489 Return a new value with the location of TOVAL and contents of
2490 FROMVAL. Handles assignment into packed fields that have
2491 floating-point or non-scalar types. */
2493 static struct value *
2494 ada_value_assign (struct value *toval, struct value *fromval)
2496 struct type *type = value_type (toval);
2497 int bits = value_bitsize (toval);
2499 toval = ada_coerce_ref (toval);
2500 fromval = ada_coerce_ref (fromval);
2502 if (ada_is_direct_array_type (value_type (toval)))
2503 toval = ada_coerce_to_simple_array (toval);
2504 if (ada_is_direct_array_type (value_type (fromval)))
2505 fromval = ada_coerce_to_simple_array (fromval);
2507 if (!deprecated_value_modifiable (toval))
2508 error (_("Left operand of assignment is not a modifiable lvalue."));
2510 if (VALUE_LVAL (toval) == lval_memory
2512 && (TYPE_CODE (type) == TYPE_CODE_FLT
2513 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2515 int len = (value_bitpos (toval)
2516 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2518 gdb_byte *buffer = alloca (len);
2520 CORE_ADDR to_addr = value_address (toval);
2522 if (TYPE_CODE (type) == TYPE_CODE_FLT)
2523 fromval = value_cast (type, fromval);
2525 read_memory (to_addr, buffer, len);
2526 from_size = value_bitsize (fromval);
2528 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2529 if (gdbarch_bits_big_endian (get_type_arch (type)))
2530 move_bits (buffer, value_bitpos (toval),
2531 value_contents (fromval), from_size - bits, bits, 1);
2533 move_bits (buffer, value_bitpos (toval),
2534 value_contents (fromval), 0, bits, 0);
2535 write_memory_with_notification (to_addr, buffer, len);
2537 val = value_copy (toval);
2538 memcpy (value_contents_raw (val), value_contents (fromval),
2539 TYPE_LENGTH (type));
2540 deprecated_set_value_type (val, type);
2545 return value_assign (toval, fromval);
2549 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2550 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2551 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2552 * COMPONENT, and not the inferior's memory. The current contents
2553 * of COMPONENT are ignored. */
2555 value_assign_to_component (struct value *container, struct value *component,
2558 LONGEST offset_in_container =
2559 (LONGEST) (value_address (component) - value_address (container));
2560 int bit_offset_in_container =
2561 value_bitpos (component) - value_bitpos (container);
2564 val = value_cast (value_type (component), val);
2566 if (value_bitsize (component) == 0)
2567 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2569 bits = value_bitsize (component);
2571 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2572 move_bits (value_contents_writeable (container) + offset_in_container,
2573 value_bitpos (container) + bit_offset_in_container,
2574 value_contents (val),
2575 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2578 move_bits (value_contents_writeable (container) + offset_in_container,
2579 value_bitpos (container) + bit_offset_in_container,
2580 value_contents (val), 0, bits, 0);
2583 /* The value of the element of array ARR at the ARITY indices given in IND.
2584 ARR may be either a simple array, GNAT array descriptor, or pointer
2588 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2592 struct type *elt_type;
2594 elt = ada_coerce_to_simple_array (arr);
2596 elt_type = ada_check_typedef (value_type (elt));
2597 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2598 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2599 return value_subscript_packed (elt, arity, ind);
2601 for (k = 0; k < arity; k += 1)
2603 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2604 error (_("too many subscripts (%d expected)"), k);
2605 elt = value_subscript (elt, pos_atr (ind[k]));
2610 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2611 value of the element of *ARR at the ARITY indices given in
2612 IND. Does not read the entire array into memory. */
2614 static struct value *
2615 ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
2620 for (k = 0; k < arity; k += 1)
2624 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2625 error (_("too many subscripts (%d expected)"), k);
2626 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2628 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2629 arr = value_ptradd (arr, pos_atr (ind[k]) - lwb);
2630 type = TYPE_TARGET_TYPE (type);
2633 return value_ind (arr);
2636 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2637 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2638 elements starting at index LOW. The lower bound of this array is LOW, as
2640 static struct value *
2641 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2644 struct type *type0 = ada_check_typedef (type);
2645 CORE_ADDR base = value_as_address (array_ptr)
2646 + ((low - ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)))
2647 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
2648 struct type *index_type =
2649 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)),
2651 struct type *slice_type =
2652 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
2654 return value_at_lazy (slice_type, base);
2658 static struct value *
2659 ada_value_slice (struct value *array, int low, int high)
2661 struct type *type = ada_check_typedef (value_type (array));
2662 struct type *index_type =
2663 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2664 struct type *slice_type =
2665 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2667 return value_cast (slice_type, value_slice (array, low, high - low + 1));
2670 /* If type is a record type in the form of a standard GNAT array
2671 descriptor, returns the number of dimensions for type. If arr is a
2672 simple array, returns the number of "array of"s that prefix its
2673 type designation. Otherwise, returns 0. */
2676 ada_array_arity (struct type *type)
2683 type = desc_base_type (type);
2686 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2687 return desc_arity (desc_bounds_type (type));
2689 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2692 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2698 /* If TYPE is a record type in the form of a standard GNAT array
2699 descriptor or a simple array type, returns the element type for
2700 TYPE after indexing by NINDICES indices, or by all indices if
2701 NINDICES is -1. Otherwise, returns NULL. */
2704 ada_array_element_type (struct type *type, int nindices)
2706 type = desc_base_type (type);
2708 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2711 struct type *p_array_type;
2713 p_array_type = desc_data_target_type (type);
2715 k = ada_array_arity (type);
2719 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2720 if (nindices >= 0 && k > nindices)
2722 while (k > 0 && p_array_type != NULL)
2724 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2727 return p_array_type;
2729 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2731 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
2733 type = TYPE_TARGET_TYPE (type);
2742 /* The type of nth index in arrays of given type (n numbering from 1).
2743 Does not examine memory. Throws an error if N is invalid or TYPE
2744 is not an array type. NAME is the name of the Ada attribute being
2745 evaluated ('range, 'first, 'last, or 'length); it is used in building
2746 the error message. */
2748 static struct type *
2749 ada_index_type (struct type *type, int n, const char *name)
2751 struct type *result_type;
2753 type = desc_base_type (type);
2755 if (n < 0 || n > ada_array_arity (type))
2756 error (_("invalid dimension number to '%s"), name);
2758 if (ada_is_simple_array_type (type))
2762 for (i = 1; i < n; i += 1)
2763 type = TYPE_TARGET_TYPE (type);
2764 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2765 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2766 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2767 perhaps stabsread.c would make more sense. */
2768 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2773 result_type = desc_index_type (desc_bounds_type (type), n);
2774 if (result_type == NULL)
2775 error (_("attempt to take bound of something that is not an array"));
2781 /* Given that arr is an array type, returns the lower bound of the
2782 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2783 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2784 array-descriptor type. It works for other arrays with bounds supplied
2785 by run-time quantities other than discriminants. */
2788 ada_array_bound_from_type (struct type *arr_type, int n, int which)
2790 struct type *type, *index_type_desc, *index_type;
2793 gdb_assert (which == 0 || which == 1);
2795 if (ada_is_constrained_packed_array_type (arr_type))
2796 arr_type = decode_constrained_packed_array_type (arr_type);
2798 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2799 return (LONGEST) - which;
2801 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2802 type = TYPE_TARGET_TYPE (arr_type);
2806 index_type_desc = ada_find_parallel_type (type, "___XA");
2807 ada_fixup_array_indexes_type (index_type_desc);
2808 if (index_type_desc != NULL)
2809 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2813 struct type *elt_type = check_typedef (type);
2815 for (i = 1; i < n; i++)
2816 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2818 index_type = TYPE_INDEX_TYPE (elt_type);
2822 (LONGEST) (which == 0
2823 ? ada_discrete_type_low_bound (index_type)
2824 : ada_discrete_type_high_bound (index_type));
2827 /* Given that arr is an array value, returns the lower bound of the
2828 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2829 WHICH is 1. This routine will also work for arrays with bounds
2830 supplied by run-time quantities other than discriminants. */
2833 ada_array_bound (struct value *arr, int n, int which)
2835 struct type *arr_type = value_type (arr);
2837 if (ada_is_constrained_packed_array_type (arr_type))
2838 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
2839 else if (ada_is_simple_array_type (arr_type))
2840 return ada_array_bound_from_type (arr_type, n, which);
2842 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
2845 /* Given that arr is an array value, returns the length of the
2846 nth index. This routine will also work for arrays with bounds
2847 supplied by run-time quantities other than discriminants.
2848 Does not work for arrays indexed by enumeration types with representation
2849 clauses at the moment. */
2852 ada_array_length (struct value *arr, int n)
2854 struct type *arr_type = ada_check_typedef (value_type (arr));
2856 if (ada_is_constrained_packed_array_type (arr_type))
2857 return ada_array_length (decode_constrained_packed_array (arr), n);
2859 if (ada_is_simple_array_type (arr_type))
2860 return (ada_array_bound_from_type (arr_type, n, 1)
2861 - ada_array_bound_from_type (arr_type, n, 0) + 1);
2863 return (value_as_long (desc_one_bound (desc_bounds (arr), n, 1))
2864 - value_as_long (desc_one_bound (desc_bounds (arr), n, 0)) + 1);
2867 /* An empty array whose type is that of ARR_TYPE (an array type),
2868 with bounds LOW to LOW-1. */
2870 static struct value *
2871 empty_array (struct type *arr_type, int low)
2873 struct type *arr_type0 = ada_check_typedef (arr_type);
2874 struct type *index_type =
2875 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)),
2877 struct type *elt_type = ada_array_element_type (arr_type0, 1);
2879 return allocate_value (create_array_type (NULL, elt_type, index_type));
2883 /* Name resolution */
2885 /* The "decoded" name for the user-definable Ada operator corresponding
2889 ada_decoded_op_name (enum exp_opcode op)
2893 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
2895 if (ada_opname_table[i].op == op)
2896 return ada_opname_table[i].decoded;
2898 error (_("Could not find operator name for opcode"));
2902 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2903 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2904 undefined namespace) and converts operators that are
2905 user-defined into appropriate function calls. If CONTEXT_TYPE is
2906 non-null, it provides a preferred result type [at the moment, only
2907 type void has any effect---causing procedures to be preferred over
2908 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2909 return type is preferred. May change (expand) *EXP. */
2912 resolve (struct expression **expp, int void_context_p)
2914 struct type *context_type = NULL;
2918 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
2920 resolve_subexp (expp, &pc, 1, context_type);
2923 /* Resolve the operator of the subexpression beginning at
2924 position *POS of *EXPP. "Resolving" consists of replacing
2925 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2926 with their resolutions, replacing built-in operators with
2927 function calls to user-defined operators, where appropriate, and,
2928 when DEPROCEDURE_P is non-zero, converting function-valued variables
2929 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2930 are as in ada_resolve, above. */
2932 static struct value *
2933 resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
2934 struct type *context_type)
2938 struct expression *exp; /* Convenience: == *expp. */
2939 enum exp_opcode op = (*expp)->elts[pc].opcode;
2940 struct value **argvec; /* Vector of operand types (alloca'ed). */
2941 int nargs; /* Number of operands. */
2948 /* Pass one: resolve operands, saving their types and updating *pos,
2953 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2954 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2959 resolve_subexp (expp, pos, 0, NULL);
2961 nargs = longest_to_int (exp->elts[pc + 1].longconst);
2966 resolve_subexp (expp, pos, 0, NULL);
2971 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
2974 case OP_ATR_MODULUS:
2984 case TERNOP_IN_RANGE:
2985 case BINOP_IN_BOUNDS:
2991 case OP_DISCRETE_RANGE:
2993 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3002 arg1 = resolve_subexp (expp, pos, 0, NULL);
3004 resolve_subexp (expp, pos, 1, NULL);
3006 resolve_subexp (expp, pos, 1, value_type (arg1));
3023 case BINOP_LOGICAL_AND:
3024 case BINOP_LOGICAL_OR:
3025 case BINOP_BITWISE_AND:
3026 case BINOP_BITWISE_IOR:
3027 case BINOP_BITWISE_XOR:
3030 case BINOP_NOTEQUAL:
3037 case BINOP_SUBSCRIPT:
3045 case UNOP_LOGICAL_NOT:
3061 case OP_INTERNALVAR:
3071 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3074 case STRUCTOP_STRUCT:
3075 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3088 error (_("Unexpected operator during name resolution"));
3091 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
3092 for (i = 0; i < nargs; i += 1)
3093 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3097 /* Pass two: perform any resolution on principal operator. */
3104 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
3106 struct ada_symbol_info *candidates;
3110 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3111 (exp->elts[pc + 2].symbol),
3112 exp->elts[pc + 1].block, VAR_DOMAIN,
3115 if (n_candidates > 1)
3117 /* Types tend to get re-introduced locally, so if there
3118 are any local symbols that are not types, first filter
3121 for (j = 0; j < n_candidates; j += 1)
3122 switch (SYMBOL_CLASS (candidates[j].sym))
3127 case LOC_REGPARM_ADDR:
3135 if (j < n_candidates)
3138 while (j < n_candidates)
3140 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
3142 candidates[j] = candidates[n_candidates - 1];
3151 if (n_candidates == 0)
3152 error (_("No definition found for %s"),
3153 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3154 else if (n_candidates == 1)
3156 else if (deprocedure_p
3157 && !is_nonfunction (candidates, n_candidates))
3159 i = ada_resolve_function
3160 (candidates, n_candidates, NULL, 0,
3161 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3164 error (_("Could not find a match for %s"),
3165 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3169 printf_filtered (_("Multiple matches for %s\n"),
3170 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3171 user_select_syms (candidates, n_candidates, 1);
3175 exp->elts[pc + 1].block = candidates[i].block;
3176 exp->elts[pc + 2].symbol = candidates[i].sym;
3177 if (innermost_block == NULL
3178 || contained_in (candidates[i].block, innermost_block))
3179 innermost_block = candidates[i].block;
3183 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3186 replace_operator_with_call (expp, pc, 0, 0,
3187 exp->elts[pc + 2].symbol,
3188 exp->elts[pc + 1].block);
3195 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3196 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3198 struct ada_symbol_info *candidates;
3202 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3203 (exp->elts[pc + 5].symbol),
3204 exp->elts[pc + 4].block, VAR_DOMAIN,
3206 if (n_candidates == 1)
3210 i = ada_resolve_function
3211 (candidates, n_candidates,
3213 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3216 error (_("Could not find a match for %s"),
3217 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3220 exp->elts[pc + 4].block = candidates[i].block;
3221 exp->elts[pc + 5].symbol = candidates[i].sym;
3222 if (innermost_block == NULL
3223 || contained_in (candidates[i].block, innermost_block))
3224 innermost_block = candidates[i].block;
3235 case BINOP_BITWISE_AND:
3236 case BINOP_BITWISE_IOR:
3237 case BINOP_BITWISE_XOR:
3239 case BINOP_NOTEQUAL:
3247 case UNOP_LOGICAL_NOT:
3249 if (possible_user_operator_p (op, argvec))
3251 struct ada_symbol_info *candidates;
3255 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3256 (struct block *) NULL, VAR_DOMAIN,
3258 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
3259 ada_decoded_op_name (op), NULL);
3263 replace_operator_with_call (expp, pc, nargs, 1,
3264 candidates[i].sym, candidates[i].block);
3275 return evaluate_subexp_type (exp, pos);
3278 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3279 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3281 /* The term "match" here is rather loose. The match is heuristic and
3285 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3287 ftype = ada_check_typedef (ftype);
3288 atype = ada_check_typedef (atype);
3290 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3291 ftype = TYPE_TARGET_TYPE (ftype);
3292 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3293 atype = TYPE_TARGET_TYPE (atype);
3295 switch (TYPE_CODE (ftype))
3298 return TYPE_CODE (ftype) == TYPE_CODE (atype);
3300 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3301 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3302 TYPE_TARGET_TYPE (atype), 0);
3305 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3307 case TYPE_CODE_ENUM:
3308 case TYPE_CODE_RANGE:
3309 switch (TYPE_CODE (atype))
3312 case TYPE_CODE_ENUM:
3313 case TYPE_CODE_RANGE:
3319 case TYPE_CODE_ARRAY:
3320 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3321 || ada_is_array_descriptor_type (atype));
3323 case TYPE_CODE_STRUCT:
3324 if (ada_is_array_descriptor_type (ftype))
3325 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3326 || ada_is_array_descriptor_type (atype));
3328 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3329 && !ada_is_array_descriptor_type (atype));
3331 case TYPE_CODE_UNION:
3333 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3337 /* Return non-zero if the formals of FUNC "sufficiently match" the
3338 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3339 may also be an enumeral, in which case it is treated as a 0-
3340 argument function. */
3343 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3346 struct type *func_type = SYMBOL_TYPE (func);
3348 if (SYMBOL_CLASS (func) == LOC_CONST
3349 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3350 return (n_actuals == 0);
3351 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3354 if (TYPE_NFIELDS (func_type) != n_actuals)
3357 for (i = 0; i < n_actuals; i += 1)
3359 if (actuals[i] == NULL)
3363 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3365 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3367 if (!ada_type_match (ftype, atype, 1))
3374 /* False iff function type FUNC_TYPE definitely does not produce a value
3375 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3376 FUNC_TYPE is not a valid function type with a non-null return type
3377 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3380 return_match (struct type *func_type, struct type *context_type)
3382 struct type *return_type;
3384 if (func_type == NULL)
3387 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3388 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3390 return_type = get_base_type (func_type);
3391 if (return_type == NULL)
3394 context_type = get_base_type (context_type);
3396 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3397 return context_type == NULL || return_type == context_type;
3398 else if (context_type == NULL)
3399 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3401 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3405 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3406 function (if any) that matches the types of the NARGS arguments in
3407 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3408 that returns that type, then eliminate matches that don't. If
3409 CONTEXT_TYPE is void and there is at least one match that does not
3410 return void, eliminate all matches that do.
3412 Asks the user if there is more than one match remaining. Returns -1
3413 if there is no such symbol or none is selected. NAME is used
3414 solely for messages. May re-arrange and modify SYMS in
3415 the process; the index returned is for the modified vector. */
3418 ada_resolve_function (struct ada_symbol_info syms[],
3419 int nsyms, struct value **args, int nargs,
3420 const char *name, struct type *context_type)
3424 int m; /* Number of hits */
3427 /* In the first pass of the loop, we only accept functions matching
3428 context_type. If none are found, we add a second pass of the loop
3429 where every function is accepted. */
3430 for (fallback = 0; m == 0 && fallback < 2; fallback++)
3432 for (k = 0; k < nsyms; k += 1)
3434 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
3436 if (ada_args_match (syms[k].sym, args, nargs)
3437 && (fallback || return_match (type, context_type)))
3449 printf_filtered (_("Multiple matches for %s\n"), name);
3450 user_select_syms (syms, m, 1);
3456 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3457 in a listing of choices during disambiguation (see sort_choices, below).
3458 The idea is that overloadings of a subprogram name from the
3459 same package should sort in their source order. We settle for ordering
3460 such symbols by their trailing number (__N or $N). */
3463 encoded_ordered_before (const char *N0, const char *N1)
3467 else if (N0 == NULL)
3473 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3475 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3477 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3478 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3483 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3486 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3488 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3489 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3491 return (strcmp (N0, N1) < 0);
3495 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3499 sort_choices (struct ada_symbol_info syms[], int nsyms)
3503 for (i = 1; i < nsyms; i += 1)
3505 struct ada_symbol_info sym = syms[i];
3508 for (j = i - 1; j >= 0; j -= 1)
3510 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3511 SYMBOL_LINKAGE_NAME (sym.sym)))
3513 syms[j + 1] = syms[j];
3519 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3520 by asking the user (if necessary), returning the number selected,
3521 and setting the first elements of SYMS items. Error if no symbols
3524 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3525 to be re-integrated one of these days. */
3528 user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
3531 int *chosen = (int *) alloca (sizeof (int) * nsyms);
3533 int first_choice = (max_results == 1) ? 1 : 2;
3534 const char *select_mode = multiple_symbols_select_mode ();
3536 if (max_results < 1)
3537 error (_("Request to select 0 symbols!"));
3541 if (select_mode == multiple_symbols_cancel)
3543 canceled because the command is ambiguous\n\
3544 See set/show multiple-symbol."));
3546 /* If select_mode is "all", then return all possible symbols.
3547 Only do that if more than one symbol can be selected, of course.
3548 Otherwise, display the menu as usual. */
3549 if (select_mode == multiple_symbols_all && max_results > 1)
3552 printf_unfiltered (_("[0] cancel\n"));
3553 if (max_results > 1)
3554 printf_unfiltered (_("[1] all\n"));
3556 sort_choices (syms, nsyms);
3558 for (i = 0; i < nsyms; i += 1)
3560 if (syms[i].sym == NULL)
3563 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3565 struct symtab_and_line sal =
3566 find_function_start_sal (syms[i].sym, 1);
3568 if (sal.symtab == NULL)
3569 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3571 SYMBOL_PRINT_NAME (syms[i].sym),
3574 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3575 SYMBOL_PRINT_NAME (syms[i].sym),
3576 symtab_to_filename_for_display (sal.symtab),
3583 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3584 && SYMBOL_TYPE (syms[i].sym) != NULL
3585 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
3586 struct symtab *symtab = SYMBOL_SYMTAB (syms[i].sym);
3588 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
3589 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3591 SYMBOL_PRINT_NAME (syms[i].sym),
3592 symtab_to_filename_for_display (symtab),
3593 SYMBOL_LINE (syms[i].sym));
3594 else if (is_enumeral
3595 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
3597 printf_unfiltered (("[%d] "), i + first_choice);
3598 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
3599 gdb_stdout, -1, 0, &type_print_raw_options);
3600 printf_unfiltered (_("'(%s) (enumeral)\n"),
3601 SYMBOL_PRINT_NAME (syms[i].sym));
3603 else if (symtab != NULL)
3604 printf_unfiltered (is_enumeral
3605 ? _("[%d] %s in %s (enumeral)\n")
3606 : _("[%d] %s at %s:?\n"),
3608 SYMBOL_PRINT_NAME (syms[i].sym),
3609 symtab_to_filename_for_display (symtab));
3611 printf_unfiltered (is_enumeral
3612 ? _("[%d] %s (enumeral)\n")
3613 : _("[%d] %s at ?\n"),
3615 SYMBOL_PRINT_NAME (syms[i].sym));
3619 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3622 for (i = 0; i < n_chosen; i += 1)
3623 syms[i] = syms[chosen[i]];
3628 /* Read and validate a set of numeric choices from the user in the
3629 range 0 .. N_CHOICES-1. Place the results in increasing
3630 order in CHOICES[0 .. N-1], and return N.
3632 The user types choices as a sequence of numbers on one line
3633 separated by blanks, encoding them as follows:
3635 + A choice of 0 means to cancel the selection, throwing an error.
3636 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3637 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3639 The user is not allowed to choose more than MAX_RESULTS values.
3641 ANNOTATION_SUFFIX, if present, is used to annotate the input
3642 prompts (for use with the -f switch). */
3645 get_selections (int *choices, int n_choices, int max_results,
3646 int is_all_choice, char *annotation_suffix)
3651 int first_choice = is_all_choice ? 2 : 1;
3653 prompt = getenv ("PS2");
3657 args = command_line_input (prompt, 0, annotation_suffix);
3660 error_no_arg (_("one or more choice numbers"));
3664 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3665 order, as given in args. Choices are validated. */
3671 args = skip_spaces (args);
3672 if (*args == '\0' && n_chosen == 0)
3673 error_no_arg (_("one or more choice numbers"));
3674 else if (*args == '\0')
3677 choice = strtol (args, &args2, 10);
3678 if (args == args2 || choice < 0
3679 || choice > n_choices + first_choice - 1)
3680 error (_("Argument must be choice number"));
3684 error (_("cancelled"));
3686 if (choice < first_choice)
3688 n_chosen = n_choices;
3689 for (j = 0; j < n_choices; j += 1)
3693 choice -= first_choice;
3695 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3699 if (j < 0 || choice != choices[j])
3703 for (k = n_chosen - 1; k > j; k -= 1)
3704 choices[k + 1] = choices[k];
3705 choices[j + 1] = choice;
3710 if (n_chosen > max_results)
3711 error (_("Select no more than %d of the above"), max_results);
3716 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3717 on the function identified by SYM and BLOCK, and taking NARGS
3718 arguments. Update *EXPP as needed to hold more space. */
3721 replace_operator_with_call (struct expression **expp, int pc, int nargs,
3722 int oplen, struct symbol *sym,
3723 const struct block *block)
3725 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3726 symbol, -oplen for operator being replaced). */
3727 struct expression *newexp = (struct expression *)
3728 xzalloc (sizeof (struct expression)
3729 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
3730 struct expression *exp = *expp;
3732 newexp->nelts = exp->nelts + 7 - oplen;
3733 newexp->language_defn = exp->language_defn;
3734 newexp->gdbarch = exp->gdbarch;
3735 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
3736 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
3737 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
3739 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3740 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3742 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3743 newexp->elts[pc + 4].block = block;
3744 newexp->elts[pc + 5].symbol = sym;
3750 /* Type-class predicates */
3752 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3756 numeric_type_p (struct type *type)
3762 switch (TYPE_CODE (type))
3767 case TYPE_CODE_RANGE:
3768 return (type == TYPE_TARGET_TYPE (type)
3769 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3776 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3779 integer_type_p (struct type *type)
3785 switch (TYPE_CODE (type))
3789 case TYPE_CODE_RANGE:
3790 return (type == TYPE_TARGET_TYPE (type)
3791 || integer_type_p (TYPE_TARGET_TYPE (type)));
3798 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3801 scalar_type_p (struct type *type)
3807 switch (TYPE_CODE (type))
3810 case TYPE_CODE_RANGE:
3811 case TYPE_CODE_ENUM:
3820 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3823 discrete_type_p (struct type *type)
3829 switch (TYPE_CODE (type))
3832 case TYPE_CODE_RANGE:
3833 case TYPE_CODE_ENUM:
3834 case TYPE_CODE_BOOL:
3842 /* Returns non-zero if OP with operands in the vector ARGS could be
3843 a user-defined function. Errs on the side of pre-defined operators
3844 (i.e., result 0). */
3847 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3849 struct type *type0 =
3850 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3851 struct type *type1 =
3852 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3866 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3870 case BINOP_BITWISE_AND:
3871 case BINOP_BITWISE_IOR:
3872 case BINOP_BITWISE_XOR:
3873 return (!(integer_type_p (type0) && integer_type_p (type1)));
3876 case BINOP_NOTEQUAL:
3881 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3884 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
3887 return (!(numeric_type_p (type0) && integer_type_p (type1)));
3891 case UNOP_LOGICAL_NOT:
3893 return (!numeric_type_p (type0));
3902 1. In the following, we assume that a renaming type's name may
3903 have an ___XD suffix. It would be nice if this went away at some
3905 2. We handle both the (old) purely type-based representation of
3906 renamings and the (new) variable-based encoding. At some point,
3907 it is devoutly to be hoped that the former goes away
3908 (FIXME: hilfinger-2007-07-09).
3909 3. Subprogram renamings are not implemented, although the XRS
3910 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3912 /* If SYM encodes a renaming,
3914 <renaming> renames <renamed entity>,
3916 sets *LEN to the length of the renamed entity's name,
3917 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3918 the string describing the subcomponent selected from the renamed
3919 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3920 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3921 are undefined). Otherwise, returns a value indicating the category
3922 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3923 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3924 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3925 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3926 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3927 may be NULL, in which case they are not assigned.
3929 [Currently, however, GCC does not generate subprogram renamings.] */
3931 enum ada_renaming_category
3932 ada_parse_renaming (struct symbol *sym,
3933 const char **renamed_entity, int *len,
3934 const char **renaming_expr)
3936 enum ada_renaming_category kind;
3941 return ADA_NOT_RENAMING;
3942 switch (SYMBOL_CLASS (sym))
3945 return ADA_NOT_RENAMING;
3947 return parse_old_style_renaming (SYMBOL_TYPE (sym),
3948 renamed_entity, len, renaming_expr);
3952 case LOC_OPTIMIZED_OUT:
3953 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
3955 return ADA_NOT_RENAMING;
3959 kind = ADA_OBJECT_RENAMING;
3963 kind = ADA_EXCEPTION_RENAMING;
3967 kind = ADA_PACKAGE_RENAMING;
3971 kind = ADA_SUBPROGRAM_RENAMING;
3975 return ADA_NOT_RENAMING;
3979 if (renamed_entity != NULL)
3980 *renamed_entity = info;
3981 suffix = strstr (info, "___XE");
3982 if (suffix == NULL || suffix == info)
3983 return ADA_NOT_RENAMING;
3985 *len = strlen (info) - strlen (suffix);
3987 if (renaming_expr != NULL)
3988 *renaming_expr = suffix;
3992 /* Assuming TYPE encodes a renaming according to the old encoding in
3993 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3994 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3995 ADA_NOT_RENAMING otherwise. */
3996 static enum ada_renaming_category
3997 parse_old_style_renaming (struct type *type,
3998 const char **renamed_entity, int *len,
3999 const char **renaming_expr)
4001 enum ada_renaming_category kind;
4006 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4007 || TYPE_NFIELDS (type) != 1)
4008 return ADA_NOT_RENAMING;
4010 name = type_name_no_tag (type);
4012 return ADA_NOT_RENAMING;
4014 name = strstr (name, "___XR");
4016 return ADA_NOT_RENAMING;
4021 kind = ADA_OBJECT_RENAMING;
4024 kind = ADA_EXCEPTION_RENAMING;
4027 kind = ADA_PACKAGE_RENAMING;
4030 kind = ADA_SUBPROGRAM_RENAMING;
4033 return ADA_NOT_RENAMING;
4036 info = TYPE_FIELD_NAME (type, 0);
4038 return ADA_NOT_RENAMING;
4039 if (renamed_entity != NULL)
4040 *renamed_entity = info;
4041 suffix = strstr (info, "___XE");
4042 if (renaming_expr != NULL)
4043 *renaming_expr = suffix + 5;
4044 if (suffix == NULL || suffix == info)
4045 return ADA_NOT_RENAMING;
4047 *len = suffix - info;
4051 /* Compute the value of the given RENAMING_SYM, which is expected to
4052 be a symbol encoding a renaming expression. BLOCK is the block
4053 used to evaluate the renaming. */
4055 static struct value *
4056 ada_read_renaming_var_value (struct symbol *renaming_sym,
4057 struct block *block)
4059 const char *sym_name;
4060 struct expression *expr;
4061 struct value *value;
4062 struct cleanup *old_chain = NULL;
4064 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4065 expr = parse_exp_1 (&sym_name, 0, block, 0);
4066 old_chain = make_cleanup (free_current_contents, &expr);
4067 value = evaluate_expression (expr);
4069 do_cleanups (old_chain);
4074 /* Evaluation: Function Calls */
4076 /* Return an lvalue containing the value VAL. This is the identity on
4077 lvalues, and otherwise has the side-effect of allocating memory
4078 in the inferior where a copy of the value contents is copied. */
4080 static struct value *
4081 ensure_lval (struct value *val)
4083 if (VALUE_LVAL (val) == not_lval
4084 || VALUE_LVAL (val) == lval_internalvar)
4086 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4087 const CORE_ADDR addr =
4088 value_as_long (value_allocate_space_in_inferior (len));
4090 set_value_address (val, addr);
4091 VALUE_LVAL (val) = lval_memory;
4092 write_memory (addr, value_contents (val), len);
4098 /* Return the value ACTUAL, converted to be an appropriate value for a
4099 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4100 allocating any necessary descriptors (fat pointers), or copies of
4101 values not residing in memory, updating it as needed. */
4104 ada_convert_actual (struct value *actual, struct type *formal_type0)
4106 struct type *actual_type = ada_check_typedef (value_type (actual));
4107 struct type *formal_type = ada_check_typedef (formal_type0);
4108 struct type *formal_target =
4109 TYPE_CODE (formal_type) == TYPE_CODE_PTR
4110 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4111 struct type *actual_target =
4112 TYPE_CODE (actual_type) == TYPE_CODE_PTR
4113 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4115 if (ada_is_array_descriptor_type (formal_target)
4116 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
4117 return make_array_descriptor (formal_type, actual);
4118 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4119 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
4121 struct value *result;
4123 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4124 && ada_is_array_descriptor_type (actual_target))
4125 result = desc_data (actual);
4126 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4128 if (VALUE_LVAL (actual) != lval_memory)
4132 actual_type = ada_check_typedef (value_type (actual));
4133 val = allocate_value (actual_type);
4134 memcpy ((char *) value_contents_raw (val),
4135 (char *) value_contents (actual),
4136 TYPE_LENGTH (actual_type));
4137 actual = ensure_lval (val);
4139 result = value_addr (actual);
4143 return value_cast_pointers (formal_type, result, 0);
4145 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4146 return ada_value_ind (actual);
4151 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4152 type TYPE. This is usually an inefficient no-op except on some targets
4153 (such as AVR) where the representation of a pointer and an address
4157 value_pointer (struct value *value, struct type *type)
4159 struct gdbarch *gdbarch = get_type_arch (type);
4160 unsigned len = TYPE_LENGTH (type);
4161 gdb_byte *buf = alloca (len);
4164 addr = value_address (value);
4165 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4166 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4171 /* Push a descriptor of type TYPE for array value ARR on the stack at
4172 *SP, updating *SP to reflect the new descriptor. Return either
4173 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4174 to-descriptor type rather than a descriptor type), a struct value *
4175 representing a pointer to this descriptor. */
4177 static struct value *
4178 make_array_descriptor (struct type *type, struct value *arr)
4180 struct type *bounds_type = desc_bounds_type (type);
4181 struct type *desc_type = desc_base_type (type);
4182 struct value *descriptor = allocate_value (desc_type);
4183 struct value *bounds = allocate_value (bounds_type);
4186 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4189 modify_field (value_type (bounds), value_contents_writeable (bounds),
4190 ada_array_bound (arr, i, 0),
4191 desc_bound_bitpos (bounds_type, i, 0),
4192 desc_bound_bitsize (bounds_type, i, 0));
4193 modify_field (value_type (bounds), value_contents_writeable (bounds),
4194 ada_array_bound (arr, i, 1),
4195 desc_bound_bitpos (bounds_type, i, 1),
4196 desc_bound_bitsize (bounds_type, i, 1));
4199 bounds = ensure_lval (bounds);
4201 modify_field (value_type (descriptor),
4202 value_contents_writeable (descriptor),
4203 value_pointer (ensure_lval (arr),
4204 TYPE_FIELD_TYPE (desc_type, 0)),
4205 fat_pntr_data_bitpos (desc_type),
4206 fat_pntr_data_bitsize (desc_type));
4208 modify_field (value_type (descriptor),
4209 value_contents_writeable (descriptor),
4210 value_pointer (bounds,
4211 TYPE_FIELD_TYPE (desc_type, 1)),
4212 fat_pntr_bounds_bitpos (desc_type),
4213 fat_pntr_bounds_bitsize (desc_type));
4215 descriptor = ensure_lval (descriptor);
4217 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4218 return value_addr (descriptor);
4223 /* Dummy definitions for an experimental caching module that is not
4224 * used in the public sources. */
4227 lookup_cached_symbol (const char *name, domain_enum namespace,
4228 struct symbol **sym, struct block **block)
4234 cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
4235 const struct block *block)
4241 /* Return nonzero if wild matching should be used when searching for
4242 all symbols matching LOOKUP_NAME.
4244 LOOKUP_NAME is expected to be a symbol name after transformation
4245 for Ada lookups (see ada_name_for_lookup). */
4248 should_use_wild_match (const char *lookup_name)
4250 return (strstr (lookup_name, "__") == NULL);
4253 /* Return the result of a standard (literal, C-like) lookup of NAME in
4254 given DOMAIN, visible from lexical block BLOCK. */
4256 static struct symbol *
4257 standard_lookup (const char *name, const struct block *block,
4260 /* Initialize it just to avoid a GCC false warning. */
4261 struct symbol *sym = NULL;
4263 if (lookup_cached_symbol (name, domain, &sym, NULL))
4265 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4266 cache_symbol (name, domain, sym, block_found);
4271 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4272 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4273 since they contend in overloading in the same way. */
4275 is_nonfunction (struct ada_symbol_info syms[], int n)
4279 for (i = 0; i < n; i += 1)
4280 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4281 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4282 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
4288 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4289 struct types. Otherwise, they may not. */
4292 equiv_types (struct type *type0, struct type *type1)
4296 if (type0 == NULL || type1 == NULL
4297 || TYPE_CODE (type0) != TYPE_CODE (type1))
4299 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4300 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4301 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4302 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4308 /* True iff SYM0 represents the same entity as SYM1, or one that is
4309 no more defined than that of SYM1. */
4312 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4316 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4317 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4320 switch (SYMBOL_CLASS (sym0))
4326 struct type *type0 = SYMBOL_TYPE (sym0);
4327 struct type *type1 = SYMBOL_TYPE (sym1);
4328 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4329 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4330 int len0 = strlen (name0);
4333 TYPE_CODE (type0) == TYPE_CODE (type1)
4334 && (equiv_types (type0, type1)
4335 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4336 && strncmp (name1 + len0, "___XV", 5) == 0));
4339 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4340 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4346 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4347 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4350 add_defn_to_vec (struct obstack *obstackp,
4352 struct block *block)
4355 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
4357 /* Do not try to complete stub types, as the debugger is probably
4358 already scanning all symbols matching a certain name at the
4359 time when this function is called. Trying to replace the stub
4360 type by its associated full type will cause us to restart a scan
4361 which may lead to an infinite recursion. Instead, the client
4362 collecting the matching symbols will end up collecting several
4363 matches, with at least one of them complete. It can then filter
4364 out the stub ones if needed. */
4366 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4368 if (lesseq_defined_than (sym, prevDefns[i].sym))
4370 else if (lesseq_defined_than (prevDefns[i].sym, sym))
4372 prevDefns[i].sym = sym;
4373 prevDefns[i].block = block;
4379 struct ada_symbol_info info;
4383 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4387 /* Number of ada_symbol_info structures currently collected in
4388 current vector in *OBSTACKP. */
4391 num_defns_collected (struct obstack *obstackp)
4393 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4396 /* Vector of ada_symbol_info structures currently collected in current
4397 vector in *OBSTACKP. If FINISH, close off the vector and return
4398 its final address. */
4400 static struct ada_symbol_info *
4401 defns_collected (struct obstack *obstackp, int finish)
4404 return obstack_finish (obstackp);
4406 return (struct ada_symbol_info *) obstack_base (obstackp);
4409 /* Return a bound minimal symbol matching NAME according to Ada
4410 decoding rules. Returns an invalid symbol if there is no such
4411 minimal symbol. Names prefixed with "standard__" are handled
4412 specially: "standard__" is first stripped off, and only static and
4413 global symbols are searched. */
4415 struct bound_minimal_symbol
4416 ada_lookup_simple_minsym (const char *name)
4418 struct bound_minimal_symbol result;
4419 struct objfile *objfile;
4420 struct minimal_symbol *msymbol;
4421 const int wild_match_p = should_use_wild_match (name);
4423 memset (&result, 0, sizeof (result));
4425 /* Special case: If the user specifies a symbol name inside package
4426 Standard, do a non-wild matching of the symbol name without
4427 the "standard__" prefix. This was primarily introduced in order
4428 to allow the user to specifically access the standard exceptions
4429 using, for instance, Standard.Constraint_Error when Constraint_Error
4430 is ambiguous (due to the user defining its own Constraint_Error
4431 entity inside its program). */
4432 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
4433 name += sizeof ("standard__") - 1;
4435 ALL_MSYMBOLS (objfile, msymbol)
4437 if (match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
4438 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4440 result.minsym = msymbol;
4441 result.objfile = objfile;
4449 /* For all subprograms that statically enclose the subprogram of the
4450 selected frame, add symbols matching identifier NAME in DOMAIN
4451 and their blocks to the list of data in OBSTACKP, as for
4452 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4453 with a wildcard prefix. */
4456 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4457 const char *name, domain_enum namespace,
4462 /* True if TYPE is definitely an artificial type supplied to a symbol
4463 for which no debugging information was given in the symbol file. */
4466 is_nondebugging_type (struct type *type)
4468 const char *name = ada_type_name (type);
4470 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4473 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4474 that are deemed "identical" for practical purposes.
4476 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4477 types and that their number of enumerals is identical (in other
4478 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4481 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4485 /* The heuristic we use here is fairly conservative. We consider
4486 that 2 enumerate types are identical if they have the same
4487 number of enumerals and that all enumerals have the same
4488 underlying value and name. */
4490 /* All enums in the type should have an identical underlying value. */
4491 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4492 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
4495 /* All enumerals should also have the same name (modulo any numerical
4497 for (i = 0; i < TYPE_NFIELDS (type1); i++)
4499 const char *name_1 = TYPE_FIELD_NAME (type1, i);
4500 const char *name_2 = TYPE_FIELD_NAME (type2, i);
4501 int len_1 = strlen (name_1);
4502 int len_2 = strlen (name_2);
4504 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4505 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4507 || strncmp (TYPE_FIELD_NAME (type1, i),
4508 TYPE_FIELD_NAME (type2, i),
4516 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4517 that are deemed "identical" for practical purposes. Sometimes,
4518 enumerals are not strictly identical, but their types are so similar
4519 that they can be considered identical.
4521 For instance, consider the following code:
4523 type Color is (Black, Red, Green, Blue, White);
4524 type RGB_Color is new Color range Red .. Blue;
4526 Type RGB_Color is a subrange of an implicit type which is a copy
4527 of type Color. If we call that implicit type RGB_ColorB ("B" is
4528 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4529 As a result, when an expression references any of the enumeral
4530 by name (Eg. "print green"), the expression is technically
4531 ambiguous and the user should be asked to disambiguate. But
4532 doing so would only hinder the user, since it wouldn't matter
4533 what choice he makes, the outcome would always be the same.
4534 So, for practical purposes, we consider them as the same. */
4537 symbols_are_identical_enums (struct ada_symbol_info *syms, int nsyms)
4541 /* Before performing a thorough comparison check of each type,
4542 we perform a series of inexpensive checks. We expect that these
4543 checks will quickly fail in the vast majority of cases, and thus
4544 help prevent the unnecessary use of a more expensive comparison.
4545 Said comparison also expects us to make some of these checks
4546 (see ada_identical_enum_types_p). */
4548 /* Quick check: All symbols should have an enum type. */
4549 for (i = 0; i < nsyms; i++)
4550 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM)
4553 /* Quick check: They should all have the same value. */
4554 for (i = 1; i < nsyms; i++)
4555 if (SYMBOL_VALUE (syms[i].sym) != SYMBOL_VALUE (syms[0].sym))
4558 /* Quick check: They should all have the same number of enumerals. */
4559 for (i = 1; i < nsyms; i++)
4560 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].sym))
4561 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].sym)))
4564 /* All the sanity checks passed, so we might have a set of
4565 identical enumeration types. Perform a more complete
4566 comparison of the type of each symbol. */
4567 for (i = 1; i < nsyms; i++)
4568 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].sym),
4569 SYMBOL_TYPE (syms[0].sym)))
4575 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4576 duplicate other symbols in the list (The only case I know of where
4577 this happens is when object files containing stabs-in-ecoff are
4578 linked with files containing ordinary ecoff debugging symbols (or no
4579 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4580 Returns the number of items in the modified list. */
4583 remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4587 /* We should never be called with less than 2 symbols, as there
4588 cannot be any extra symbol in that case. But it's easy to
4589 handle, since we have nothing to do in that case. */
4598 /* If two symbols have the same name and one of them is a stub type,
4599 the get rid of the stub. */
4601 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4602 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4604 for (j = 0; j < nsyms; j++)
4607 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4608 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4609 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4610 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
4615 /* Two symbols with the same name, same class and same address
4616 should be identical. */
4618 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
4619 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4620 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4622 for (j = 0; j < nsyms; j += 1)
4625 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4626 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4627 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
4628 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4629 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4630 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
4637 for (j = i + 1; j < nsyms; j += 1)
4638 syms[j - 1] = syms[j];
4645 /* If all the remaining symbols are identical enumerals, then
4646 just keep the first one and discard the rest.
4648 Unlike what we did previously, we do not discard any entry
4649 unless they are ALL identical. This is because the symbol
4650 comparison is not a strict comparison, but rather a practical
4651 comparison. If all symbols are considered identical, then
4652 we can just go ahead and use the first one and discard the rest.
4653 But if we cannot reduce the list to a single element, we have
4654 to ask the user to disambiguate anyways. And if we have to
4655 present a multiple-choice menu, it's less confusing if the list
4656 isn't missing some choices that were identical and yet distinct. */
4657 if (symbols_are_identical_enums (syms, nsyms))
4663 /* Given a type that corresponds to a renaming entity, use the type name
4664 to extract the scope (package name or function name, fully qualified,
4665 and following the GNAT encoding convention) where this renaming has been
4666 defined. The string returned needs to be deallocated after use. */
4669 xget_renaming_scope (struct type *renaming_type)
4671 /* The renaming types adhere to the following convention:
4672 <scope>__<rename>___<XR extension>.
4673 So, to extract the scope, we search for the "___XR" extension,
4674 and then backtrack until we find the first "__". */
4676 const char *name = type_name_no_tag (renaming_type);
4677 char *suffix = strstr (name, "___XR");
4682 /* Now, backtrack a bit until we find the first "__". Start looking
4683 at suffix - 3, as the <rename> part is at least one character long. */
4685 for (last = suffix - 3; last > name; last--)
4686 if (last[0] == '_' && last[1] == '_')
4689 /* Make a copy of scope and return it. */
4691 scope_len = last - name;
4692 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
4694 strncpy (scope, name, scope_len);
4695 scope[scope_len] = '\0';
4700 /* Return nonzero if NAME corresponds to a package name. */
4703 is_package_name (const char *name)
4705 /* Here, We take advantage of the fact that no symbols are generated
4706 for packages, while symbols are generated for each function.
4707 So the condition for NAME represent a package becomes equivalent
4708 to NAME not existing in our list of symbols. There is only one
4709 small complication with library-level functions (see below). */
4713 /* If it is a function that has not been defined at library level,
4714 then we should be able to look it up in the symbols. */
4715 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4718 /* Library-level function names start with "_ada_". See if function
4719 "_ada_" followed by NAME can be found. */
4721 /* Do a quick check that NAME does not contain "__", since library-level
4722 functions names cannot contain "__" in them. */
4723 if (strstr (name, "__") != NULL)
4726 fun_name = xstrprintf ("_ada_%s", name);
4728 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4731 /* Return nonzero if SYM corresponds to a renaming entity that is
4732 not visible from FUNCTION_NAME. */
4735 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
4738 struct cleanup *old_chain;
4740 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4743 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
4744 old_chain = make_cleanup (xfree, scope);
4746 /* If the rename has been defined in a package, then it is visible. */
4747 if (is_package_name (scope))
4749 do_cleanups (old_chain);
4753 /* Check that the rename is in the current function scope by checking
4754 that its name starts with SCOPE. */
4756 /* If the function name starts with "_ada_", it means that it is
4757 a library-level function. Strip this prefix before doing the
4758 comparison, as the encoding for the renaming does not contain
4760 if (strncmp (function_name, "_ada_", 5) == 0)
4764 int is_invisible = strncmp (function_name, scope, strlen (scope)) != 0;
4766 do_cleanups (old_chain);
4767 return is_invisible;
4771 /* Remove entries from SYMS that corresponds to a renaming entity that
4772 is not visible from the function associated with CURRENT_BLOCK or
4773 that is superfluous due to the presence of more specific renaming
4774 information. Places surviving symbols in the initial entries of
4775 SYMS and returns the number of surviving symbols.
4778 First, in cases where an object renaming is implemented as a
4779 reference variable, GNAT may produce both the actual reference
4780 variable and the renaming encoding. In this case, we discard the
4783 Second, GNAT emits a type following a specified encoding for each renaming
4784 entity. Unfortunately, STABS currently does not support the definition
4785 of types that are local to a given lexical block, so all renamings types
4786 are emitted at library level. As a consequence, if an application
4787 contains two renaming entities using the same name, and a user tries to
4788 print the value of one of these entities, the result of the ada symbol
4789 lookup will also contain the wrong renaming type.
4791 This function partially covers for this limitation by attempting to
4792 remove from the SYMS list renaming symbols that should be visible
4793 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4794 method with the current information available. The implementation
4795 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4797 - When the user tries to print a rename in a function while there
4798 is another rename entity defined in a package: Normally, the
4799 rename in the function has precedence over the rename in the
4800 package, so the latter should be removed from the list. This is
4801 currently not the case.
4803 - This function will incorrectly remove valid renames if
4804 the CURRENT_BLOCK corresponds to a function which symbol name
4805 has been changed by an "Export" pragma. As a consequence,
4806 the user will be unable to print such rename entities. */
4809 remove_irrelevant_renamings (struct ada_symbol_info *syms,
4810 int nsyms, const struct block *current_block)
4812 struct symbol *current_function;
4813 const char *current_function_name;
4815 int is_new_style_renaming;
4817 /* If there is both a renaming foo___XR... encoded as a variable and
4818 a simple variable foo in the same block, discard the latter.
4819 First, zero out such symbols, then compress. */
4820 is_new_style_renaming = 0;
4821 for (i = 0; i < nsyms; i += 1)
4823 struct symbol *sym = syms[i].sym;
4824 const struct block *block = syms[i].block;
4828 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4830 name = SYMBOL_LINKAGE_NAME (sym);
4831 suffix = strstr (name, "___XR");
4835 int name_len = suffix - name;
4838 is_new_style_renaming = 1;
4839 for (j = 0; j < nsyms; j += 1)
4840 if (i != j && syms[j].sym != NULL
4841 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
4843 && block == syms[j].block)
4847 if (is_new_style_renaming)
4851 for (j = k = 0; j < nsyms; j += 1)
4852 if (syms[j].sym != NULL)
4860 /* Extract the function name associated to CURRENT_BLOCK.
4861 Abort if unable to do so. */
4863 if (current_block == NULL)
4866 current_function = block_linkage_function (current_block);
4867 if (current_function == NULL)
4870 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4871 if (current_function_name == NULL)
4874 /* Check each of the symbols, and remove it from the list if it is
4875 a type corresponding to a renaming that is out of the scope of
4876 the current block. */
4881 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
4882 == ADA_OBJECT_RENAMING
4883 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4887 for (j = i + 1; j < nsyms; j += 1)
4888 syms[j - 1] = syms[j];
4898 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4899 whose name and domain match NAME and DOMAIN respectively.
4900 If no match was found, then extend the search to "enclosing"
4901 routines (in other words, if we're inside a nested function,
4902 search the symbols defined inside the enclosing functions).
4903 If WILD_MATCH_P is nonzero, perform the naming matching in
4904 "wild" mode (see function "wild_match" for more info).
4906 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4909 ada_add_local_symbols (struct obstack *obstackp, const char *name,
4910 struct block *block, domain_enum domain,
4913 int block_depth = 0;
4915 while (block != NULL)
4918 ada_add_block_symbols (obstackp, block, name, domain, NULL,
4921 /* If we found a non-function match, assume that's the one. */
4922 if (is_nonfunction (defns_collected (obstackp, 0),
4923 num_defns_collected (obstackp)))
4926 block = BLOCK_SUPERBLOCK (block);
4929 /* If no luck so far, try to find NAME as a local symbol in some lexically
4930 enclosing subprogram. */
4931 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
4932 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
4935 /* An object of this type is used as the user_data argument when
4936 calling the map_matching_symbols method. */
4940 struct objfile *objfile;
4941 struct obstack *obstackp;
4942 struct symbol *arg_sym;
4946 /* A callback for add_matching_symbols that adds SYM, found in BLOCK,
4947 to a list of symbols. DATA0 is a pointer to a struct match_data *
4948 containing the obstack that collects the symbol list, the file that SYM
4949 must come from, a flag indicating whether a non-argument symbol has
4950 been found in the current block, and the last argument symbol
4951 passed in SYM within the current block (if any). When SYM is null,
4952 marking the end of a block, the argument symbol is added if no
4953 other has been found. */
4956 aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
4958 struct match_data *data = (struct match_data *) data0;
4962 if (!data->found_sym && data->arg_sym != NULL)
4963 add_defn_to_vec (data->obstackp,
4964 fixup_symbol_section (data->arg_sym, data->objfile),
4966 data->found_sym = 0;
4967 data->arg_sym = NULL;
4971 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
4973 else if (SYMBOL_IS_ARGUMENT (sym))
4974 data->arg_sym = sym;
4977 data->found_sym = 1;
4978 add_defn_to_vec (data->obstackp,
4979 fixup_symbol_section (sym, data->objfile),
4986 /* Implements compare_names, but only applying the comparision using
4987 the given CASING. */
4990 compare_names_with_case (const char *string1, const char *string2,
4991 enum case_sensitivity casing)
4993 while (*string1 != '\0' && *string2 != '\0')
4997 if (isspace (*string1) || isspace (*string2))
4998 return strcmp_iw_ordered (string1, string2);
5000 if (casing == case_sensitive_off)
5002 c1 = tolower (*string1);
5003 c2 = tolower (*string2);
5020 return strcmp_iw_ordered (string1, string2);
5022 if (*string2 == '\0')
5024 if (is_name_suffix (string1))
5031 if (*string2 == '(')
5032 return strcmp_iw_ordered (string1, string2);
5035 if (casing == case_sensitive_off)
5036 return tolower (*string1) - tolower (*string2);
5038 return *string1 - *string2;
5043 /* Compare STRING1 to STRING2, with results as for strcmp.
5044 Compatible with strcmp_iw_ordered in that...
5046 strcmp_iw_ordered (STRING1, STRING2) <= 0
5050 compare_names (STRING1, STRING2) <= 0
5052 (they may differ as to what symbols compare equal). */
5055 compare_names (const char *string1, const char *string2)
5059 /* Similar to what strcmp_iw_ordered does, we need to perform
5060 a case-insensitive comparison first, and only resort to
5061 a second, case-sensitive, comparison if the first one was
5062 not sufficient to differentiate the two strings. */
5064 result = compare_names_with_case (string1, string2, case_sensitive_off);
5066 result = compare_names_with_case (string1, string2, case_sensitive_on);
5071 /* Add to OBSTACKP all non-local symbols whose name and domain match
5072 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5073 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5076 add_nonlocal_symbols (struct obstack *obstackp, const char *name,
5077 domain_enum domain, int global,
5080 struct objfile *objfile;
5081 struct match_data data;
5083 memset (&data, 0, sizeof data);
5084 data.obstackp = obstackp;
5086 ALL_OBJFILES (objfile)
5088 data.objfile = objfile;
5091 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5092 aux_add_nonlocal_symbols, &data,
5095 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5096 aux_add_nonlocal_symbols, &data,
5097 full_match, compare_names);
5100 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5102 ALL_OBJFILES (objfile)
5104 char *name1 = alloca (strlen (name) + sizeof ("_ada_"));
5105 strcpy (name1, "_ada_");
5106 strcpy (name1 + sizeof ("_ada_") - 1, name);
5107 data.objfile = objfile;
5108 objfile->sf->qf->map_matching_symbols (objfile, name1, domain,
5110 aux_add_nonlocal_symbols,
5112 full_match, compare_names);
5117 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is
5118 non-zero, enclosing scope and in global scopes, returning the number of
5120 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
5121 indicating the symbols found and the blocks and symbol tables (if
5122 any) in which they were found. This vector is transient---good only to
5123 the next call of ada_lookup_symbol_list.
5125 When full_search is non-zero, any non-function/non-enumeral
5126 symbol match within the nest of blocks whose innermost member is BLOCK0,
5127 is the one match returned (no other matches in that or
5128 enclosing blocks is returned). If there are any matches in or
5129 surrounding BLOCK0, then these alone are returned.
5131 Names prefixed with "standard__" are handled specially: "standard__"
5132 is first stripped off, and only static and global symbols are searched. */
5135 ada_lookup_symbol_list_worker (const char *name0, const struct block *block0,
5136 domain_enum namespace,
5137 struct ada_symbol_info **results,
5141 struct block *block;
5143 const int wild_match_p = should_use_wild_match (name0);
5147 obstack_free (&symbol_list_obstack, NULL);
5148 obstack_init (&symbol_list_obstack);
5152 /* Search specified block and its superiors. */
5155 block = (struct block *) block0; /* FIXME: No cast ought to be
5156 needed, but adding const will
5157 have a cascade effect. */
5159 /* Special case: If the user specifies a symbol name inside package
5160 Standard, do a non-wild matching of the symbol name without
5161 the "standard__" prefix. This was primarily introduced in order
5162 to allow the user to specifically access the standard exceptions
5163 using, for instance, Standard.Constraint_Error when Constraint_Error
5164 is ambiguous (due to the user defining its own Constraint_Error
5165 entity inside its program). */
5166 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
5169 name = name0 + sizeof ("standard__") - 1;
5172 /* Check the non-global symbols. If we have ANY match, then we're done. */
5178 ada_add_local_symbols (&symbol_list_obstack, name, block,
5179 namespace, wild_match_p);
5183 /* In the !full_search case we're are being called by
5184 ada_iterate_over_symbols, and we don't want to search
5186 ada_add_block_symbols (&symbol_list_obstack, block, name,
5187 namespace, NULL, wild_match_p);
5189 if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
5193 /* No non-global symbols found. Check our cache to see if we have
5194 already performed this search before. If we have, then return
5198 if (lookup_cached_symbol (name0, namespace, &sym, &block))
5201 add_defn_to_vec (&symbol_list_obstack, sym, block);
5205 /* Search symbols from all global blocks. */
5207 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 1,
5210 /* Now add symbols from all per-file blocks if we've gotten no hits
5211 (not strictly correct, but perhaps better than an error). */
5213 if (num_defns_collected (&symbol_list_obstack) == 0)
5214 add_nonlocal_symbols (&symbol_list_obstack, name, namespace, 0,
5218 ndefns = num_defns_collected (&symbol_list_obstack);
5219 *results = defns_collected (&symbol_list_obstack, 1);
5221 ndefns = remove_extra_symbols (*results, ndefns);
5223 if (ndefns == 0 && full_search)
5224 cache_symbol (name0, namespace, NULL, NULL);
5226 if (ndefns == 1 && full_search && cacheIfUnique)
5227 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
5229 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
5234 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5235 in global scopes, returning the number of matches, and setting *RESULTS
5236 to a vector of (SYM,BLOCK) tuples.
5237 See ada_lookup_symbol_list_worker for further details. */
5240 ada_lookup_symbol_list (const char *name0, const struct block *block0,
5241 domain_enum domain, struct ada_symbol_info **results)
5243 return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1);
5246 /* Implementation of the la_iterate_over_symbols method. */
5249 ada_iterate_over_symbols (const struct block *block,
5250 const char *name, domain_enum domain,
5251 symbol_found_callback_ftype *callback,
5255 struct ada_symbol_info *results;
5257 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5258 for (i = 0; i < ndefs; ++i)
5260 if (! (*callback) (results[i].sym, data))
5265 /* If NAME is the name of an entity, return a string that should
5266 be used to look that entity up in Ada units. This string should
5267 be deallocated after use using xfree.
5269 NAME can have any form that the "break" or "print" commands might
5270 recognize. In other words, it does not have to be the "natural"
5271 name, or the "encoded" name. */
5274 ada_name_for_lookup (const char *name)
5277 int nlen = strlen (name);
5279 if (name[0] == '<' && name[nlen - 1] == '>')
5281 canon = xmalloc (nlen - 1);
5282 memcpy (canon, name + 1, nlen - 2);
5283 canon[nlen - 2] = '\0';
5286 canon = xstrdup (ada_encode (ada_fold_name (name)));
5290 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5291 to 1, but choosing the first symbol found if there are multiple
5294 The result is stored in *INFO, which must be non-NULL.
5295 If no match is found, INFO->SYM is set to NULL. */
5298 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5299 domain_enum namespace,
5300 struct ada_symbol_info *info)
5302 struct ada_symbol_info *candidates;
5305 gdb_assert (info != NULL);
5306 memset (info, 0, sizeof (struct ada_symbol_info));
5308 n_candidates = ada_lookup_symbol_list (name, block, namespace, &candidates);
5309 if (n_candidates == 0)
5312 *info = candidates[0];
5313 info->sym = fixup_symbol_section (info->sym, NULL);
5316 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5317 scope and in global scopes, or NULL if none. NAME is folded and
5318 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5319 choosing the first symbol if there are multiple choices.
5320 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5323 ada_lookup_symbol (const char *name, const struct block *block0,
5324 domain_enum namespace, int *is_a_field_of_this)
5326 struct ada_symbol_info info;
5328 if (is_a_field_of_this != NULL)
5329 *is_a_field_of_this = 0;
5331 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
5332 block0, namespace, &info);
5336 static struct symbol *
5337 ada_lookup_symbol_nonlocal (const char *name,
5338 const struct block *block,
5339 const domain_enum domain)
5341 return ada_lookup_symbol (name, block_static_block (block), domain, NULL);
5345 /* True iff STR is a possible encoded suffix of a normal Ada name
5346 that is to be ignored for matching purposes. Suffixes of parallel
5347 names (e.g., XVE) are not included here. Currently, the possible suffixes
5348 are given by any of the regular expressions:
5350 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5351 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5352 TKB [subprogram suffix for task bodies]
5353 _E[0-9]+[bs]$ [protected object entry suffixes]
5354 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5356 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5357 match is performed. This sequence is used to differentiate homonyms,
5358 is an optional part of a valid name suffix. */
5361 is_name_suffix (const char *str)
5364 const char *matching;
5365 const int len = strlen (str);
5367 /* Skip optional leading __[0-9]+. */
5369 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5372 while (isdigit (str[0]))
5378 if (str[0] == '.' || str[0] == '$')
5381 while (isdigit (matching[0]))
5383 if (matching[0] == '\0')
5389 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5392 while (isdigit (matching[0]))
5394 if (matching[0] == '\0')
5398 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5400 if (strcmp (str, "TKB") == 0)
5404 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5405 with a N at the end. Unfortunately, the compiler uses the same
5406 convention for other internal types it creates. So treating
5407 all entity names that end with an "N" as a name suffix causes
5408 some regressions. For instance, consider the case of an enumerated
5409 type. To support the 'Image attribute, it creates an array whose
5411 Having a single character like this as a suffix carrying some
5412 information is a bit risky. Perhaps we should change the encoding
5413 to be something like "_N" instead. In the meantime, do not do
5414 the following check. */
5415 /* Protected Object Subprograms */
5416 if (len == 1 && str [0] == 'N')
5421 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5424 while (isdigit (matching[0]))
5426 if ((matching[0] == 'b' || matching[0] == 's')
5427 && matching [1] == '\0')
5431 /* ??? We should not modify STR directly, as we are doing below. This
5432 is fine in this case, but may become problematic later if we find
5433 that this alternative did not work, and want to try matching
5434 another one from the begining of STR. Since we modified it, we
5435 won't be able to find the begining of the string anymore! */
5439 while (str[0] != '_' && str[0] != '\0')
5441 if (str[0] != 'n' && str[0] != 'b')
5447 if (str[0] == '\000')
5452 if (str[1] != '_' || str[2] == '\000')
5456 if (strcmp (str + 3, "JM") == 0)
5458 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5459 the LJM suffix in favor of the JM one. But we will
5460 still accept LJM as a valid suffix for a reasonable
5461 amount of time, just to allow ourselves to debug programs
5462 compiled using an older version of GNAT. */
5463 if (strcmp (str + 3, "LJM") == 0)
5467 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5468 || str[4] == 'U' || str[4] == 'P')
5470 if (str[4] == 'R' && str[5] != 'T')
5474 if (!isdigit (str[2]))
5476 for (k = 3; str[k] != '\0'; k += 1)
5477 if (!isdigit (str[k]) && str[k] != '_')
5481 if (str[0] == '$' && isdigit (str[1]))
5483 for (k = 2; str[k] != '\0'; k += 1)
5484 if (!isdigit (str[k]) && str[k] != '_')
5491 /* Return non-zero if the string starting at NAME and ending before
5492 NAME_END contains no capital letters. */
5495 is_valid_name_for_wild_match (const char *name0)
5497 const char *decoded_name = ada_decode (name0);
5500 /* If the decoded name starts with an angle bracket, it means that
5501 NAME0 does not follow the GNAT encoding format. It should then
5502 not be allowed as a possible wild match. */
5503 if (decoded_name[0] == '<')
5506 for (i=0; decoded_name[i] != '\0'; i++)
5507 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5513 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5514 that could start a simple name. Assumes that *NAMEP points into
5515 the string beginning at NAME0. */
5518 advance_wild_match (const char **namep, const char *name0, int target0)
5520 const char *name = *namep;
5530 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5533 if (name == name0 + 5 && strncmp (name0, "_ada", 4) == 0)
5538 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5539 || name[2] == target0))
5547 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5557 /* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5558 informational suffixes of NAME (i.e., for which is_name_suffix is
5559 true). Assumes that PATN is a lower-cased Ada simple name. */
5562 wild_match (const char *name, const char *patn)
5565 const char *name0 = name;
5569 const char *match = name;
5573 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5576 if (*p == '\0' && is_name_suffix (name))
5577 return match != name0 && !is_valid_name_for_wild_match (name0);
5579 if (name[-1] == '_')
5582 if (!advance_wild_match (&name, name0, *patn))
5587 /* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5588 informational suffix. */
5591 full_match (const char *sym_name, const char *search_name)
5593 return !match_name (sym_name, search_name, 0);
5597 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5598 vector *defn_symbols, updating the list of symbols in OBSTACKP
5599 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5600 OBJFILE is the section containing BLOCK. */
5603 ada_add_block_symbols (struct obstack *obstackp,
5604 struct block *block, const char *name,
5605 domain_enum domain, struct objfile *objfile,
5608 struct block_iterator iter;
5609 int name_len = strlen (name);
5610 /* A matching argument symbol, if any. */
5611 struct symbol *arg_sym;
5612 /* Set true when we find a matching non-argument symbol. */
5620 for (sym = block_iter_match_first (block, name, wild_match, &iter);
5621 sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
5623 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5624 SYMBOL_DOMAIN (sym), domain)
5625 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
5627 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5629 else if (SYMBOL_IS_ARGUMENT (sym))
5634 add_defn_to_vec (obstackp,
5635 fixup_symbol_section (sym, objfile),
5643 for (sym = block_iter_match_first (block, name, full_match, &iter);
5644 sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
5646 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5647 SYMBOL_DOMAIN (sym), domain))
5649 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5651 if (SYMBOL_IS_ARGUMENT (sym))
5656 add_defn_to_vec (obstackp,
5657 fixup_symbol_section (sym, objfile),
5665 if (!found_sym && arg_sym != NULL)
5667 add_defn_to_vec (obstackp,
5668 fixup_symbol_section (arg_sym, objfile),
5677 ALL_BLOCK_SYMBOLS (block, iter, sym)
5679 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5680 SYMBOL_DOMAIN (sym), domain))
5684 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5687 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5689 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5694 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5696 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5698 if (SYMBOL_IS_ARGUMENT (sym))
5703 add_defn_to_vec (obstackp,
5704 fixup_symbol_section (sym, objfile),
5712 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5713 They aren't parameters, right? */
5714 if (!found_sym && arg_sym != NULL)
5716 add_defn_to_vec (obstackp,
5717 fixup_symbol_section (arg_sym, objfile),
5724 /* Symbol Completion */
5726 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5727 name in a form that's appropriate for the completion. The result
5728 does not need to be deallocated, but is only good until the next call.
5730 TEXT_LEN is equal to the length of TEXT.
5731 Perform a wild match if WILD_MATCH_P is set.
5732 ENCODED_P should be set if TEXT represents the start of a symbol name
5733 in its encoded form. */
5736 symbol_completion_match (const char *sym_name,
5737 const char *text, int text_len,
5738 int wild_match_p, int encoded_p)
5740 const int verbatim_match = (text[0] == '<');
5745 /* Strip the leading angle bracket. */
5750 /* First, test against the fully qualified name of the symbol. */
5752 if (strncmp (sym_name, text, text_len) == 0)
5755 if (match && !encoded_p)
5757 /* One needed check before declaring a positive match is to verify
5758 that iff we are doing a verbatim match, the decoded version
5759 of the symbol name starts with '<'. Otherwise, this symbol name
5760 is not a suitable completion. */
5761 const char *sym_name_copy = sym_name;
5762 int has_angle_bracket;
5764 sym_name = ada_decode (sym_name);
5765 has_angle_bracket = (sym_name[0] == '<');
5766 match = (has_angle_bracket == verbatim_match);
5767 sym_name = sym_name_copy;
5770 if (match && !verbatim_match)
5772 /* When doing non-verbatim match, another check that needs to
5773 be done is to verify that the potentially matching symbol name
5774 does not include capital letters, because the ada-mode would
5775 not be able to understand these symbol names without the
5776 angle bracket notation. */
5779 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5784 /* Second: Try wild matching... */
5786 if (!match && wild_match_p)
5788 /* Since we are doing wild matching, this means that TEXT
5789 may represent an unqualified symbol name. We therefore must
5790 also compare TEXT against the unqualified name of the symbol. */
5791 sym_name = ada_unqualified_name (ada_decode (sym_name));
5793 if (strncmp (sym_name, text, text_len) == 0)
5797 /* Finally: If we found a mach, prepare the result to return. */
5803 sym_name = add_angle_brackets (sym_name);
5806 sym_name = ada_decode (sym_name);
5811 /* A companion function to ada_make_symbol_completion_list().
5812 Check if SYM_NAME represents a symbol which name would be suitable
5813 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5814 it is appended at the end of the given string vector SV.
5816 ORIG_TEXT is the string original string from the user command
5817 that needs to be completed. WORD is the entire command on which
5818 completion should be performed. These two parameters are used to
5819 determine which part of the symbol name should be added to the
5821 if WILD_MATCH_P is set, then wild matching is performed.
5822 ENCODED_P should be set if TEXT represents a symbol name in its
5823 encoded formed (in which case the completion should also be
5827 symbol_completion_add (VEC(char_ptr) **sv,
5828 const char *sym_name,
5829 const char *text, int text_len,
5830 const char *orig_text, const char *word,
5831 int wild_match_p, int encoded_p)
5833 const char *match = symbol_completion_match (sym_name, text, text_len,
5834 wild_match_p, encoded_p);
5840 /* We found a match, so add the appropriate completion to the given
5843 if (word == orig_text)
5845 completion = xmalloc (strlen (match) + 5);
5846 strcpy (completion, match);
5848 else if (word > orig_text)
5850 /* Return some portion of sym_name. */
5851 completion = xmalloc (strlen (match) + 5);
5852 strcpy (completion, match + (word - orig_text));
5856 /* Return some of ORIG_TEXT plus sym_name. */
5857 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
5858 strncpy (completion, word, orig_text - word);
5859 completion[orig_text - word] = '\0';
5860 strcat (completion, match);
5863 VEC_safe_push (char_ptr, *sv, completion);
5866 /* An object of this type is passed as the user_data argument to the
5867 expand_symtabs_matching method. */
5868 struct add_partial_datum
5870 VEC(char_ptr) **completions;
5879 /* A callback for expand_symtabs_matching. */
5882 ada_complete_symbol_matcher (const char *name, void *user_data)
5884 struct add_partial_datum *data = user_data;
5886 return symbol_completion_match (name, data->text, data->text_len,
5887 data->wild_match, data->encoded) != NULL;
5890 /* Return a list of possible symbol names completing TEXT0. WORD is
5891 the entire command on which completion is made. */
5893 static VEC (char_ptr) *
5894 ada_make_symbol_completion_list (const char *text0, const char *word,
5895 enum type_code code)
5901 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
5904 struct minimal_symbol *msymbol;
5905 struct objfile *objfile;
5906 struct block *b, *surrounding_static_block = 0;
5908 struct block_iterator iter;
5909 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
5911 gdb_assert (code == TYPE_CODE_UNDEF);
5913 if (text0[0] == '<')
5915 text = xstrdup (text0);
5916 make_cleanup (xfree, text);
5917 text_len = strlen (text);
5923 text = xstrdup (ada_encode (text0));
5924 make_cleanup (xfree, text);
5925 text_len = strlen (text);
5926 for (i = 0; i < text_len; i++)
5927 text[i] = tolower (text[i]);
5929 encoded_p = (strstr (text0, "__") != NULL);
5930 /* If the name contains a ".", then the user is entering a fully
5931 qualified entity name, and the match must not be done in wild
5932 mode. Similarly, if the user wants to complete what looks like
5933 an encoded name, the match must not be done in wild mode. */
5934 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
5937 /* First, look at the partial symtab symbols. */
5939 struct add_partial_datum data;
5941 data.completions = &completions;
5943 data.text_len = text_len;
5946 data.wild_match = wild_match_p;
5947 data.encoded = encoded_p;
5948 expand_symtabs_matching (NULL, ada_complete_symbol_matcher, ALL_DOMAIN,
5952 /* At this point scan through the misc symbol vectors and add each
5953 symbol you find to the list. Eventually we want to ignore
5954 anything that isn't a text symbol (everything else will be
5955 handled by the psymtab code above). */
5957 ALL_MSYMBOLS (objfile, msymbol)
5960 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
5961 text, text_len, text0, word, wild_match_p,
5965 /* Search upwards from currently selected frame (so that we can
5966 complete on local vars. */
5968 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
5970 if (!BLOCK_SUPERBLOCK (b))
5971 surrounding_static_block = b; /* For elmin of dups */
5973 ALL_BLOCK_SYMBOLS (b, iter, sym)
5975 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5976 text, text_len, text0, word,
5977 wild_match_p, encoded_p);
5981 /* Go through the symtabs and check the externs and statics for
5982 symbols which match. */
5984 ALL_SYMTABS (objfile, s)
5987 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5988 ALL_BLOCK_SYMBOLS (b, iter, sym)
5990 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5991 text, text_len, text0, word,
5992 wild_match_p, encoded_p);
5996 ALL_SYMTABS (objfile, s)
5999 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
6000 /* Don't do this block twice. */
6001 if (b == surrounding_static_block)
6003 ALL_BLOCK_SYMBOLS (b, iter, sym)
6005 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
6006 text, text_len, text0, word,
6007 wild_match_p, encoded_p);
6011 do_cleanups (old_chain);
6017 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6018 for tagged types. */
6021 ada_is_dispatch_table_ptr_type (struct type *type)
6025 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6028 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6032 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6035 /* Return non-zero if TYPE is an interface tag. */
6038 ada_is_interface_tag (struct type *type)
6040 const char *name = TYPE_NAME (type);
6045 return (strcmp (name, "ada__tags__interface_tag") == 0);
6048 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6049 to be invisible to users. */
6052 ada_is_ignored_field (struct type *type, int field_num)
6054 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6057 /* Check the name of that field. */
6059 const char *name = TYPE_FIELD_NAME (type, field_num);
6061 /* Anonymous field names should not be printed.
6062 brobecker/2007-02-20: I don't think this can actually happen
6063 but we don't want to print the value of annonymous fields anyway. */
6067 /* Normally, fields whose name start with an underscore ("_")
6068 are fields that have been internally generated by the compiler,
6069 and thus should not be printed. The "_parent" field is special,
6070 however: This is a field internally generated by the compiler
6071 for tagged types, and it contains the components inherited from
6072 the parent type. This field should not be printed as is, but
6073 should not be ignored either. */
6074 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
6078 /* If this is the dispatch table of a tagged type or an interface tag,
6080 if (ada_is_tagged_type (type, 1)
6081 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6082 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
6085 /* Not a special field, so it should not be ignored. */
6089 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6090 pointer or reference type whose ultimate target has a tag field. */
6093 ada_is_tagged_type (struct type *type, int refok)
6095 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6098 /* True iff TYPE represents the type of X'Tag */
6101 ada_is_tag_type (struct type *type)
6103 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6107 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6109 return (name != NULL
6110 && strcmp (name, "ada__tags__dispatch_table") == 0);
6114 /* The type of the tag on VAL. */
6117 ada_tag_type (struct value *val)
6119 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
6122 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6123 retired at Ada 05). */
6126 is_ada95_tag (struct value *tag)
6128 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6131 /* The value of the tag on VAL. */
6134 ada_value_tag (struct value *val)
6136 return ada_value_struct_elt (val, "_tag", 0);
6139 /* The value of the tag on the object of type TYPE whose contents are
6140 saved at VALADDR, if it is non-null, or is at memory address
6143 static struct value *
6144 value_tag_from_contents_and_address (struct type *type,
6145 const gdb_byte *valaddr,
6148 int tag_byte_offset;
6149 struct type *tag_type;
6151 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6154 const gdb_byte *valaddr1 = ((valaddr == NULL)
6156 : valaddr + tag_byte_offset);
6157 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6159 return value_from_contents_and_address (tag_type, valaddr1, address1);
6164 static struct type *
6165 type_from_tag (struct value *tag)
6167 const char *type_name = ada_tag_name (tag);
6169 if (type_name != NULL)
6170 return ada_find_any_type (ada_encode (type_name));
6174 /* Given a value OBJ of a tagged type, return a value of this
6175 type at the base address of the object. The base address, as
6176 defined in Ada.Tags, it is the address of the primary tag of
6177 the object, and therefore where the field values of its full
6178 view can be fetched. */
6181 ada_tag_value_at_base_address (struct value *obj)
6183 volatile struct gdb_exception e;
6185 LONGEST offset_to_top = 0;
6186 struct type *ptr_type, *obj_type;
6188 CORE_ADDR base_address;
6190 obj_type = value_type (obj);
6192 /* It is the responsability of the caller to deref pointers. */
6194 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6195 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6198 tag = ada_value_tag (obj);
6202 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6204 if (is_ada95_tag (tag))
6207 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6208 ptr_type = lookup_pointer_type (ptr_type);
6209 val = value_cast (ptr_type, tag);
6213 /* It is perfectly possible that an exception be raised while
6214 trying to determine the base address, just like for the tag;
6215 see ada_tag_name for more details. We do not print the error
6216 message for the same reason. */
6218 TRY_CATCH (e, RETURN_MASK_ERROR)
6220 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6226 /* If offset is null, nothing to do. */
6228 if (offset_to_top == 0)
6231 /* -1 is a special case in Ada.Tags; however, what should be done
6232 is not quite clear from the documentation. So do nothing for
6235 if (offset_to_top == -1)
6238 base_address = value_address (obj) - offset_to_top;
6239 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6241 /* Make sure that we have a proper tag at the new address.
6242 Otherwise, offset_to_top is bogus (which can happen when
6243 the object is not initialized yet). */
6248 obj_type = type_from_tag (tag);
6253 return value_from_contents_and_address (obj_type, NULL, base_address);
6256 /* Return the "ada__tags__type_specific_data" type. */
6258 static struct type *
6259 ada_get_tsd_type (struct inferior *inf)
6261 struct ada_inferior_data *data = get_ada_inferior_data (inf);
6263 if (data->tsd_type == 0)
6264 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6265 return data->tsd_type;
6268 /* Return the TSD (type-specific data) associated to the given TAG.
6269 TAG is assumed to be the tag of a tagged-type entity.
6271 May return NULL if we are unable to get the TSD. */
6273 static struct value *
6274 ada_get_tsd_from_tag (struct value *tag)
6279 /* First option: The TSD is simply stored as a field of our TAG.
6280 Only older versions of GNAT would use this format, but we have
6281 to test it first, because there are no visible markers for
6282 the current approach except the absence of that field. */
6284 val = ada_value_struct_elt (tag, "tsd", 1);
6288 /* Try the second representation for the dispatch table (in which
6289 there is no explicit 'tsd' field in the referent of the tag pointer,
6290 and instead the tsd pointer is stored just before the dispatch
6293 type = ada_get_tsd_type (current_inferior());
6296 type = lookup_pointer_type (lookup_pointer_type (type));
6297 val = value_cast (type, tag);
6300 return value_ind (value_ptradd (val, -1));
6303 /* Given the TSD of a tag (type-specific data), return a string
6304 containing the name of the associated type.
6306 The returned value is good until the next call. May return NULL
6307 if we are unable to determine the tag name. */
6310 ada_tag_name_from_tsd (struct value *tsd)
6312 static char name[1024];
6316 val = ada_value_struct_elt (tsd, "expanded_name", 1);
6319 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6320 for (p = name; *p != '\0'; p += 1)
6326 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6329 Return NULL if the TAG is not an Ada tag, or if we were unable to
6330 determine the name of that tag. The result is good until the next
6334 ada_tag_name (struct value *tag)
6336 volatile struct gdb_exception e;
6339 if (!ada_is_tag_type (value_type (tag)))
6342 /* It is perfectly possible that an exception be raised while trying
6343 to determine the TAG's name, even under normal circumstances:
6344 The associated variable may be uninitialized or corrupted, for
6345 instance. We do not let any exception propagate past this point.
6346 instead we return NULL.
6348 We also do not print the error message either (which often is very
6349 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6350 the caller print a more meaningful message if necessary. */
6351 TRY_CATCH (e, RETURN_MASK_ERROR)
6353 struct value *tsd = ada_get_tsd_from_tag (tag);
6356 name = ada_tag_name_from_tsd (tsd);
6362 /* The parent type of TYPE, or NULL if none. */
6365 ada_parent_type (struct type *type)
6369 type = ada_check_typedef (type);
6371 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6374 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6375 if (ada_is_parent_field (type, i))
6377 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6379 /* If the _parent field is a pointer, then dereference it. */
6380 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6381 parent_type = TYPE_TARGET_TYPE (parent_type);
6382 /* If there is a parallel XVS type, get the actual base type. */
6383 parent_type = ada_get_base_type (parent_type);
6385 return ada_check_typedef (parent_type);
6391 /* True iff field number FIELD_NUM of structure type TYPE contains the
6392 parent-type (inherited) fields of a derived type. Assumes TYPE is
6393 a structure type with at least FIELD_NUM+1 fields. */
6396 ada_is_parent_field (struct type *type, int field_num)
6398 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6400 return (name != NULL
6401 && (strncmp (name, "PARENT", 6) == 0
6402 || strncmp (name, "_parent", 7) == 0));
6405 /* True iff field number FIELD_NUM of structure type TYPE is a
6406 transparent wrapper field (which should be silently traversed when doing
6407 field selection and flattened when printing). Assumes TYPE is a
6408 structure type with at least FIELD_NUM+1 fields. Such fields are always
6412 ada_is_wrapper_field (struct type *type, int field_num)
6414 const char *name = TYPE_FIELD_NAME (type, field_num);
6416 return (name != NULL
6417 && (strncmp (name, "PARENT", 6) == 0
6418 || strcmp (name, "REP") == 0
6419 || strncmp (name, "_parent", 7) == 0
6420 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6423 /* True iff field number FIELD_NUM of structure or union type TYPE
6424 is a variant wrapper. Assumes TYPE is a structure type with at least
6425 FIELD_NUM+1 fields. */
6428 ada_is_variant_part (struct type *type, int field_num)
6430 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
6432 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
6433 || (is_dynamic_field (type, field_num)
6434 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6435 == TYPE_CODE_UNION)));
6438 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6439 whose discriminants are contained in the record type OUTER_TYPE,
6440 returns the type of the controlling discriminant for the variant.
6441 May return NULL if the type could not be found. */
6444 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6446 char *name = ada_variant_discrim_name (var_type);
6448 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
6451 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6452 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6453 represents a 'when others' clause; otherwise 0. */
6456 ada_is_others_clause (struct type *type, int field_num)
6458 const char *name = TYPE_FIELD_NAME (type, field_num);
6460 return (name != NULL && name[0] == 'O');
6463 /* Assuming that TYPE0 is the type of the variant part of a record,
6464 returns the name of the discriminant controlling the variant.
6465 The value is valid until the next call to ada_variant_discrim_name. */
6468 ada_variant_discrim_name (struct type *type0)
6470 static char *result = NULL;
6471 static size_t result_len = 0;
6474 const char *discrim_end;
6475 const char *discrim_start;
6477 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6478 type = TYPE_TARGET_TYPE (type0);
6482 name = ada_type_name (type);
6484 if (name == NULL || name[0] == '\000')
6487 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6490 if (strncmp (discrim_end, "___XVN", 6) == 0)
6493 if (discrim_end == name)
6496 for (discrim_start = discrim_end; discrim_start != name + 3;
6499 if (discrim_start == name + 1)
6501 if ((discrim_start > name + 3
6502 && strncmp (discrim_start - 3, "___", 3) == 0)
6503 || discrim_start[-1] == '.')
6507 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6508 strncpy (result, discrim_start, discrim_end - discrim_start);
6509 result[discrim_end - discrim_start] = '\0';
6513 /* Scan STR for a subtype-encoded number, beginning at position K.
6514 Put the position of the character just past the number scanned in
6515 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6516 Return 1 if there was a valid number at the given position, and 0
6517 otherwise. A "subtype-encoded" number consists of the absolute value
6518 in decimal, followed by the letter 'm' to indicate a negative number.
6519 Assumes 0m does not occur. */
6522 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6526 if (!isdigit (str[k]))
6529 /* Do it the hard way so as not to make any assumption about
6530 the relationship of unsigned long (%lu scan format code) and
6533 while (isdigit (str[k]))
6535 RU = RU * 10 + (str[k] - '0');
6542 *R = (-(LONGEST) (RU - 1)) - 1;
6548 /* NOTE on the above: Technically, C does not say what the results of
6549 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6550 number representable as a LONGEST (although either would probably work
6551 in most implementations). When RU>0, the locution in the then branch
6552 above is always equivalent to the negative of RU. */
6559 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6560 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6561 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6564 ada_in_variant (LONGEST val, struct type *type, int field_num)
6566 const char *name = TYPE_FIELD_NAME (type, field_num);
6580 if (!ada_scan_number (name, p + 1, &W, &p))
6590 if (!ada_scan_number (name, p + 1, &L, &p)
6591 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6593 if (val >= L && val <= U)
6605 /* FIXME: Lots of redundancy below. Try to consolidate. */
6607 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6608 ARG_TYPE, extract and return the value of one of its (non-static)
6609 fields. FIELDNO says which field. Differs from value_primitive_field
6610 only in that it can handle packed values of arbitrary type. */
6612 static struct value *
6613 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6614 struct type *arg_type)
6618 arg_type = ada_check_typedef (arg_type);
6619 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6621 /* Handle packed fields. */
6623 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6625 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6626 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6628 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
6629 offset + bit_pos / 8,
6630 bit_pos % 8, bit_size, type);
6633 return value_primitive_field (arg1, offset, fieldno, arg_type);
6636 /* Find field with name NAME in object of type TYPE. If found,
6637 set the following for each argument that is non-null:
6638 - *FIELD_TYPE_P to the field's type;
6639 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6640 an object of that type;
6641 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6642 - *BIT_SIZE_P to its size in bits if the field is packed, and
6644 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6645 fields up to but not including the desired field, or by the total
6646 number of fields if not found. A NULL value of NAME never
6647 matches; the function just counts visible fields in this case.
6649 Returns 1 if found, 0 otherwise. */
6652 find_struct_field (const char *name, struct type *type, int offset,
6653 struct type **field_type_p,
6654 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6659 type = ada_check_typedef (type);
6661 if (field_type_p != NULL)
6662 *field_type_p = NULL;
6663 if (byte_offset_p != NULL)
6665 if (bit_offset_p != NULL)
6667 if (bit_size_p != NULL)
6670 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6672 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6673 int fld_offset = offset + bit_pos / 8;
6674 const char *t_field_name = TYPE_FIELD_NAME (type, i);
6676 if (t_field_name == NULL)
6679 else if (name != NULL && field_name_match (t_field_name, name))
6681 int bit_size = TYPE_FIELD_BITSIZE (type, i);
6683 if (field_type_p != NULL)
6684 *field_type_p = TYPE_FIELD_TYPE (type, i);
6685 if (byte_offset_p != NULL)
6686 *byte_offset_p = fld_offset;
6687 if (bit_offset_p != NULL)
6688 *bit_offset_p = bit_pos % 8;
6689 if (bit_size_p != NULL)
6690 *bit_size_p = bit_size;
6693 else if (ada_is_wrapper_field (type, i))
6695 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6696 field_type_p, byte_offset_p, bit_offset_p,
6697 bit_size_p, index_p))
6700 else if (ada_is_variant_part (type, i))
6702 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6705 struct type *field_type
6706 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6708 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
6710 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6712 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6713 field_type_p, byte_offset_p,
6714 bit_offset_p, bit_size_p, index_p))
6718 else if (index_p != NULL)
6724 /* Number of user-visible fields in record type TYPE. */
6727 num_visible_fields (struct type *type)
6732 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6736 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6737 and search in it assuming it has (class) type TYPE.
6738 If found, return value, else return NULL.
6740 Searches recursively through wrapper fields (e.g., '_parent'). */
6742 static struct value *
6743 ada_search_struct_field (char *name, struct value *arg, int offset,
6748 type = ada_check_typedef (type);
6749 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6751 const char *t_field_name = TYPE_FIELD_NAME (type, i);
6753 if (t_field_name == NULL)
6756 else if (field_name_match (t_field_name, name))
6757 return ada_value_primitive_field (arg, offset, i, type);
6759 else if (ada_is_wrapper_field (type, i))
6761 struct value *v = /* Do not let indent join lines here. */
6762 ada_search_struct_field (name, arg,
6763 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6764 TYPE_FIELD_TYPE (type, i));
6770 else if (ada_is_variant_part (type, i))
6772 /* PNH: Do we ever get here? See find_struct_field. */
6774 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
6776 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6778 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
6780 struct value *v = ada_search_struct_field /* Force line
6783 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6784 TYPE_FIELD_TYPE (field_type, j));
6794 static struct value *ada_index_struct_field_1 (int *, struct value *,
6795 int, struct type *);
6798 /* Return field #INDEX in ARG, where the index is that returned by
6799 * find_struct_field through its INDEX_P argument. Adjust the address
6800 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6801 * If found, return value, else return NULL. */
6803 static struct value *
6804 ada_index_struct_field (int index, struct value *arg, int offset,
6807 return ada_index_struct_field_1 (&index, arg, offset, type);
6811 /* Auxiliary function for ada_index_struct_field. Like
6812 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6815 static struct value *
6816 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6820 type = ada_check_typedef (type);
6822 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6824 if (TYPE_FIELD_NAME (type, i) == NULL)
6826 else if (ada_is_wrapper_field (type, i))
6828 struct value *v = /* Do not let indent join lines here. */
6829 ada_index_struct_field_1 (index_p, arg,
6830 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6831 TYPE_FIELD_TYPE (type, i));
6837 else if (ada_is_variant_part (type, i))
6839 /* PNH: Do we ever get here? See ada_search_struct_field,
6840 find_struct_field. */
6841 error (_("Cannot assign this kind of variant record"));
6843 else if (*index_p == 0)
6844 return ada_value_primitive_field (arg, offset, i, type);
6851 /* Given ARG, a value of type (pointer or reference to a)*
6852 structure/union, extract the component named NAME from the ultimate
6853 target structure/union and return it as a value with its
6856 The routine searches for NAME among all members of the structure itself
6857 and (recursively) among all members of any wrapper members
6860 If NO_ERR, then simply return NULL in case of error, rather than
6864 ada_value_struct_elt (struct value *arg, char *name, int no_err)
6866 struct type *t, *t1;
6870 t1 = t = ada_check_typedef (value_type (arg));
6871 if (TYPE_CODE (t) == TYPE_CODE_REF)
6873 t1 = TYPE_TARGET_TYPE (t);
6876 t1 = ada_check_typedef (t1);
6877 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
6879 arg = coerce_ref (arg);
6884 while (TYPE_CODE (t) == TYPE_CODE_PTR)
6886 t1 = TYPE_TARGET_TYPE (t);
6889 t1 = ada_check_typedef (t1);
6890 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
6892 arg = value_ind (arg);
6899 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
6903 v = ada_search_struct_field (name, arg, 0, t);
6906 int bit_offset, bit_size, byte_offset;
6907 struct type *field_type;
6910 if (TYPE_CODE (t) == TYPE_CODE_PTR)
6911 address = value_address (ada_value_ind (arg));
6913 address = value_address (ada_coerce_ref (arg));
6915 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
6916 if (find_struct_field (name, t1, 0,
6917 &field_type, &byte_offset, &bit_offset,
6922 if (TYPE_CODE (t) == TYPE_CODE_REF)
6923 arg = ada_coerce_ref (arg);
6925 arg = ada_value_ind (arg);
6926 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6927 bit_offset, bit_size,
6931 v = value_at_lazy (field_type, address + byte_offset);
6935 if (v != NULL || no_err)
6938 error (_("There is no member named %s."), name);
6944 error (_("Attempt to extract a component of "
6945 "a value that is not a record."));
6948 /* Given a type TYPE, look up the type of the component of type named NAME.
6949 If DISPP is non-null, add its byte displacement from the beginning of a
6950 structure (pointed to by a value) of type TYPE to *DISPP (does not
6951 work for packed fields).
6953 Matches any field whose name has NAME as a prefix, possibly
6956 TYPE can be either a struct or union. If REFOK, TYPE may also
6957 be a (pointer or reference)+ to a struct or union, and the
6958 ultimate target type will be searched.
6960 Looks recursively into variant clauses and parent types.
6962 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6963 TYPE is not a type of the right kind. */
6965 static struct type *
6966 ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6967 int noerr, int *dispp)
6974 if (refok && type != NULL)
6977 type = ada_check_typedef (type);
6978 if (TYPE_CODE (type) != TYPE_CODE_PTR
6979 && TYPE_CODE (type) != TYPE_CODE_REF)
6981 type = TYPE_TARGET_TYPE (type);
6985 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6986 && TYPE_CODE (type) != TYPE_CODE_UNION))
6992 target_terminal_ours ();
6993 gdb_flush (gdb_stdout);
6995 error (_("Type (null) is not a structure or union type"));
6998 /* XXX: type_sprint */
6999 fprintf_unfiltered (gdb_stderr, _("Type "));
7000 type_print (type, "", gdb_stderr, -1);
7001 error (_(" is not a structure or union type"));
7006 type = to_static_fixed_type (type);
7008 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7010 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7014 if (t_field_name == NULL)
7017 else if (field_name_match (t_field_name, name))
7020 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
7021 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
7024 else if (ada_is_wrapper_field (type, i))
7027 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7032 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7037 else if (ada_is_variant_part (type, i))
7040 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7043 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7045 /* FIXME pnh 2008/01/26: We check for a field that is
7046 NOT wrapped in a struct, since the compiler sometimes
7047 generates these for unchecked variant types. Revisit
7048 if the compiler changes this practice. */
7049 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
7051 if (v_field_name != NULL
7052 && field_name_match (v_field_name, name))
7053 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
7055 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7062 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7073 target_terminal_ours ();
7074 gdb_flush (gdb_stdout);
7077 /* XXX: type_sprint */
7078 fprintf_unfiltered (gdb_stderr, _("Type "));
7079 type_print (type, "", gdb_stderr, -1);
7080 error (_(" has no component named <null>"));
7084 /* XXX: type_sprint */
7085 fprintf_unfiltered (gdb_stderr, _("Type "));
7086 type_print (type, "", gdb_stderr, -1);
7087 error (_(" has no component named %s"), name);
7094 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7095 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7096 represents an unchecked union (that is, the variant part of a
7097 record that is named in an Unchecked_Union pragma). */
7100 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7102 char *discrim_name = ada_variant_discrim_name (var_type);
7104 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
7109 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7110 within a value of type OUTER_TYPE that is stored in GDB at
7111 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7112 numbering from 0) is applicable. Returns -1 if none are. */
7115 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
7116 const gdb_byte *outer_valaddr)
7120 char *discrim_name = ada_variant_discrim_name (var_type);
7121 struct value *outer;
7122 struct value *discrim;
7123 LONGEST discrim_val;
7125 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
7126 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7127 if (discrim == NULL)
7129 discrim_val = value_as_long (discrim);
7132 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7134 if (ada_is_others_clause (var_type, i))
7136 else if (ada_in_variant (discrim_val, var_type, i))
7140 return others_clause;
7145 /* Dynamic-Sized Records */
7147 /* Strategy: The type ostensibly attached to a value with dynamic size
7148 (i.e., a size that is not statically recorded in the debugging
7149 data) does not accurately reflect the size or layout of the value.
7150 Our strategy is to convert these values to values with accurate,
7151 conventional types that are constructed on the fly. */
7153 /* There is a subtle and tricky problem here. In general, we cannot
7154 determine the size of dynamic records without its data. However,
7155 the 'struct value' data structure, which GDB uses to represent
7156 quantities in the inferior process (the target), requires the size
7157 of the type at the time of its allocation in order to reserve space
7158 for GDB's internal copy of the data. That's why the
7159 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7160 rather than struct value*s.
7162 However, GDB's internal history variables ($1, $2, etc.) are
7163 struct value*s containing internal copies of the data that are not, in
7164 general, the same as the data at their corresponding addresses in
7165 the target. Fortunately, the types we give to these values are all
7166 conventional, fixed-size types (as per the strategy described
7167 above), so that we don't usually have to perform the
7168 'to_fixed_xxx_type' conversions to look at their values.
7169 Unfortunately, there is one exception: if one of the internal
7170 history variables is an array whose elements are unconstrained
7171 records, then we will need to create distinct fixed types for each
7172 element selected. */
7174 /* The upshot of all of this is that many routines take a (type, host
7175 address, target address) triple as arguments to represent a value.
7176 The host address, if non-null, is supposed to contain an internal
7177 copy of the relevant data; otherwise, the program is to consult the
7178 target at the target address. */
7180 /* Assuming that VAL0 represents a pointer value, the result of
7181 dereferencing it. Differs from value_ind in its treatment of
7182 dynamic-sized types. */
7185 ada_value_ind (struct value *val0)
7187 struct value *val = value_ind (val0);
7189 if (ada_is_tagged_type (value_type (val), 0))
7190 val = ada_tag_value_at_base_address (val);
7192 return ada_to_fixed_value (val);
7195 /* The value resulting from dereferencing any "reference to"
7196 qualifiers on VAL0. */
7198 static struct value *
7199 ada_coerce_ref (struct value *val0)
7201 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
7203 struct value *val = val0;
7205 val = coerce_ref (val);
7207 if (ada_is_tagged_type (value_type (val), 0))
7208 val = ada_tag_value_at_base_address (val);
7210 return ada_to_fixed_value (val);
7216 /* Return OFF rounded upward if necessary to a multiple of
7217 ALIGNMENT (a power of 2). */
7220 align_value (unsigned int off, unsigned int alignment)
7222 return (off + alignment - 1) & ~(alignment - 1);
7225 /* Return the bit alignment required for field #F of template type TYPE. */
7228 field_alignment (struct type *type, int f)
7230 const char *name = TYPE_FIELD_NAME (type, f);
7234 /* The field name should never be null, unless the debugging information
7235 is somehow malformed. In this case, we assume the field does not
7236 require any alignment. */
7240 len = strlen (name);
7242 if (!isdigit (name[len - 1]))
7245 if (isdigit (name[len - 2]))
7246 align_offset = len - 2;
7248 align_offset = len - 1;
7250 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
7251 return TARGET_CHAR_BIT;
7253 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7256 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7258 static struct symbol *
7259 ada_find_any_type_symbol (const char *name)
7263 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7264 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7267 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7271 /* Find a type named NAME. Ignores ambiguity. This routine will look
7272 solely for types defined by debug info, it will not search the GDB
7275 static struct type *
7276 ada_find_any_type (const char *name)
7278 struct symbol *sym = ada_find_any_type_symbol (name);
7281 return SYMBOL_TYPE (sym);
7286 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7287 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7288 symbol, in which case it is returned. Otherwise, this looks for
7289 symbols whose name is that of NAME_SYM suffixed with "___XR".
7290 Return symbol if found, and NULL otherwise. */
7293 ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
7295 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
7298 if (strstr (name, "___XR") != NULL)
7301 sym = find_old_style_renaming_symbol (name, block);
7306 /* Not right yet. FIXME pnh 7/20/2007. */
7307 sym = ada_find_any_type_symbol (name);
7308 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7314 static struct symbol *
7315 find_old_style_renaming_symbol (const char *name, const struct block *block)
7317 const struct symbol *function_sym = block_linkage_function (block);
7320 if (function_sym != NULL)
7322 /* If the symbol is defined inside a function, NAME is not fully
7323 qualified. This means we need to prepend the function name
7324 as well as adding the ``___XR'' suffix to build the name of
7325 the associated renaming symbol. */
7326 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
7327 /* Function names sometimes contain suffixes used
7328 for instance to qualify nested subprograms. When building
7329 the XR type name, we need to make sure that this suffix is
7330 not included. So do not include any suffix in the function
7331 name length below. */
7332 int function_name_len = ada_name_prefix_len (function_name);
7333 const int rename_len = function_name_len + 2 /* "__" */
7334 + strlen (name) + 6 /* "___XR\0" */ ;
7336 /* Strip the suffix if necessary. */
7337 ada_remove_trailing_digits (function_name, &function_name_len);
7338 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7339 ada_remove_Xbn_suffix (function_name, &function_name_len);
7341 /* Library-level functions are a special case, as GNAT adds
7342 a ``_ada_'' prefix to the function name to avoid namespace
7343 pollution. However, the renaming symbols themselves do not
7344 have this prefix, so we need to skip this prefix if present. */
7345 if (function_name_len > 5 /* "_ada_" */
7346 && strstr (function_name, "_ada_") == function_name)
7349 function_name_len -= 5;
7352 rename = (char *) alloca (rename_len * sizeof (char));
7353 strncpy (rename, function_name, function_name_len);
7354 xsnprintf (rename + function_name_len, rename_len - function_name_len,
7359 const int rename_len = strlen (name) + 6;
7361 rename = (char *) alloca (rename_len * sizeof (char));
7362 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
7365 return ada_find_any_type_symbol (rename);
7368 /* Because of GNAT encoding conventions, several GDB symbols may match a
7369 given type name. If the type denoted by TYPE0 is to be preferred to
7370 that of TYPE1 for purposes of type printing, return non-zero;
7371 otherwise return 0. */
7374 ada_prefer_type (struct type *type0, struct type *type1)
7378 else if (type0 == NULL)
7380 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7382 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7384 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7386 else if (ada_is_constrained_packed_array_type (type0))
7388 else if (ada_is_array_descriptor_type (type0)
7389 && !ada_is_array_descriptor_type (type1))
7393 const char *type0_name = type_name_no_tag (type0);
7394 const char *type1_name = type_name_no_tag (type1);
7396 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7397 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7403 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
7404 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7407 ada_type_name (struct type *type)
7411 else if (TYPE_NAME (type) != NULL)
7412 return TYPE_NAME (type);
7414 return TYPE_TAG_NAME (type);
7417 /* Search the list of "descriptive" types associated to TYPE for a type
7418 whose name is NAME. */
7420 static struct type *
7421 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
7423 struct type *result;
7425 /* If there no descriptive-type info, then there is no parallel type
7427 if (!HAVE_GNAT_AUX_INFO (type))
7430 result = TYPE_DESCRIPTIVE_TYPE (type);
7431 while (result != NULL)
7433 const char *result_name = ada_type_name (result);
7435 if (result_name == NULL)
7437 warning (_("unexpected null name on descriptive type"));
7441 /* If the names match, stop. */
7442 if (strcmp (result_name, name) == 0)
7445 /* Otherwise, look at the next item on the list, if any. */
7446 if (HAVE_GNAT_AUX_INFO (result))
7447 result = TYPE_DESCRIPTIVE_TYPE (result);
7452 /* If we didn't find a match, see whether this is a packed array. With
7453 older compilers, the descriptive type information is either absent or
7454 irrelevant when it comes to packed arrays so the above lookup fails.
7455 Fall back to using a parallel lookup by name in this case. */
7456 if (result == NULL && ada_is_constrained_packed_array_type (type))
7457 return ada_find_any_type (name);
7462 /* Find a parallel type to TYPE with the specified NAME, using the
7463 descriptive type taken from the debugging information, if available,
7464 and otherwise using the (slower) name-based method. */
7466 static struct type *
7467 ada_find_parallel_type_with_name (struct type *type, const char *name)
7469 struct type *result = NULL;
7471 if (HAVE_GNAT_AUX_INFO (type))
7472 result = find_parallel_type_by_descriptive_type (type, name);
7474 result = ada_find_any_type (name);
7479 /* Same as above, but specify the name of the parallel type by appending
7480 SUFFIX to the name of TYPE. */
7483 ada_find_parallel_type (struct type *type, const char *suffix)
7486 const char *typename = ada_type_name (type);
7489 if (typename == NULL)
7492 len = strlen (typename);
7494 name = (char *) alloca (len + strlen (suffix) + 1);
7496 strcpy (name, typename);
7497 strcpy (name + len, suffix);
7499 return ada_find_parallel_type_with_name (type, name);
7502 /* If TYPE is a variable-size record type, return the corresponding template
7503 type describing its fields. Otherwise, return NULL. */
7505 static struct type *
7506 dynamic_template_type (struct type *type)
7508 type = ada_check_typedef (type);
7510 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
7511 || ada_type_name (type) == NULL)
7515 int len = strlen (ada_type_name (type));
7517 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7520 return ada_find_parallel_type (type, "___XVE");
7524 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7525 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7528 is_dynamic_field (struct type *templ_type, int field_num)
7530 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
7533 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7534 && strstr (name, "___XVL") != NULL;
7537 /* The index of the variant field of TYPE, or -1 if TYPE does not
7538 represent a variant record type. */
7541 variant_field_index (struct type *type)
7545 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7548 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7550 if (ada_is_variant_part (type, f))
7556 /* A record type with no fields. */
7558 static struct type *
7559 empty_record (struct type *template)
7561 struct type *type = alloc_type_copy (template);
7563 TYPE_CODE (type) = TYPE_CODE_STRUCT;
7564 TYPE_NFIELDS (type) = 0;
7565 TYPE_FIELDS (type) = NULL;
7566 INIT_CPLUS_SPECIFIC (type);
7567 TYPE_NAME (type) = "<empty>";
7568 TYPE_TAG_NAME (type) = NULL;
7569 TYPE_LENGTH (type) = 0;
7573 /* An ordinary record type (with fixed-length fields) that describes
7574 the value of type TYPE at VALADDR or ADDRESS (see comments at
7575 the beginning of this section) VAL according to GNAT conventions.
7576 DVAL0 should describe the (portion of a) record that contains any
7577 necessary discriminants. It should be NULL if value_type (VAL) is
7578 an outer-level type (i.e., as opposed to a branch of a variant.) A
7579 variant field (unless unchecked) is replaced by a particular branch
7582 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7583 length are not statically known are discarded. As a consequence,
7584 VALADDR, ADDRESS and DVAL0 are ignored.
7586 NOTE: Limitations: For now, we assume that dynamic fields and
7587 variants occupy whole numbers of bytes. However, they need not be
7591 ada_template_to_fixed_record_type_1 (struct type *type,
7592 const gdb_byte *valaddr,
7593 CORE_ADDR address, struct value *dval0,
7594 int keep_dynamic_fields)
7596 struct value *mark = value_mark ();
7599 int nfields, bit_len;
7605 /* Compute the number of fields in this record type that are going
7606 to be processed: unless keep_dynamic_fields, this includes only
7607 fields whose position and length are static will be processed. */
7608 if (keep_dynamic_fields)
7609 nfields = TYPE_NFIELDS (type);
7613 while (nfields < TYPE_NFIELDS (type)
7614 && !ada_is_variant_part (type, nfields)
7615 && !is_dynamic_field (type, nfields))
7619 rtype = alloc_type_copy (type);
7620 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7621 INIT_CPLUS_SPECIFIC (rtype);
7622 TYPE_NFIELDS (rtype) = nfields;
7623 TYPE_FIELDS (rtype) = (struct field *)
7624 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7625 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
7626 TYPE_NAME (rtype) = ada_type_name (type);
7627 TYPE_TAG_NAME (rtype) = NULL;
7628 TYPE_FIXED_INSTANCE (rtype) = 1;
7634 for (f = 0; f < nfields; f += 1)
7636 off = align_value (off, field_alignment (type, f))
7637 + TYPE_FIELD_BITPOS (type, f);
7638 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
7639 TYPE_FIELD_BITSIZE (rtype, f) = 0;
7641 if (ada_is_variant_part (type, f))
7646 else if (is_dynamic_field (type, f))
7648 const gdb_byte *field_valaddr = valaddr;
7649 CORE_ADDR field_address = address;
7650 struct type *field_type =
7651 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
7655 /* rtype's length is computed based on the run-time
7656 value of discriminants. If the discriminants are not
7657 initialized, the type size may be completely bogus and
7658 GDB may fail to allocate a value for it. So check the
7659 size first before creating the value. */
7661 dval = value_from_contents_and_address (rtype, valaddr, address);
7666 /* If the type referenced by this field is an aligner type, we need
7667 to unwrap that aligner type, because its size might not be set.
7668 Keeping the aligner type would cause us to compute the wrong
7669 size for this field, impacting the offset of the all the fields
7670 that follow this one. */
7671 if (ada_is_aligner_type (field_type))
7673 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
7675 field_valaddr = cond_offset_host (field_valaddr, field_offset);
7676 field_address = cond_offset_target (field_address, field_offset);
7677 field_type = ada_aligned_type (field_type);
7680 field_valaddr = cond_offset_host (field_valaddr,
7681 off / TARGET_CHAR_BIT);
7682 field_address = cond_offset_target (field_address,
7683 off / TARGET_CHAR_BIT);
7685 /* Get the fixed type of the field. Note that, in this case,
7686 we do not want to get the real type out of the tag: if
7687 the current field is the parent part of a tagged record,
7688 we will get the tag of the object. Clearly wrong: the real
7689 type of the parent is not the real type of the child. We
7690 would end up in an infinite loop. */
7691 field_type = ada_get_base_type (field_type);
7692 field_type = ada_to_fixed_type (field_type, field_valaddr,
7693 field_address, dval, 0);
7694 /* If the field size is already larger than the maximum
7695 object size, then the record itself will necessarily
7696 be larger than the maximum object size. We need to make
7697 this check now, because the size might be so ridiculously
7698 large (due to an uninitialized variable in the inferior)
7699 that it would cause an overflow when adding it to the
7701 check_size (field_type);
7703 TYPE_FIELD_TYPE (rtype, f) = field_type;
7704 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7705 /* The multiplication can potentially overflow. But because
7706 the field length has been size-checked just above, and
7707 assuming that the maximum size is a reasonable value,
7708 an overflow should not happen in practice. So rather than
7709 adding overflow recovery code to this already complex code,
7710 we just assume that it's not going to happen. */
7712 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
7716 /* Note: If this field's type is a typedef, it is important
7717 to preserve the typedef layer.
7719 Otherwise, we might be transforming a typedef to a fat
7720 pointer (encoding a pointer to an unconstrained array),
7721 into a basic fat pointer (encoding an unconstrained
7722 array). As both types are implemented using the same
7723 structure, the typedef is the only clue which allows us
7724 to distinguish between the two options. Stripping it
7725 would prevent us from printing this field appropriately. */
7726 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
7727 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7728 if (TYPE_FIELD_BITSIZE (type, f) > 0)
7730 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7733 struct type *field_type = TYPE_FIELD_TYPE (type, f);
7735 /* We need to be careful of typedefs when computing
7736 the length of our field. If this is a typedef,
7737 get the length of the target type, not the length
7739 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
7740 field_type = ada_typedef_target_type (field_type);
7743 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
7746 if (off + fld_bit_len > bit_len)
7747 bit_len = off + fld_bit_len;
7749 TYPE_LENGTH (rtype) =
7750 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7753 /* We handle the variant part, if any, at the end because of certain
7754 odd cases in which it is re-ordered so as NOT to be the last field of
7755 the record. This can happen in the presence of representation
7757 if (variant_field >= 0)
7759 struct type *branch_type;
7761 off = TYPE_FIELD_BITPOS (rtype, variant_field);
7764 dval = value_from_contents_and_address (rtype, valaddr, address);
7769 to_fixed_variant_branch_type
7770 (TYPE_FIELD_TYPE (type, variant_field),
7771 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7772 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7773 if (branch_type == NULL)
7775 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
7776 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7777 TYPE_NFIELDS (rtype) -= 1;
7781 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7782 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7784 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
7786 if (off + fld_bit_len > bit_len)
7787 bit_len = off + fld_bit_len;
7788 TYPE_LENGTH (rtype) =
7789 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7793 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7794 should contain the alignment of that record, which should be a strictly
7795 positive value. If null or negative, then something is wrong, most
7796 probably in the debug info. In that case, we don't round up the size
7797 of the resulting type. If this record is not part of another structure,
7798 the current RTYPE length might be good enough for our purposes. */
7799 if (TYPE_LENGTH (type) <= 0)
7801 if (TYPE_NAME (rtype))
7802 warning (_("Invalid type size for `%s' detected: %d."),
7803 TYPE_NAME (rtype), TYPE_LENGTH (type));
7805 warning (_("Invalid type size for <unnamed> detected: %d."),
7806 TYPE_LENGTH (type));
7810 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
7811 TYPE_LENGTH (type));
7814 value_free_to_mark (mark);
7815 if (TYPE_LENGTH (rtype) > varsize_limit)
7816 error (_("record type with dynamic size is larger than varsize-limit"));
7820 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7823 static struct type *
7824 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
7825 CORE_ADDR address, struct value *dval0)
7827 return ada_template_to_fixed_record_type_1 (type, valaddr,
7831 /* An ordinary record type in which ___XVL-convention fields and
7832 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7833 static approximations, containing all possible fields. Uses
7834 no runtime values. Useless for use in values, but that's OK,
7835 since the results are used only for type determinations. Works on both
7836 structs and unions. Representation note: to save space, we memorize
7837 the result of this function in the TYPE_TARGET_TYPE of the
7840 static struct type *
7841 template_to_static_fixed_type (struct type *type0)
7847 if (TYPE_TARGET_TYPE (type0) != NULL)
7848 return TYPE_TARGET_TYPE (type0);
7850 nfields = TYPE_NFIELDS (type0);
7853 for (f = 0; f < nfields; f += 1)
7855 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
7856 struct type *new_type;
7858 if (is_dynamic_field (type0, f))
7859 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
7861 new_type = static_unwrap_type (field_type);
7862 if (type == type0 && new_type != field_type)
7864 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
7865 TYPE_CODE (type) = TYPE_CODE (type0);
7866 INIT_CPLUS_SPECIFIC (type);
7867 TYPE_NFIELDS (type) = nfields;
7868 TYPE_FIELDS (type) = (struct field *)
7869 TYPE_ALLOC (type, nfields * sizeof (struct field));
7870 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7871 sizeof (struct field) * nfields);
7872 TYPE_NAME (type) = ada_type_name (type0);
7873 TYPE_TAG_NAME (type) = NULL;
7874 TYPE_FIXED_INSTANCE (type) = 1;
7875 TYPE_LENGTH (type) = 0;
7877 TYPE_FIELD_TYPE (type, f) = new_type;
7878 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
7883 /* Given an object of type TYPE whose contents are at VALADDR and
7884 whose address in memory is ADDRESS, returns a revision of TYPE,
7885 which should be a non-dynamic-sized record, in which the variant
7886 part, if any, is replaced with the appropriate branch. Looks
7887 for discriminant values in DVAL0, which can be NULL if the record
7888 contains the necessary discriminant values. */
7890 static struct type *
7891 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
7892 CORE_ADDR address, struct value *dval0)
7894 struct value *mark = value_mark ();
7897 struct type *branch_type;
7898 int nfields = TYPE_NFIELDS (type);
7899 int variant_field = variant_field_index (type);
7901 if (variant_field == -1)
7905 dval = value_from_contents_and_address (type, valaddr, address);
7909 rtype = alloc_type_copy (type);
7910 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7911 INIT_CPLUS_SPECIFIC (rtype);
7912 TYPE_NFIELDS (rtype) = nfields;
7913 TYPE_FIELDS (rtype) =
7914 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7915 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
7916 sizeof (struct field) * nfields);
7917 TYPE_NAME (rtype) = ada_type_name (type);
7918 TYPE_TAG_NAME (rtype) = NULL;
7919 TYPE_FIXED_INSTANCE (rtype) = 1;
7920 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7922 branch_type = to_fixed_variant_branch_type
7923 (TYPE_FIELD_TYPE (type, variant_field),
7924 cond_offset_host (valaddr,
7925 TYPE_FIELD_BITPOS (type, variant_field)
7927 cond_offset_target (address,
7928 TYPE_FIELD_BITPOS (type, variant_field)
7929 / TARGET_CHAR_BIT), dval);
7930 if (branch_type == NULL)
7934 for (f = variant_field + 1; f < nfields; f += 1)
7935 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7936 TYPE_NFIELDS (rtype) -= 1;
7940 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7941 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7942 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
7943 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
7945 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
7947 value_free_to_mark (mark);
7951 /* An ordinary record type (with fixed-length fields) that describes
7952 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7953 beginning of this section]. Any necessary discriminants' values
7954 should be in DVAL, a record value; it may be NULL if the object
7955 at ADDR itself contains any necessary discriminant values.
7956 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7957 values from the record are needed. Except in the case that DVAL,
7958 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7959 unchecked) is replaced by a particular branch of the variant.
7961 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7962 is questionable and may be removed. It can arise during the
7963 processing of an unconstrained-array-of-record type where all the
7964 variant branches have exactly the same size. This is because in
7965 such cases, the compiler does not bother to use the XVS convention
7966 when encoding the record. I am currently dubious of this
7967 shortcut and suspect the compiler should be altered. FIXME. */
7969 static struct type *
7970 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
7971 CORE_ADDR address, struct value *dval)
7973 struct type *templ_type;
7975 if (TYPE_FIXED_INSTANCE (type0))
7978 templ_type = dynamic_template_type (type0);
7980 if (templ_type != NULL)
7981 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
7982 else if (variant_field_index (type0) >= 0)
7984 if (dval == NULL && valaddr == NULL && address == 0)
7986 return to_record_with_fixed_variant_part (type0, valaddr, address,
7991 TYPE_FIXED_INSTANCE (type0) = 1;
7997 /* An ordinary record type (with fixed-length fields) that describes
7998 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7999 union type. Any necessary discriminants' values should be in DVAL,
8000 a record value. That is, this routine selects the appropriate
8001 branch of the union at ADDR according to the discriminant value
8002 indicated in the union's type name. Returns VAR_TYPE0 itself if
8003 it represents a variant subject to a pragma Unchecked_Union. */
8005 static struct type *
8006 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8007 CORE_ADDR address, struct value *dval)
8010 struct type *templ_type;
8011 struct type *var_type;
8013 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8014 var_type = TYPE_TARGET_TYPE (var_type0);
8016 var_type = var_type0;
8018 templ_type = ada_find_parallel_type (var_type, "___XVU");
8020 if (templ_type != NULL)
8021 var_type = templ_type;
8023 if (is_unchecked_variant (var_type, value_type (dval)))
8026 ada_which_variant_applies (var_type,
8027 value_type (dval), value_contents (dval));
8030 return empty_record (var_type);
8031 else if (is_dynamic_field (var_type, which))
8032 return to_fixed_record_type
8033 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8034 valaddr, address, dval);
8035 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
8037 to_fixed_record_type
8038 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
8040 return TYPE_FIELD_TYPE (var_type, which);
8043 /* Assuming that TYPE0 is an array type describing the type of a value
8044 at ADDR, and that DVAL describes a record containing any
8045 discriminants used in TYPE0, returns a type for the value that
8046 contains no dynamic components (that is, no components whose sizes
8047 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8048 true, gives an error message if the resulting type's size is over
8051 static struct type *
8052 to_fixed_array_type (struct type *type0, struct value *dval,
8055 struct type *index_type_desc;
8056 struct type *result;
8057 int constrained_packed_array_p;
8059 type0 = ada_check_typedef (type0);
8060 if (TYPE_FIXED_INSTANCE (type0))
8063 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8064 if (constrained_packed_array_p)
8065 type0 = decode_constrained_packed_array_type (type0);
8067 index_type_desc = ada_find_parallel_type (type0, "___XA");
8068 ada_fixup_array_indexes_type (index_type_desc);
8069 if (index_type_desc == NULL)
8071 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8073 /* NOTE: elt_type---the fixed version of elt_type0---should never
8074 depend on the contents of the array in properly constructed
8076 /* Create a fixed version of the array element type.
8077 We're not providing the address of an element here,
8078 and thus the actual object value cannot be inspected to do
8079 the conversion. This should not be a problem, since arrays of
8080 unconstrained objects are not allowed. In particular, all
8081 the elements of an array of a tagged type should all be of
8082 the same type specified in the debugging info. No need to
8083 consult the object tag. */
8084 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8086 /* Make sure we always create a new array type when dealing with
8087 packed array types, since we're going to fix-up the array
8088 type length and element bitsize a little further down. */
8089 if (elt_type0 == elt_type && !constrained_packed_array_p)
8092 result = create_array_type (alloc_type_copy (type0),
8093 elt_type, TYPE_INDEX_TYPE (type0));
8098 struct type *elt_type0;
8101 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
8102 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8104 /* NOTE: result---the fixed version of elt_type0---should never
8105 depend on the contents of the array in properly constructed
8107 /* Create a fixed version of the array element type.
8108 We're not providing the address of an element here,
8109 and thus the actual object value cannot be inspected to do
8110 the conversion. This should not be a problem, since arrays of
8111 unconstrained objects are not allowed. In particular, all
8112 the elements of an array of a tagged type should all be of
8113 the same type specified in the debugging info. No need to
8114 consult the object tag. */
8116 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8119 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
8121 struct type *range_type =
8122 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
8124 result = create_array_type (alloc_type_copy (elt_type0),
8125 result, range_type);
8126 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8128 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
8129 error (_("array type with dynamic size is larger than varsize-limit"));
8132 /* We want to preserve the type name. This can be useful when
8133 trying to get the type name of a value that has already been
8134 printed (for instance, if the user did "print VAR; whatis $". */
8135 TYPE_NAME (result) = TYPE_NAME (type0);
8137 if (constrained_packed_array_p)
8139 /* So far, the resulting type has been created as if the original
8140 type was a regular (non-packed) array type. As a result, the
8141 bitsize of the array elements needs to be set again, and the array
8142 length needs to be recomputed based on that bitsize. */
8143 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8144 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8146 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8147 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8148 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8149 TYPE_LENGTH (result)++;
8152 TYPE_FIXED_INSTANCE (result) = 1;
8157 /* A standard type (containing no dynamically sized components)
8158 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8159 DVAL describes a record containing any discriminants used in TYPE0,
8160 and may be NULL if there are none, or if the object of type TYPE at
8161 ADDRESS or in VALADDR contains these discriminants.
8163 If CHECK_TAG is not null, in the case of tagged types, this function
8164 attempts to locate the object's tag and use it to compute the actual
8165 type. However, when ADDRESS is null, we cannot use it to determine the
8166 location of the tag, and therefore compute the tagged type's actual type.
8167 So we return the tagged type without consulting the tag. */
8169 static struct type *
8170 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8171 CORE_ADDR address, struct value *dval, int check_tag)
8173 type = ada_check_typedef (type);
8174 switch (TYPE_CODE (type))
8178 case TYPE_CODE_STRUCT:
8180 struct type *static_type = to_static_fixed_type (type);
8181 struct type *fixed_record_type =
8182 to_fixed_record_type (type, valaddr, address, NULL);
8184 /* If STATIC_TYPE is a tagged type and we know the object's address,
8185 then we can determine its tag, and compute the object's actual
8186 type from there. Note that we have to use the fixed record
8187 type (the parent part of the record may have dynamic fields
8188 and the way the location of _tag is expressed may depend on
8191 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8194 value_tag_from_contents_and_address
8198 struct type *real_type = type_from_tag (tag);
8200 value_from_contents_and_address (fixed_record_type,
8203 if (real_type != NULL)
8204 return to_fixed_record_type
8206 value_address (ada_tag_value_at_base_address (obj)), NULL);
8209 /* Check to see if there is a parallel ___XVZ variable.
8210 If there is, then it provides the actual size of our type. */
8211 else if (ada_type_name (fixed_record_type) != NULL)
8213 const char *name = ada_type_name (fixed_record_type);
8214 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
8218 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8219 size = get_int_var_value (xvz_name, &xvz_found);
8220 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8222 fixed_record_type = copy_type (fixed_record_type);
8223 TYPE_LENGTH (fixed_record_type) = size;
8225 /* The FIXED_RECORD_TYPE may have be a stub. We have
8226 observed this when the debugging info is STABS, and
8227 apparently it is something that is hard to fix.
8229 In practice, we don't need the actual type definition
8230 at all, because the presence of the XVZ variable allows us
8231 to assume that there must be a XVS type as well, which we
8232 should be able to use later, when we need the actual type
8235 In the meantime, pretend that the "fixed" type we are
8236 returning is NOT a stub, because this can cause trouble
8237 when using this type to create new types targeting it.
8238 Indeed, the associated creation routines often check
8239 whether the target type is a stub and will try to replace
8240 it, thus using a type with the wrong size. This, in turn,
8241 might cause the new type to have the wrong size too.
8242 Consider the case of an array, for instance, where the size
8243 of the array is computed from the number of elements in
8244 our array multiplied by the size of its element. */
8245 TYPE_STUB (fixed_record_type) = 0;
8248 return fixed_record_type;
8250 case TYPE_CODE_ARRAY:
8251 return to_fixed_array_type (type, dval, 1);
8252 case TYPE_CODE_UNION:
8256 return to_fixed_variant_branch_type (type, valaddr, address, dval);
8260 /* The same as ada_to_fixed_type_1, except that it preserves the type
8261 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8263 The typedef layer needs be preserved in order to differentiate between
8264 arrays and array pointers when both types are implemented using the same
8265 fat pointer. In the array pointer case, the pointer is encoded as
8266 a typedef of the pointer type. For instance, considering:
8268 type String_Access is access String;
8269 S1 : String_Access := null;
8271 To the debugger, S1 is defined as a typedef of type String. But
8272 to the user, it is a pointer. So if the user tries to print S1,
8273 we should not dereference the array, but print the array address
8276 If we didn't preserve the typedef layer, we would lose the fact that
8277 the type is to be presented as a pointer (needs de-reference before
8278 being printed). And we would also use the source-level type name. */
8281 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8282 CORE_ADDR address, struct value *dval, int check_tag)
8285 struct type *fixed_type =
8286 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8288 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8289 then preserve the typedef layer.
8291 Implementation note: We can only check the main-type portion of
8292 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8293 from TYPE now returns a type that has the same instance flags
8294 as TYPE. For instance, if TYPE is a "typedef const", and its
8295 target type is a "struct", then the typedef elimination will return
8296 a "const" version of the target type. See check_typedef for more
8297 details about how the typedef layer elimination is done.
8299 brobecker/2010-11-19: It seems to me that the only case where it is
8300 useful to preserve the typedef layer is when dealing with fat pointers.
8301 Perhaps, we could add a check for that and preserve the typedef layer
8302 only in that situation. But this seems unecessary so far, probably
8303 because we call check_typedef/ada_check_typedef pretty much everywhere.
8305 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8306 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
8307 == TYPE_MAIN_TYPE (fixed_type)))
8313 /* A standard (static-sized) type corresponding as well as possible to
8314 TYPE0, but based on no runtime data. */
8316 static struct type *
8317 to_static_fixed_type (struct type *type0)
8324 if (TYPE_FIXED_INSTANCE (type0))
8327 type0 = ada_check_typedef (type0);
8329 switch (TYPE_CODE (type0))
8333 case TYPE_CODE_STRUCT:
8334 type = dynamic_template_type (type0);
8336 return template_to_static_fixed_type (type);
8338 return template_to_static_fixed_type (type0);
8339 case TYPE_CODE_UNION:
8340 type = ada_find_parallel_type (type0, "___XVU");
8342 return template_to_static_fixed_type (type);
8344 return template_to_static_fixed_type (type0);
8348 /* A static approximation of TYPE with all type wrappers removed. */
8350 static struct type *
8351 static_unwrap_type (struct type *type)
8353 if (ada_is_aligner_type (type))
8355 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
8356 if (ada_type_name (type1) == NULL)
8357 TYPE_NAME (type1) = ada_type_name (type);
8359 return static_unwrap_type (type1);
8363 struct type *raw_real_type = ada_get_base_type (type);
8365 if (raw_real_type == type)
8368 return to_static_fixed_type (raw_real_type);
8372 /* In some cases, incomplete and private types require
8373 cross-references that are not resolved as records (for example,
8375 type FooP is access Foo;
8377 type Foo is array ...;
8378 ). In these cases, since there is no mechanism for producing
8379 cross-references to such types, we instead substitute for FooP a
8380 stub enumeration type that is nowhere resolved, and whose tag is
8381 the name of the actual type. Call these types "non-record stubs". */
8383 /* A type equivalent to TYPE that is not a non-record stub, if one
8384 exists, otherwise TYPE. */
8387 ada_check_typedef (struct type *type)
8392 /* If our type is a typedef type of a fat pointer, then we're done.
8393 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8394 what allows us to distinguish between fat pointers that represent
8395 array types, and fat pointers that represent array access types
8396 (in both cases, the compiler implements them as fat pointers). */
8397 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8398 && is_thick_pntr (ada_typedef_target_type (type)))
8401 CHECK_TYPEDEF (type);
8402 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
8403 || !TYPE_STUB (type)
8404 || TYPE_TAG_NAME (type) == NULL)
8408 const char *name = TYPE_TAG_NAME (type);
8409 struct type *type1 = ada_find_any_type (name);
8414 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8415 stubs pointing to arrays, as we don't create symbols for array
8416 types, only for the typedef-to-array types). If that's the case,
8417 strip the typedef layer. */
8418 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
8419 type1 = ada_check_typedef (type1);
8425 /* A value representing the data at VALADDR/ADDRESS as described by
8426 type TYPE0, but with a standard (static-sized) type that correctly
8427 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8428 type, then return VAL0 [this feature is simply to avoid redundant
8429 creation of struct values]. */
8431 static struct value *
8432 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8435 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8437 if (type == type0 && val0 != NULL)
8440 return value_from_contents_and_address (type, 0, address);
8443 /* A value representing VAL, but with a standard (static-sized) type
8444 that correctly describes it. Does not necessarily create a new
8448 ada_to_fixed_value (struct value *val)
8450 val = unwrap_value (val);
8451 val = ada_to_fixed_value_create (value_type (val),
8452 value_address (val),
8460 /* Table mapping attribute numbers to names.
8461 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8463 static const char *attribute_names[] = {
8481 ada_attribute_name (enum exp_opcode n)
8483 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8484 return attribute_names[n - OP_ATR_FIRST + 1];
8486 return attribute_names[0];
8489 /* Evaluate the 'POS attribute applied to ARG. */
8492 pos_atr (struct value *arg)
8494 struct value *val = coerce_ref (arg);
8495 struct type *type = value_type (val);
8497 if (!discrete_type_p (type))
8498 error (_("'POS only defined on discrete types"));
8500 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8503 LONGEST v = value_as_long (val);
8505 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
8507 if (v == TYPE_FIELD_ENUMVAL (type, i))
8510 error (_("enumeration value is invalid: can't find 'POS"));
8513 return value_as_long (val);
8516 static struct value *
8517 value_pos_atr (struct type *type, struct value *arg)
8519 return value_from_longest (type, pos_atr (arg));
8522 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8524 static struct value *
8525 value_val_atr (struct type *type, struct value *arg)
8527 if (!discrete_type_p (type))
8528 error (_("'VAL only defined on discrete types"));
8529 if (!integer_type_p (value_type (arg)))
8530 error (_("'VAL requires integral argument"));
8532 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8534 long pos = value_as_long (arg);
8536 if (pos < 0 || pos >= TYPE_NFIELDS (type))
8537 error (_("argument to 'VAL out of range"));
8538 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
8541 return value_from_longest (type, value_as_long (arg));
8547 /* True if TYPE appears to be an Ada character type.
8548 [At the moment, this is true only for Character and Wide_Character;
8549 It is a heuristic test that could stand improvement]. */
8552 ada_is_character_type (struct type *type)
8556 /* If the type code says it's a character, then assume it really is,
8557 and don't check any further. */
8558 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
8561 /* Otherwise, assume it's a character type iff it is a discrete type
8562 with a known character type name. */
8563 name = ada_type_name (type);
8564 return (name != NULL
8565 && (TYPE_CODE (type) == TYPE_CODE_INT
8566 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8567 && (strcmp (name, "character") == 0
8568 || strcmp (name, "wide_character") == 0
8569 || strcmp (name, "wide_wide_character") == 0
8570 || strcmp (name, "unsigned char") == 0));
8573 /* True if TYPE appears to be an Ada string type. */
8576 ada_is_string_type (struct type *type)
8578 type = ada_check_typedef (type);
8580 && TYPE_CODE (type) != TYPE_CODE_PTR
8581 && (ada_is_simple_array_type (type)
8582 || ada_is_array_descriptor_type (type))
8583 && ada_array_arity (type) == 1)
8585 struct type *elttype = ada_array_element_type (type, 1);
8587 return ada_is_character_type (elttype);
8593 /* The compiler sometimes provides a parallel XVS type for a given
8594 PAD type. Normally, it is safe to follow the PAD type directly,
8595 but older versions of the compiler have a bug that causes the offset
8596 of its "F" field to be wrong. Following that field in that case
8597 would lead to incorrect results, but this can be worked around
8598 by ignoring the PAD type and using the associated XVS type instead.
8600 Set to True if the debugger should trust the contents of PAD types.
8601 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8602 static int trust_pad_over_xvs = 1;
8604 /* True if TYPE is a struct type introduced by the compiler to force the
8605 alignment of a value. Such types have a single field with a
8606 distinctive name. */
8609 ada_is_aligner_type (struct type *type)
8611 type = ada_check_typedef (type);
8613 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
8616 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
8617 && TYPE_NFIELDS (type) == 1
8618 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
8621 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8622 the parallel type. */
8625 ada_get_base_type (struct type *raw_type)
8627 struct type *real_type_namer;
8628 struct type *raw_real_type;
8630 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
8633 if (ada_is_aligner_type (raw_type))
8634 /* The encoding specifies that we should always use the aligner type.
8635 So, even if this aligner type has an associated XVS type, we should
8638 According to the compiler gurus, an XVS type parallel to an aligner
8639 type may exist because of a stabs limitation. In stabs, aligner
8640 types are empty because the field has a variable-sized type, and
8641 thus cannot actually be used as an aligner type. As a result,
8642 we need the associated parallel XVS type to decode the type.
8643 Since the policy in the compiler is to not change the internal
8644 representation based on the debugging info format, we sometimes
8645 end up having a redundant XVS type parallel to the aligner type. */
8648 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
8649 if (real_type_namer == NULL
8650 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
8651 || TYPE_NFIELDS (real_type_namer) != 1)
8654 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
8656 /* This is an older encoding form where the base type needs to be
8657 looked up by name. We prefer the newer enconding because it is
8659 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
8660 if (raw_real_type == NULL)
8663 return raw_real_type;
8666 /* The field in our XVS type is a reference to the base type. */
8667 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
8670 /* The type of value designated by TYPE, with all aligners removed. */
8673 ada_aligned_type (struct type *type)
8675 if (ada_is_aligner_type (type))
8676 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
8678 return ada_get_base_type (type);
8682 /* The address of the aligned value in an object at address VALADDR
8683 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
8686 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
8688 if (ada_is_aligner_type (type))
8689 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
8691 TYPE_FIELD_BITPOS (type,
8692 0) / TARGET_CHAR_BIT);
8699 /* The printed representation of an enumeration literal with encoded
8700 name NAME. The value is good to the next call of ada_enum_name. */
8702 ada_enum_name (const char *name)
8704 static char *result;
8705 static size_t result_len = 0;
8708 /* First, unqualify the enumeration name:
8709 1. Search for the last '.' character. If we find one, then skip
8710 all the preceding characters, the unqualified name starts
8711 right after that dot.
8712 2. Otherwise, we may be debugging on a target where the compiler
8713 translates dots into "__". Search forward for double underscores,
8714 but stop searching when we hit an overloading suffix, which is
8715 of the form "__" followed by digits. */
8717 tmp = strrchr (name, '.');
8722 while ((tmp = strstr (name, "__")) != NULL)
8724 if (isdigit (tmp[2]))
8735 if (name[1] == 'U' || name[1] == 'W')
8737 if (sscanf (name + 2, "%x", &v) != 1)
8743 GROW_VECT (result, result_len, 16);
8744 if (isascii (v) && isprint (v))
8745 xsnprintf (result, result_len, "'%c'", v);
8746 else if (name[1] == 'U')
8747 xsnprintf (result, result_len, "[\"%02x\"]", v);
8749 xsnprintf (result, result_len, "[\"%04x\"]", v);
8755 tmp = strstr (name, "__");
8757 tmp = strstr (name, "$");
8760 GROW_VECT (result, result_len, tmp - name + 1);
8761 strncpy (result, name, tmp - name);
8762 result[tmp - name] = '\0';
8770 /* Evaluate the subexpression of EXP starting at *POS as for
8771 evaluate_type, updating *POS to point just past the evaluated
8774 static struct value *
8775 evaluate_subexp_type (struct expression *exp, int *pos)
8777 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
8780 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8783 static struct value *
8784 unwrap_value (struct value *val)
8786 struct type *type = ada_check_typedef (value_type (val));
8788 if (ada_is_aligner_type (type))
8790 struct value *v = ada_value_struct_elt (val, "F", 0);
8791 struct type *val_type = ada_check_typedef (value_type (v));
8793 if (ada_type_name (val_type) == NULL)
8794 TYPE_NAME (val_type) = ada_type_name (type);
8796 return unwrap_value (v);
8800 struct type *raw_real_type =
8801 ada_check_typedef (ada_get_base_type (type));
8803 /* If there is no parallel XVS or XVE type, then the value is
8804 already unwrapped. Return it without further modification. */
8805 if ((type == raw_real_type)
8806 && ada_find_parallel_type (type, "___XVE") == NULL)
8810 coerce_unspec_val_to_type
8811 (val, ada_to_fixed_type (raw_real_type, 0,
8812 value_address (val),
8817 static struct value *
8818 cast_to_fixed (struct type *type, struct value *arg)
8822 if (type == value_type (arg))
8824 else if (ada_is_fixed_point_type (value_type (arg)))
8825 val = ada_float_to_fixed (type,
8826 ada_fixed_to_float (value_type (arg),
8827 value_as_long (arg)));
8830 DOUBLEST argd = value_as_double (arg);
8832 val = ada_float_to_fixed (type, argd);
8835 return value_from_longest (type, val);
8838 static struct value *
8839 cast_from_fixed (struct type *type, struct value *arg)
8841 DOUBLEST val = ada_fixed_to_float (value_type (arg),
8842 value_as_long (arg));
8844 return value_from_double (type, val);
8847 /* Given two array types T1 and T2, return nonzero iff both arrays
8848 contain the same number of elements. */
8851 ada_same_array_size_p (struct type *t1, struct type *t2)
8853 LONGEST lo1, hi1, lo2, hi2;
8855 /* Get the array bounds in order to verify that the size of
8856 the two arrays match. */
8857 if (!get_array_bounds (t1, &lo1, &hi1)
8858 || !get_array_bounds (t2, &lo2, &hi2))
8859 error (_("unable to determine array bounds"));
8861 /* To make things easier for size comparison, normalize a bit
8862 the case of empty arrays by making sure that the difference
8863 between upper bound and lower bound is always -1. */
8869 return (hi1 - lo1 == hi2 - lo2);
8872 /* Assuming that VAL is an array of integrals, and TYPE represents
8873 an array with the same number of elements, but with wider integral
8874 elements, return an array "casted" to TYPE. In practice, this
8875 means that the returned array is built by casting each element
8876 of the original array into TYPE's (wider) element type. */
8878 static struct value *
8879 ada_promote_array_of_integrals (struct type *type, struct value *val)
8881 struct type *elt_type = TYPE_TARGET_TYPE (type);
8886 /* Verify that both val and type are arrays of scalars, and
8887 that the size of val's elements is smaller than the size
8888 of type's element. */
8889 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
8890 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
8891 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
8892 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
8893 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
8894 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
8896 if (!get_array_bounds (type, &lo, &hi))
8897 error (_("unable to determine array bounds"));
8899 res = allocate_value (type);
8901 /* Promote each array element. */
8902 for (i = 0; i < hi - lo + 1; i++)
8904 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
8906 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
8907 value_contents_all (elt), TYPE_LENGTH (elt_type));
8913 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8914 return the converted value. */
8916 static struct value *
8917 coerce_for_assign (struct type *type, struct value *val)
8919 struct type *type2 = value_type (val);
8924 type2 = ada_check_typedef (type2);
8925 type = ada_check_typedef (type);
8927 if (TYPE_CODE (type2) == TYPE_CODE_PTR
8928 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
8930 val = ada_value_ind (val);
8931 type2 = value_type (val);
8934 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
8935 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
8937 if (!ada_same_array_size_p (type, type2))
8938 error (_("cannot assign arrays of different length"));
8940 if (is_integral_type (TYPE_TARGET_TYPE (type))
8941 && is_integral_type (TYPE_TARGET_TYPE (type2))
8942 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8943 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8945 /* Allow implicit promotion of the array elements to
8947 return ada_promote_array_of_integrals (type, val);
8950 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8951 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
8952 error (_("Incompatible types in assignment"));
8953 deprecated_set_value_type (val, type);
8958 static struct value *
8959 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8962 struct type *type1, *type2;
8965 arg1 = coerce_ref (arg1);
8966 arg2 = coerce_ref (arg2);
8967 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
8968 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
8970 if (TYPE_CODE (type1) != TYPE_CODE_INT
8971 || TYPE_CODE (type2) != TYPE_CODE_INT)
8972 return value_binop (arg1, arg2, op);
8981 return value_binop (arg1, arg2, op);
8984 v2 = value_as_long (arg2);
8986 error (_("second operand of %s must not be zero."), op_string (op));
8988 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
8989 return value_binop (arg1, arg2, op);
8991 v1 = value_as_long (arg1);
8996 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8997 v += v > 0 ? -1 : 1;
9005 /* Should not reach this point. */
9009 val = allocate_value (type1);
9010 store_unsigned_integer (value_contents_raw (val),
9011 TYPE_LENGTH (value_type (val)),
9012 gdbarch_byte_order (get_type_arch (type1)), v);
9017 ada_value_equal (struct value *arg1, struct value *arg2)
9019 if (ada_is_direct_array_type (value_type (arg1))
9020 || ada_is_direct_array_type (value_type (arg2)))
9022 /* Automatically dereference any array reference before
9023 we attempt to perform the comparison. */
9024 arg1 = ada_coerce_ref (arg1);
9025 arg2 = ada_coerce_ref (arg2);
9027 arg1 = ada_coerce_to_simple_array (arg1);
9028 arg2 = ada_coerce_to_simple_array (arg2);
9029 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9030 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
9031 error (_("Attempt to compare array with non-array"));
9032 /* FIXME: The following works only for types whose
9033 representations use all bits (no padding or undefined bits)
9034 and do not have user-defined equality. */
9036 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
9037 && memcmp (value_contents (arg1), value_contents (arg2),
9038 TYPE_LENGTH (value_type (arg1))) == 0;
9040 return value_equal (arg1, arg2);
9043 /* Total number of component associations in the aggregate starting at
9044 index PC in EXP. Assumes that index PC is the start of an
9048 num_component_specs (struct expression *exp, int pc)
9052 m = exp->elts[pc + 1].longconst;
9055 for (i = 0; i < m; i += 1)
9057 switch (exp->elts[pc].opcode)
9063 n += exp->elts[pc + 1].longconst;
9066 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9071 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9072 component of LHS (a simple array or a record), updating *POS past
9073 the expression, assuming that LHS is contained in CONTAINER. Does
9074 not modify the inferior's memory, nor does it modify LHS (unless
9075 LHS == CONTAINER). */
9078 assign_component (struct value *container, struct value *lhs, LONGEST index,
9079 struct expression *exp, int *pos)
9081 struct value *mark = value_mark ();
9084 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9086 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9087 struct value *index_val = value_from_longest (index_type, index);
9089 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9093 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9094 elt = ada_to_fixed_value (elt);
9097 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9098 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9100 value_assign_to_component (container, elt,
9101 ada_evaluate_subexp (NULL, exp, pos,
9104 value_free_to_mark (mark);
9107 /* Assuming that LHS represents an lvalue having a record or array
9108 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9109 of that aggregate's value to LHS, advancing *POS past the
9110 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9111 lvalue containing LHS (possibly LHS itself). Does not modify
9112 the inferior's memory, nor does it modify the contents of
9113 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9115 static struct value *
9116 assign_aggregate (struct value *container,
9117 struct value *lhs, struct expression *exp,
9118 int *pos, enum noside noside)
9120 struct type *lhs_type;
9121 int n = exp->elts[*pos+1].longconst;
9122 LONGEST low_index, high_index;
9125 int max_indices, num_indices;
9129 if (noside != EVAL_NORMAL)
9131 for (i = 0; i < n; i += 1)
9132 ada_evaluate_subexp (NULL, exp, pos, noside);
9136 container = ada_coerce_ref (container);
9137 if (ada_is_direct_array_type (value_type (container)))
9138 container = ada_coerce_to_simple_array (container);
9139 lhs = ada_coerce_ref (lhs);
9140 if (!deprecated_value_modifiable (lhs))
9141 error (_("Left operand of assignment is not a modifiable lvalue."));
9143 lhs_type = value_type (lhs);
9144 if (ada_is_direct_array_type (lhs_type))
9146 lhs = ada_coerce_to_simple_array (lhs);
9147 lhs_type = value_type (lhs);
9148 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9149 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
9151 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9154 high_index = num_visible_fields (lhs_type) - 1;
9157 error (_("Left-hand side must be array or record."));
9159 num_specs = num_component_specs (exp, *pos - 3);
9160 max_indices = 4 * num_specs + 4;
9161 indices = alloca (max_indices * sizeof (indices[0]));
9162 indices[0] = indices[1] = low_index - 1;
9163 indices[2] = indices[3] = high_index + 1;
9166 for (i = 0; i < n; i += 1)
9168 switch (exp->elts[*pos].opcode)
9171 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9172 &num_indices, max_indices,
9173 low_index, high_index);
9176 aggregate_assign_positional (container, lhs, exp, pos, indices,
9177 &num_indices, max_indices,
9178 low_index, high_index);
9182 error (_("Misplaced 'others' clause"));
9183 aggregate_assign_others (container, lhs, exp, pos, indices,
9184 num_indices, low_index, high_index);
9187 error (_("Internal error: bad aggregate clause"));
9194 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9195 construct at *POS, updating *POS past the construct, given that
9196 the positions are relative to lower bound LOW, where HIGH is the
9197 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9198 updating *NUM_INDICES as needed. CONTAINER is as for
9199 assign_aggregate. */
9201 aggregate_assign_positional (struct value *container,
9202 struct value *lhs, struct expression *exp,
9203 int *pos, LONGEST *indices, int *num_indices,
9204 int max_indices, LONGEST low, LONGEST high)
9206 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9208 if (ind - 1 == high)
9209 warning (_("Extra components in aggregate ignored."));
9212 add_component_interval (ind, ind, indices, num_indices, max_indices);
9214 assign_component (container, lhs, ind, exp, pos);
9217 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9220 /* Assign into the components of LHS indexed by the OP_CHOICES
9221 construct at *POS, updating *POS past the construct, given that
9222 the allowable indices are LOW..HIGH. Record the indices assigned
9223 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9224 needed. CONTAINER is as for assign_aggregate. */
9226 aggregate_assign_from_choices (struct value *container,
9227 struct value *lhs, struct expression *exp,
9228 int *pos, LONGEST *indices, int *num_indices,
9229 int max_indices, LONGEST low, LONGEST high)
9232 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9233 int choice_pos, expr_pc;
9234 int is_array = ada_is_direct_array_type (value_type (lhs));
9236 choice_pos = *pos += 3;
9238 for (j = 0; j < n_choices; j += 1)
9239 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9241 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9243 for (j = 0; j < n_choices; j += 1)
9245 LONGEST lower, upper;
9246 enum exp_opcode op = exp->elts[choice_pos].opcode;
9248 if (op == OP_DISCRETE_RANGE)
9251 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9253 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9258 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9270 name = &exp->elts[choice_pos + 2].string;
9273 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9276 error (_("Invalid record component association."));
9278 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9280 if (! find_struct_field (name, value_type (lhs), 0,
9281 NULL, NULL, NULL, NULL, &ind))
9282 error (_("Unknown component name: %s."), name);
9283 lower = upper = ind;
9286 if (lower <= upper && (lower < low || upper > high))
9287 error (_("Index in component association out of bounds."));
9289 add_component_interval (lower, upper, indices, num_indices,
9291 while (lower <= upper)
9296 assign_component (container, lhs, lower, exp, &pos1);
9302 /* Assign the value of the expression in the OP_OTHERS construct in
9303 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9304 have not been previously assigned. The index intervals already assigned
9305 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9306 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9308 aggregate_assign_others (struct value *container,
9309 struct value *lhs, struct expression *exp,
9310 int *pos, LONGEST *indices, int num_indices,
9311 LONGEST low, LONGEST high)
9314 int expr_pc = *pos + 1;
9316 for (i = 0; i < num_indices - 2; i += 2)
9320 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9325 assign_component (container, lhs, ind, exp, &localpos);
9328 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9331 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9332 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9333 modifying *SIZE as needed. It is an error if *SIZE exceeds
9334 MAX_SIZE. The resulting intervals do not overlap. */
9336 add_component_interval (LONGEST low, LONGEST high,
9337 LONGEST* indices, int *size, int max_size)
9341 for (i = 0; i < *size; i += 2) {
9342 if (high >= indices[i] && low <= indices[i + 1])
9346 for (kh = i + 2; kh < *size; kh += 2)
9347 if (high < indices[kh])
9349 if (low < indices[i])
9351 indices[i + 1] = indices[kh - 1];
9352 if (high > indices[i + 1])
9353 indices[i + 1] = high;
9354 memcpy (indices + i + 2, indices + kh, *size - kh);
9355 *size -= kh - i - 2;
9358 else if (high < indices[i])
9362 if (*size == max_size)
9363 error (_("Internal error: miscounted aggregate components."));
9365 for (j = *size-1; j >= i+2; j -= 1)
9366 indices[j] = indices[j - 2];
9368 indices[i + 1] = high;
9371 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9374 static struct value *
9375 ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
9377 if (type == ada_check_typedef (value_type (arg2)))
9380 if (ada_is_fixed_point_type (type))
9381 return (cast_to_fixed (type, arg2));
9383 if (ada_is_fixed_point_type (value_type (arg2)))
9384 return cast_from_fixed (type, arg2);
9386 return value_cast (type, arg2);
9389 /* Evaluating Ada expressions, and printing their result.
9390 ------------------------------------------------------
9395 We usually evaluate an Ada expression in order to print its value.
9396 We also evaluate an expression in order to print its type, which
9397 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9398 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9399 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9400 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9403 Evaluating expressions is a little more complicated for Ada entities
9404 than it is for entities in languages such as C. The main reason for
9405 this is that Ada provides types whose definition might be dynamic.
9406 One example of such types is variant records. Or another example
9407 would be an array whose bounds can only be known at run time.
9409 The following description is a general guide as to what should be
9410 done (and what should NOT be done) in order to evaluate an expression
9411 involving such types, and when. This does not cover how the semantic
9412 information is encoded by GNAT as this is covered separatly. For the
9413 document used as the reference for the GNAT encoding, see exp_dbug.ads
9414 in the GNAT sources.
9416 Ideally, we should embed each part of this description next to its
9417 associated code. Unfortunately, the amount of code is so vast right
9418 now that it's hard to see whether the code handling a particular
9419 situation might be duplicated or not. One day, when the code is
9420 cleaned up, this guide might become redundant with the comments
9421 inserted in the code, and we might want to remove it.
9423 2. ``Fixing'' an Entity, the Simple Case:
9424 -----------------------------------------
9426 When evaluating Ada expressions, the tricky issue is that they may
9427 reference entities whose type contents and size are not statically
9428 known. Consider for instance a variant record:
9430 type Rec (Empty : Boolean := True) is record
9433 when False => Value : Integer;
9436 Yes : Rec := (Empty => False, Value => 1);
9437 No : Rec := (empty => True);
9439 The size and contents of that record depends on the value of the
9440 descriminant (Rec.Empty). At this point, neither the debugging
9441 information nor the associated type structure in GDB are able to
9442 express such dynamic types. So what the debugger does is to create
9443 "fixed" versions of the type that applies to the specific object.
9444 We also informally refer to this opperation as "fixing" an object,
9445 which means creating its associated fixed type.
9447 Example: when printing the value of variable "Yes" above, its fixed
9448 type would look like this:
9455 On the other hand, if we printed the value of "No", its fixed type
9462 Things become a little more complicated when trying to fix an entity
9463 with a dynamic type that directly contains another dynamic type,
9464 such as an array of variant records, for instance. There are
9465 two possible cases: Arrays, and records.
9467 3. ``Fixing'' Arrays:
9468 ---------------------
9470 The type structure in GDB describes an array in terms of its bounds,
9471 and the type of its elements. By design, all elements in the array
9472 have the same type and we cannot represent an array of variant elements
9473 using the current type structure in GDB. When fixing an array,
9474 we cannot fix the array element, as we would potentially need one
9475 fixed type per element of the array. As a result, the best we can do
9476 when fixing an array is to produce an array whose bounds and size
9477 are correct (allowing us to read it from memory), but without having
9478 touched its element type. Fixing each element will be done later,
9479 when (if) necessary.
9481 Arrays are a little simpler to handle than records, because the same
9482 amount of memory is allocated for each element of the array, even if
9483 the amount of space actually used by each element differs from element
9484 to element. Consider for instance the following array of type Rec:
9486 type Rec_Array is array (1 .. 2) of Rec;
9488 The actual amount of memory occupied by each element might be different
9489 from element to element, depending on the value of their discriminant.
9490 But the amount of space reserved for each element in the array remains
9491 fixed regardless. So we simply need to compute that size using
9492 the debugging information available, from which we can then determine
9493 the array size (we multiply the number of elements of the array by
9494 the size of each element).
9496 The simplest case is when we have an array of a constrained element
9497 type. For instance, consider the following type declarations:
9499 type Bounded_String (Max_Size : Integer) is
9501 Buffer : String (1 .. Max_Size);
9503 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9505 In this case, the compiler describes the array as an array of
9506 variable-size elements (identified by its XVS suffix) for which
9507 the size can be read in the parallel XVZ variable.
9509 In the case of an array of an unconstrained element type, the compiler
9510 wraps the array element inside a private PAD type. This type should not
9511 be shown to the user, and must be "unwrap"'ed before printing. Note
9512 that we also use the adjective "aligner" in our code to designate
9513 these wrapper types.
9515 In some cases, the size allocated for each element is statically
9516 known. In that case, the PAD type already has the correct size,
9517 and the array element should remain unfixed.
9519 But there are cases when this size is not statically known.
9520 For instance, assuming that "Five" is an integer variable:
9522 type Dynamic is array (1 .. Five) of Integer;
9523 type Wrapper (Has_Length : Boolean := False) is record
9526 when True => Length : Integer;
9530 type Wrapper_Array is array (1 .. 2) of Wrapper;
9532 Hello : Wrapper_Array := (others => (Has_Length => True,
9533 Data => (others => 17),
9537 The debugging info would describe variable Hello as being an
9538 array of a PAD type. The size of that PAD type is not statically
9539 known, but can be determined using a parallel XVZ variable.
9540 In that case, a copy of the PAD type with the correct size should
9541 be used for the fixed array.
9543 3. ``Fixing'' record type objects:
9544 ----------------------------------
9546 Things are slightly different from arrays in the case of dynamic
9547 record types. In this case, in order to compute the associated
9548 fixed type, we need to determine the size and offset of each of
9549 its components. This, in turn, requires us to compute the fixed
9550 type of each of these components.
9552 Consider for instance the example:
9554 type Bounded_String (Max_Size : Natural) is record
9555 Str : String (1 .. Max_Size);
9558 My_String : Bounded_String (Max_Size => 10);
9560 In that case, the position of field "Length" depends on the size
9561 of field Str, which itself depends on the value of the Max_Size
9562 discriminant. In order to fix the type of variable My_String,
9563 we need to fix the type of field Str. Therefore, fixing a variant
9564 record requires us to fix each of its components.
9566 However, if a component does not have a dynamic size, the component
9567 should not be fixed. In particular, fields that use a PAD type
9568 should not fixed. Here is an example where this might happen
9569 (assuming type Rec above):
9571 type Container (Big : Boolean) is record
9575 when True => Another : Integer;
9579 My_Container : Container := (Big => False,
9580 First => (Empty => True),
9583 In that example, the compiler creates a PAD type for component First,
9584 whose size is constant, and then positions the component After just
9585 right after it. The offset of component After is therefore constant
9588 The debugger computes the position of each field based on an algorithm
9589 that uses, among other things, the actual position and size of the field
9590 preceding it. Let's now imagine that the user is trying to print
9591 the value of My_Container. If the type fixing was recursive, we would
9592 end up computing the offset of field After based on the size of the
9593 fixed version of field First. And since in our example First has
9594 only one actual field, the size of the fixed type is actually smaller
9595 than the amount of space allocated to that field, and thus we would
9596 compute the wrong offset of field After.
9598 To make things more complicated, we need to watch out for dynamic
9599 components of variant records (identified by the ___XVL suffix in
9600 the component name). Even if the target type is a PAD type, the size
9601 of that type might not be statically known. So the PAD type needs
9602 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9603 we might end up with the wrong size for our component. This can be
9604 observed with the following type declarations:
9606 type Octal is new Integer range 0 .. 7;
9607 type Octal_Array is array (Positive range <>) of Octal;
9608 pragma Pack (Octal_Array);
9610 type Octal_Buffer (Size : Positive) is record
9611 Buffer : Octal_Array (1 .. Size);
9615 In that case, Buffer is a PAD type whose size is unset and needs
9616 to be computed by fixing the unwrapped type.
9618 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9619 ----------------------------------------------------------
9621 Lastly, when should the sub-elements of an entity that remained unfixed
9622 thus far, be actually fixed?
9624 The answer is: Only when referencing that element. For instance
9625 when selecting one component of a record, this specific component
9626 should be fixed at that point in time. Or when printing the value
9627 of a record, each component should be fixed before its value gets
9628 printed. Similarly for arrays, the element of the array should be
9629 fixed when printing each element of the array, or when extracting
9630 one element out of that array. On the other hand, fixing should
9631 not be performed on the elements when taking a slice of an array!
9633 Note that one of the side-effects of miscomputing the offset and
9634 size of each field is that we end up also miscomputing the size
9635 of the containing type. This can have adverse results when computing
9636 the value of an entity. GDB fetches the value of an entity based
9637 on the size of its type, and thus a wrong size causes GDB to fetch
9638 the wrong amount of memory. In the case where the computed size is
9639 too small, GDB fetches too little data to print the value of our
9640 entiry. Results in this case as unpredicatble, as we usually read
9641 past the buffer containing the data =:-o. */
9643 /* Implement the evaluate_exp routine in the exp_descriptor structure
9644 for the Ada language. */
9646 static struct value *
9647 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
9648 int *pos, enum noside noside)
9653 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
9656 struct value **argvec;
9660 op = exp->elts[pc].opcode;
9666 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
9668 if (noside == EVAL_NORMAL)
9669 arg1 = unwrap_value (arg1);
9671 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
9672 then we need to perform the conversion manually, because
9673 evaluate_subexp_standard doesn't do it. This conversion is
9674 necessary in Ada because the different kinds of float/fixed
9675 types in Ada have different representations.
9677 Similarly, we need to perform the conversion from OP_LONG
9679 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
9680 arg1 = ada_value_cast (expect_type, arg1, noside);
9686 struct value *result;
9689 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
9690 /* The result type will have code OP_STRING, bashed there from
9691 OP_ARRAY. Bash it back. */
9692 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
9693 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
9699 type = exp->elts[pc + 1].type;
9700 arg1 = evaluate_subexp (type, exp, pos, noside);
9701 if (noside == EVAL_SKIP)
9703 arg1 = ada_value_cast (type, arg1, noside);
9708 type = exp->elts[pc + 1].type;
9709 return ada_evaluate_subexp (type, exp, pos, noside);
9712 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9713 if (exp->elts[*pos].opcode == OP_AGGREGATE)
9715 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
9716 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
9718 return ada_value_assign (arg1, arg1);
9720 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9721 except if the lhs of our assignment is a convenience variable.
9722 In the case of assigning to a convenience variable, the lhs
9723 should be exactly the result of the evaluation of the rhs. */
9724 type = value_type (arg1);
9725 if (VALUE_LVAL (arg1) == lval_internalvar)
9727 arg2 = evaluate_subexp (type, exp, pos, noside);
9728 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
9730 if (ada_is_fixed_point_type (value_type (arg1)))
9731 arg2 = cast_to_fixed (value_type (arg1), arg2);
9732 else if (ada_is_fixed_point_type (value_type (arg2)))
9734 (_("Fixed-point values must be assigned to fixed-point variables"));
9736 arg2 = coerce_for_assign (value_type (arg1), arg2);
9737 return ada_value_assign (arg1, arg2);
9740 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9741 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9742 if (noside == EVAL_SKIP)
9744 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9745 return (value_from_longest
9747 value_as_long (arg1) + value_as_long (arg2)));
9748 if ((ada_is_fixed_point_type (value_type (arg1))
9749 || ada_is_fixed_point_type (value_type (arg2)))
9750 && value_type (arg1) != value_type (arg2))
9751 error (_("Operands of fixed-point addition must have the same type"));
9752 /* Do the addition, and cast the result to the type of the first
9753 argument. We cannot cast the result to a reference type, so if
9754 ARG1 is a reference type, find its underlying type. */
9755 type = value_type (arg1);
9756 while (TYPE_CODE (type) == TYPE_CODE_REF)
9757 type = TYPE_TARGET_TYPE (type);
9758 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9759 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
9762 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
9763 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
9764 if (noside == EVAL_SKIP)
9766 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
9767 return (value_from_longest
9769 value_as_long (arg1) - value_as_long (arg2)));
9770 if ((ada_is_fixed_point_type (value_type (arg1))
9771 || ada_is_fixed_point_type (value_type (arg2)))
9772 && value_type (arg1) != value_type (arg2))
9773 error (_("Operands of fixed-point subtraction "
9774 "must have the same type"));
9775 /* Do the substraction, and cast the result to the type of the first
9776 argument. We cannot cast the result to a reference type, so if
9777 ARG1 is a reference type, find its underlying type. */
9778 type = value_type (arg1);
9779 while (TYPE_CODE (type) == TYPE_CODE_REF)
9780 type = TYPE_TARGET_TYPE (type);
9781 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9782 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
9788 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9789 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9790 if (noside == EVAL_SKIP)
9792 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9794 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9795 return value_zero (value_type (arg1), not_lval);
9799 type = builtin_type (exp->gdbarch)->builtin_double;
9800 if (ada_is_fixed_point_type (value_type (arg1)))
9801 arg1 = cast_from_fixed (type, arg1);
9802 if (ada_is_fixed_point_type (value_type (arg2)))
9803 arg2 = cast_from_fixed (type, arg2);
9804 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9805 return ada_value_binop (arg1, arg2, op);
9809 case BINOP_NOTEQUAL:
9810 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9811 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
9812 if (noside == EVAL_SKIP)
9814 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9818 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9819 tem = ada_value_equal (arg1, arg2);
9821 if (op == BINOP_NOTEQUAL)
9823 type = language_bool_type (exp->language_defn, exp->gdbarch);
9824 return value_from_longest (type, (LONGEST) tem);
9827 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9828 if (noside == EVAL_SKIP)
9830 else if (ada_is_fixed_point_type (value_type (arg1)))
9831 return value_cast (value_type (arg1), value_neg (arg1));
9834 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9835 return value_neg (arg1);
9838 case BINOP_LOGICAL_AND:
9839 case BINOP_LOGICAL_OR:
9840 case UNOP_LOGICAL_NOT:
9845 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
9846 type = language_bool_type (exp->language_defn, exp->gdbarch);
9847 return value_cast (type, val);
9850 case BINOP_BITWISE_AND:
9851 case BINOP_BITWISE_IOR:
9852 case BINOP_BITWISE_XOR:
9856 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9858 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
9860 return value_cast (value_type (arg1), val);
9866 if (noside == EVAL_SKIP)
9871 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
9872 /* Only encountered when an unresolved symbol occurs in a
9873 context other than a function call, in which case, it is
9875 error (_("Unexpected unresolved symbol, %s, during evaluation"),
9876 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
9877 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9879 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
9880 /* Check to see if this is a tagged type. We also need to handle
9881 the case where the type is a reference to a tagged type, but
9882 we have to be careful to exclude pointers to tagged types.
9883 The latter should be shown as usual (as a pointer), whereas
9884 a reference should mostly be transparent to the user. */
9885 if (ada_is_tagged_type (type, 0)
9886 || (TYPE_CODE(type) == TYPE_CODE_REF
9887 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
9889 /* Tagged types are a little special in the fact that the real
9890 type is dynamic and can only be determined by inspecting the
9891 object's tag. This means that we need to get the object's
9892 value first (EVAL_NORMAL) and then extract the actual object
9895 Note that we cannot skip the final step where we extract
9896 the object type from its tag, because the EVAL_NORMAL phase
9897 results in dynamic components being resolved into fixed ones.
9898 This can cause problems when trying to print the type
9899 description of tagged types whose parent has a dynamic size:
9900 We use the type name of the "_parent" component in order
9901 to print the name of the ancestor type in the type description.
9902 If that component had a dynamic size, the resolution into
9903 a fixed type would result in the loss of that type name,
9904 thus preventing us from printing the name of the ancestor
9905 type in the type description. */
9906 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
9908 if (TYPE_CODE (type) != TYPE_CODE_REF)
9910 struct type *actual_type;
9912 actual_type = type_from_tag (ada_value_tag (arg1));
9913 if (actual_type == NULL)
9914 /* If, for some reason, we were unable to determine
9915 the actual type from the tag, then use the static
9916 approximation that we just computed as a fallback.
9917 This can happen if the debugging information is
9918 incomplete, for instance. */
9920 return value_zero (actual_type, not_lval);
9924 /* In the case of a ref, ada_coerce_ref takes care
9925 of determining the actual type. But the evaluation
9926 should return a ref as it should be valid to ask
9927 for its address; so rebuild a ref after coerce. */
9928 arg1 = ada_coerce_ref (arg1);
9929 return value_ref (arg1);
9935 (to_static_fixed_type
9936 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
9941 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
9942 return ada_to_fixed_value (arg1);
9948 /* Allocate arg vector, including space for the function to be
9949 called in argvec[0] and a terminating NULL. */
9950 nargs = longest_to_int (exp->elts[pc + 1].longconst);
9952 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
9954 if (exp->elts[*pos].opcode == OP_VAR_VALUE
9955 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
9956 error (_("Unexpected unresolved symbol, %s, during evaluation"),
9957 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
9960 for (tem = 0; tem <= nargs; tem += 1)
9961 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9964 if (noside == EVAL_SKIP)
9968 if (ada_is_constrained_packed_array_type
9969 (desc_base_type (value_type (argvec[0]))))
9970 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
9971 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
9972 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
9973 /* This is a packed array that has already been fixed, and
9974 therefore already coerced to a simple array. Nothing further
9977 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
9978 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
9979 && VALUE_LVAL (argvec[0]) == lval_memory))
9980 argvec[0] = value_addr (argvec[0]);
9982 type = ada_check_typedef (value_type (argvec[0]));
9984 /* Ada allows us to implicitly dereference arrays when subscripting
9985 them. So, if this is an array typedef (encoding use for array
9986 access types encoded as fat pointers), strip it now. */
9987 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
9988 type = ada_typedef_target_type (type);
9990 if (TYPE_CODE (type) == TYPE_CODE_PTR)
9992 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
9994 case TYPE_CODE_FUNC:
9995 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
9997 case TYPE_CODE_ARRAY:
9999 case TYPE_CODE_STRUCT:
10000 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10001 argvec[0] = ada_value_ind (argvec[0]);
10002 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10005 error (_("cannot subscript or call something of type `%s'"),
10006 ada_type_name (value_type (argvec[0])));
10011 switch (TYPE_CODE (type))
10013 case TYPE_CODE_FUNC:
10014 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10016 struct type *rtype = TYPE_TARGET_TYPE (type);
10018 if (TYPE_GNU_IFUNC (type))
10019 return allocate_value (TYPE_TARGET_TYPE (rtype));
10020 return allocate_value (rtype);
10022 return call_function_by_hand (argvec[0], nargs, argvec + 1);
10023 case TYPE_CODE_INTERNAL_FUNCTION:
10024 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10025 /* We don't know anything about what the internal
10026 function might return, but we have to return
10028 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10031 return call_internal_function (exp->gdbarch, exp->language_defn,
10032 argvec[0], nargs, argvec + 1);
10034 case TYPE_CODE_STRUCT:
10038 arity = ada_array_arity (type);
10039 type = ada_array_element_type (type, nargs);
10041 error (_("cannot subscript or call a record"));
10042 if (arity != nargs)
10043 error (_("wrong number of subscripts; expecting %d"), arity);
10044 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10045 return value_zero (ada_aligned_type (type), lval_memory);
10047 unwrap_value (ada_value_subscript
10048 (argvec[0], nargs, argvec + 1));
10050 case TYPE_CODE_ARRAY:
10051 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10053 type = ada_array_element_type (type, nargs);
10055 error (_("element type of array unknown"));
10057 return value_zero (ada_aligned_type (type), lval_memory);
10060 unwrap_value (ada_value_subscript
10061 (ada_coerce_to_simple_array (argvec[0]),
10062 nargs, argvec + 1));
10063 case TYPE_CODE_PTR: /* Pointer to array */
10064 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10065 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10067 type = ada_array_element_type (type, nargs);
10069 error (_("element type of array unknown"));
10071 return value_zero (ada_aligned_type (type), lval_memory);
10074 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
10075 nargs, argvec + 1));
10078 error (_("Attempt to index or call something other than an "
10079 "array or function"));
10084 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10085 struct value *low_bound_val =
10086 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10087 struct value *high_bound_val =
10088 evaluate_subexp (NULL_TYPE, exp, pos, noside);
10090 LONGEST high_bound;
10092 low_bound_val = coerce_ref (low_bound_val);
10093 high_bound_val = coerce_ref (high_bound_val);
10094 low_bound = pos_atr (low_bound_val);
10095 high_bound = pos_atr (high_bound_val);
10097 if (noside == EVAL_SKIP)
10100 /* If this is a reference to an aligner type, then remove all
10102 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10103 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
10104 TYPE_TARGET_TYPE (value_type (array)) =
10105 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
10107 if (ada_is_constrained_packed_array_type (value_type (array)))
10108 error (_("cannot slice a packed array"));
10110 /* If this is a reference to an array or an array lvalue,
10111 convert to a pointer. */
10112 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10113 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
10114 && VALUE_LVAL (array) == lval_memory))
10115 array = value_addr (array);
10117 if (noside == EVAL_AVOID_SIDE_EFFECTS
10118 && ada_is_array_descriptor_type (ada_check_typedef
10119 (value_type (array))))
10120 return empty_array (ada_type_of_array (array, 0), low_bound);
10122 array = ada_coerce_to_simple_array_ptr (array);
10124 /* If we have more than one level of pointer indirection,
10125 dereference the value until we get only one level. */
10126 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10127 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
10129 array = value_ind (array);
10131 /* Make sure we really do have an array type before going further,
10132 to avoid a SEGV when trying to get the index type or the target
10133 type later down the road if the debug info generated by
10134 the compiler is incorrect or incomplete. */
10135 if (!ada_is_simple_array_type (value_type (array)))
10136 error (_("cannot take slice of non-array"));
10138 if (TYPE_CODE (ada_check_typedef (value_type (array)))
10141 struct type *type0 = ada_check_typedef (value_type (array));
10143 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10144 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
10147 struct type *arr_type0 =
10148 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
10150 return ada_value_slice_from_ptr (array, arr_type0,
10151 longest_to_int (low_bound),
10152 longest_to_int (high_bound));
10155 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10157 else if (high_bound < low_bound)
10158 return empty_array (value_type (array), low_bound);
10160 return ada_value_slice (array, longest_to_int (low_bound),
10161 longest_to_int (high_bound));
10164 case UNOP_IN_RANGE:
10166 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10167 type = check_typedef (exp->elts[pc + 1].type);
10169 if (noside == EVAL_SKIP)
10172 switch (TYPE_CODE (type))
10175 lim_warning (_("Membership test incompletely implemented; "
10176 "always returns true"));
10177 type = language_bool_type (exp->language_defn, exp->gdbarch);
10178 return value_from_longest (type, (LONGEST) 1);
10180 case TYPE_CODE_RANGE:
10181 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10182 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
10183 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10184 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10185 type = language_bool_type (exp->language_defn, exp->gdbarch);
10187 value_from_longest (type,
10188 (value_less (arg1, arg3)
10189 || value_equal (arg1, arg3))
10190 && (value_less (arg2, arg1)
10191 || value_equal (arg2, arg1)));
10194 case BINOP_IN_BOUNDS:
10196 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10197 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10199 if (noside == EVAL_SKIP)
10202 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10204 type = language_bool_type (exp->language_defn, exp->gdbarch);
10205 return value_zero (type, not_lval);
10208 tem = longest_to_int (exp->elts[pc + 1].longconst);
10210 type = ada_index_type (value_type (arg2), tem, "range");
10212 type = value_type (arg1);
10214 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10215 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
10217 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10218 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10219 type = language_bool_type (exp->language_defn, exp->gdbarch);
10221 value_from_longest (type,
10222 (value_less (arg1, arg3)
10223 || value_equal (arg1, arg3))
10224 && (value_less (arg2, arg1)
10225 || value_equal (arg2, arg1)));
10227 case TERNOP_IN_RANGE:
10228 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10229 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10230 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10232 if (noside == EVAL_SKIP)
10235 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10236 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10237 type = language_bool_type (exp->language_defn, exp->gdbarch);
10239 value_from_longest (type,
10240 (value_less (arg1, arg3)
10241 || value_equal (arg1, arg3))
10242 && (value_less (arg2, arg1)
10243 || value_equal (arg2, arg1)));
10247 case OP_ATR_LENGTH:
10249 struct type *type_arg;
10251 if (exp->elts[*pos].opcode == OP_TYPE)
10253 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10255 type_arg = check_typedef (exp->elts[pc + 2].type);
10259 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10263 if (exp->elts[*pos].opcode != OP_LONG)
10264 error (_("Invalid operand to '%s"), ada_attribute_name (op));
10265 tem = longest_to_int (exp->elts[*pos + 2].longconst);
10268 if (noside == EVAL_SKIP)
10271 if (type_arg == NULL)
10273 arg1 = ada_coerce_ref (arg1);
10275 if (ada_is_constrained_packed_array_type (value_type (arg1)))
10276 arg1 = ada_coerce_to_simple_array (arg1);
10278 type = ada_index_type (value_type (arg1), tem,
10279 ada_attribute_name (op));
10281 type = builtin_type (exp->gdbarch)->builtin_int;
10283 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10284 return allocate_value (type);
10288 default: /* Should never happen. */
10289 error (_("unexpected attribute encountered"));
10291 return value_from_longest
10292 (type, ada_array_bound (arg1, tem, 0));
10294 return value_from_longest
10295 (type, ada_array_bound (arg1, tem, 1));
10296 case OP_ATR_LENGTH:
10297 return value_from_longest
10298 (type, ada_array_length (arg1, tem));
10301 else if (discrete_type_p (type_arg))
10303 struct type *range_type;
10304 const char *name = ada_type_name (type_arg);
10307 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
10308 range_type = to_fixed_range_type (type_arg, NULL);
10309 if (range_type == NULL)
10310 range_type = type_arg;
10314 error (_("unexpected attribute encountered"));
10316 return value_from_longest
10317 (range_type, ada_discrete_type_low_bound (range_type));
10319 return value_from_longest
10320 (range_type, ada_discrete_type_high_bound (range_type));
10321 case OP_ATR_LENGTH:
10322 error (_("the 'length attribute applies only to array types"));
10325 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
10326 error (_("unimplemented type attribute"));
10331 if (ada_is_constrained_packed_array_type (type_arg))
10332 type_arg = decode_constrained_packed_array_type (type_arg);
10334 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10336 type = builtin_type (exp->gdbarch)->builtin_int;
10338 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10339 return allocate_value (type);
10344 error (_("unexpected attribute encountered"));
10346 low = ada_array_bound_from_type (type_arg, tem, 0);
10347 return value_from_longest (type, low);
10349 high = ada_array_bound_from_type (type_arg, tem, 1);
10350 return value_from_longest (type, high);
10351 case OP_ATR_LENGTH:
10352 low = ada_array_bound_from_type (type_arg, tem, 0);
10353 high = ada_array_bound_from_type (type_arg, tem, 1);
10354 return value_from_longest (type, high - low + 1);
10360 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10361 if (noside == EVAL_SKIP)
10364 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10365 return value_zero (ada_tag_type (arg1), not_lval);
10367 return ada_value_tag (arg1);
10371 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10372 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10373 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10374 if (noside == EVAL_SKIP)
10376 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10377 return value_zero (value_type (arg1), not_lval);
10380 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10381 return value_binop (arg1, arg2,
10382 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10385 case OP_ATR_MODULUS:
10387 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
10389 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10390 if (noside == EVAL_SKIP)
10393 if (!ada_is_modular_type (type_arg))
10394 error (_("'modulus must be applied to modular type"));
10396 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
10397 ada_modulus (type_arg));
10402 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10403 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10404 if (noside == EVAL_SKIP)
10406 type = builtin_type (exp->gdbarch)->builtin_int;
10407 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10408 return value_zero (type, not_lval);
10410 return value_pos_atr (type, arg1);
10413 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10414 type = value_type (arg1);
10416 /* If the argument is a reference, then dereference its type, since
10417 the user is really asking for the size of the actual object,
10418 not the size of the pointer. */
10419 if (TYPE_CODE (type) == TYPE_CODE_REF)
10420 type = TYPE_TARGET_TYPE (type);
10422 if (noside == EVAL_SKIP)
10424 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10425 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
10427 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
10428 TARGET_CHAR_BIT * TYPE_LENGTH (type));
10431 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10432 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10433 type = exp->elts[pc + 2].type;
10434 if (noside == EVAL_SKIP)
10436 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10437 return value_zero (type, not_lval);
10439 return value_val_atr (type, arg1);
10442 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10443 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10444 if (noside == EVAL_SKIP)
10446 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10447 return value_zero (value_type (arg1), not_lval);
10450 /* For integer exponentiation operations,
10451 only promote the first argument. */
10452 if (is_integral_type (value_type (arg2)))
10453 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10455 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10457 return value_binop (arg1, arg2, op);
10461 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10462 if (noside == EVAL_SKIP)
10468 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10469 if (noside == EVAL_SKIP)
10471 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10472 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
10473 return value_neg (arg1);
10478 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10479 if (noside == EVAL_SKIP)
10481 type = ada_check_typedef (value_type (arg1));
10482 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10484 if (ada_is_array_descriptor_type (type))
10485 /* GDB allows dereferencing GNAT array descriptors. */
10487 struct type *arrType = ada_type_of_array (arg1, 0);
10489 if (arrType == NULL)
10490 error (_("Attempt to dereference null array pointer."));
10491 return value_at_lazy (arrType, 0);
10493 else if (TYPE_CODE (type) == TYPE_CODE_PTR
10494 || TYPE_CODE (type) == TYPE_CODE_REF
10495 /* In C you can dereference an array to get the 1st elt. */
10496 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
10498 type = to_static_fixed_type
10500 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
10502 return value_zero (type, lval_memory);
10504 else if (TYPE_CODE (type) == TYPE_CODE_INT)
10506 /* GDB allows dereferencing an int. */
10507 if (expect_type == NULL)
10508 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10513 to_static_fixed_type (ada_aligned_type (expect_type));
10514 return value_zero (expect_type, lval_memory);
10518 error (_("Attempt to take contents of a non-pointer value."));
10520 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
10521 type = ada_check_typedef (value_type (arg1));
10523 if (TYPE_CODE (type) == TYPE_CODE_INT)
10524 /* GDB allows dereferencing an int. If we were given
10525 the expect_type, then use that as the target type.
10526 Otherwise, assume that the target type is an int. */
10528 if (expect_type != NULL)
10529 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
10532 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
10533 (CORE_ADDR) value_as_address (arg1));
10536 if (ada_is_array_descriptor_type (type))
10537 /* GDB allows dereferencing GNAT array descriptors. */
10538 return ada_coerce_to_simple_array (arg1);
10540 return ada_value_ind (arg1);
10542 case STRUCTOP_STRUCT:
10543 tem = longest_to_int (exp->elts[pc + 1].longconst);
10544 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
10545 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10546 if (noside == EVAL_SKIP)
10548 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10550 struct type *type1 = value_type (arg1);
10552 if (ada_is_tagged_type (type1, 1))
10554 type = ada_lookup_struct_elt_type (type1,
10555 &exp->elts[pc + 2].string,
10558 /* In this case, we assume that the field COULD exist
10559 in some extension of the type. Return an object of
10560 "type" void, which will match any formal
10561 (see ada_type_match). */
10562 return value_zero (builtin_type (exp->gdbarch)->builtin_void,
10567 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
10570 return value_zero (ada_aligned_type (type), lval_memory);
10573 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
10574 arg1 = unwrap_value (arg1);
10575 return ada_to_fixed_value (arg1);
10578 /* The value is not supposed to be used. This is here to make it
10579 easier to accommodate expressions that contain types. */
10581 if (noside == EVAL_SKIP)
10583 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10584 return allocate_value (exp->elts[pc + 1].type);
10586 error (_("Attempt to use a type name as an expression"));
10591 case OP_DISCRETE_RANGE:
10592 case OP_POSITIONAL:
10594 if (noside == EVAL_NORMAL)
10598 error (_("Undefined name, ambiguous name, or renaming used in "
10599 "component association: %s."), &exp->elts[pc+2].string);
10601 error (_("Aggregates only allowed on the right of an assignment"));
10603 internal_error (__FILE__, __LINE__,
10604 _("aggregate apparently mangled"));
10607 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10609 for (tem = 0; tem < nargs; tem += 1)
10610 ada_evaluate_subexp (NULL, exp, pos, noside);
10615 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
10621 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
10622 type name that encodes the 'small and 'delta information.
10623 Otherwise, return NULL. */
10625 static const char *
10626 fixed_type_info (struct type *type)
10628 const char *name = ada_type_name (type);
10629 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
10631 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
10633 const char *tail = strstr (name, "___XF_");
10640 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
10641 return fixed_type_info (TYPE_TARGET_TYPE (type));
10646 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
10649 ada_is_fixed_point_type (struct type *type)
10651 return fixed_type_info (type) != NULL;
10654 /* Return non-zero iff TYPE represents a System.Address type. */
10657 ada_is_system_address_type (struct type *type)
10659 return (TYPE_NAME (type)
10660 && strcmp (TYPE_NAME (type), "system__address") == 0);
10663 /* Assuming that TYPE is the representation of an Ada fixed-point
10664 type, return its delta, or -1 if the type is malformed and the
10665 delta cannot be determined. */
10668 ada_delta (struct type *type)
10670 const char *encoding = fixed_type_info (type);
10673 /* Strictly speaking, num and den are encoded as integer. However,
10674 they may not fit into a long, and they will have to be converted
10675 to DOUBLEST anyway. So scan them as DOUBLEST. */
10676 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10683 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
10684 factor ('SMALL value) associated with the type. */
10687 scaling_factor (struct type *type)
10689 const char *encoding = fixed_type_info (type);
10690 DOUBLEST num0, den0, num1, den1;
10693 /* Strictly speaking, num's and den's are encoded as integer. However,
10694 they may not fit into a long, and they will have to be converted
10695 to DOUBLEST anyway. So scan them as DOUBLEST. */
10696 n = sscanf (encoding,
10697 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
10698 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
10699 &num0, &den0, &num1, &den1);
10704 return num1 / den1;
10706 return num0 / den0;
10710 /* Assuming that X is the representation of a value of fixed-point
10711 type TYPE, return its floating-point equivalent. */
10714 ada_fixed_to_float (struct type *type, LONGEST x)
10716 return (DOUBLEST) x *scaling_factor (type);
10719 /* The representation of a fixed-point value of type TYPE
10720 corresponding to the value X. */
10723 ada_float_to_fixed (struct type *type, DOUBLEST x)
10725 return (LONGEST) (x / scaling_factor (type) + 0.5);
10732 /* Scan STR beginning at position K for a discriminant name, and
10733 return the value of that discriminant field of DVAL in *PX. If
10734 PNEW_K is not null, put the position of the character beyond the
10735 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
10736 not alter *PX and *PNEW_K if unsuccessful. */
10739 scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
10742 static char *bound_buffer = NULL;
10743 static size_t bound_buffer_len = 0;
10746 struct value *bound_val;
10748 if (dval == NULL || str == NULL || str[k] == '\0')
10751 pend = strstr (str + k, "__");
10755 k += strlen (bound);
10759 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
10760 bound = bound_buffer;
10761 strncpy (bound_buffer, str + k, pend - (str + k));
10762 bound[pend - (str + k)] = '\0';
10766 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
10767 if (bound_val == NULL)
10770 *px = value_as_long (bound_val);
10771 if (pnew_k != NULL)
10776 /* Value of variable named NAME in the current environment. If
10777 no such variable found, then if ERR_MSG is null, returns 0, and
10778 otherwise causes an error with message ERR_MSG. */
10780 static struct value *
10781 get_var_value (char *name, char *err_msg)
10783 struct ada_symbol_info *syms;
10786 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
10791 if (err_msg == NULL)
10794 error (("%s"), err_msg);
10797 return value_of_variable (syms[0].sym, syms[0].block);
10800 /* Value of integer variable named NAME in the current environment. If
10801 no such variable found, returns 0, and sets *FLAG to 0. If
10802 successful, sets *FLAG to 1. */
10805 get_int_var_value (char *name, int *flag)
10807 struct value *var_val = get_var_value (name, 0);
10819 return value_as_long (var_val);
10824 /* Return a range type whose base type is that of the range type named
10825 NAME in the current environment, and whose bounds are calculated
10826 from NAME according to the GNAT range encoding conventions.
10827 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
10828 corresponding range type from debug information; fall back to using it
10829 if symbol lookup fails. If a new type must be created, allocate it
10830 like ORIG_TYPE was. The bounds information, in general, is encoded
10831 in NAME, the base type given in the named range type. */
10833 static struct type *
10834 to_fixed_range_type (struct type *raw_type, struct value *dval)
10837 struct type *base_type;
10838 char *subtype_info;
10840 gdb_assert (raw_type != NULL);
10841 gdb_assert (TYPE_NAME (raw_type) != NULL);
10843 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
10844 base_type = TYPE_TARGET_TYPE (raw_type);
10846 base_type = raw_type;
10848 name = TYPE_NAME (raw_type);
10849 subtype_info = strstr (name, "___XD");
10850 if (subtype_info == NULL)
10852 LONGEST L = ada_discrete_type_low_bound (raw_type);
10853 LONGEST U = ada_discrete_type_high_bound (raw_type);
10855 if (L < INT_MIN || U > INT_MAX)
10858 return create_range_type (alloc_type_copy (raw_type), raw_type,
10859 ada_discrete_type_low_bound (raw_type),
10860 ada_discrete_type_high_bound (raw_type));
10864 static char *name_buf = NULL;
10865 static size_t name_len = 0;
10866 int prefix_len = subtype_info - name;
10872 GROW_VECT (name_buf, name_len, prefix_len + 5);
10873 strncpy (name_buf, name, prefix_len);
10874 name_buf[prefix_len] = '\0';
10877 bounds_str = strchr (subtype_info, '_');
10880 if (*subtype_info == 'L')
10882 if (!ada_scan_number (bounds_str, n, &L, &n)
10883 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
10885 if (bounds_str[n] == '_')
10887 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
10895 strcpy (name_buf + prefix_len, "___L");
10896 L = get_int_var_value (name_buf, &ok);
10899 lim_warning (_("Unknown lower bound, using 1."));
10904 if (*subtype_info == 'U')
10906 if (!ada_scan_number (bounds_str, n, &U, &n)
10907 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
10914 strcpy (name_buf + prefix_len, "___U");
10915 U = get_int_var_value (name_buf, &ok);
10918 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
10923 type = create_range_type (alloc_type_copy (raw_type), base_type, L, U);
10924 TYPE_NAME (type) = name;
10929 /* True iff NAME is the name of a range type. */
10932 ada_is_range_type_name (const char *name)
10934 return (name != NULL && strstr (name, "___XD"));
10938 /* Modular types */
10940 /* True iff TYPE is an Ada modular type. */
10943 ada_is_modular_type (struct type *type)
10945 struct type *subranged_type = get_base_type (type);
10947 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
10948 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
10949 && TYPE_UNSIGNED (subranged_type));
10952 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
10955 ada_modulus (struct type *type)
10957 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
10961 /* Ada exception catchpoint support:
10962 ---------------------------------
10964 We support 3 kinds of exception catchpoints:
10965 . catchpoints on Ada exceptions
10966 . catchpoints on unhandled Ada exceptions
10967 . catchpoints on failed assertions
10969 Exceptions raised during failed assertions, or unhandled exceptions
10970 could perfectly be caught with the general catchpoint on Ada exceptions.
10971 However, we can easily differentiate these two special cases, and having
10972 the option to distinguish these two cases from the rest can be useful
10973 to zero-in on certain situations.
10975 Exception catchpoints are a specialized form of breakpoint,
10976 since they rely on inserting breakpoints inside known routines
10977 of the GNAT runtime. The implementation therefore uses a standard
10978 breakpoint structure of the BP_BREAKPOINT type, but with its own set
10981 Support in the runtime for exception catchpoints have been changed
10982 a few times already, and these changes affect the implementation
10983 of these catchpoints. In order to be able to support several
10984 variants of the runtime, we use a sniffer that will determine
10985 the runtime variant used by the program being debugged. */
10987 /* Ada's standard exceptions. */
10989 static char *standard_exc[] = {
10990 "constraint_error",
10996 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
10998 /* A structure that describes how to support exception catchpoints
10999 for a given executable. */
11001 struct exception_support_info
11003 /* The name of the symbol to break on in order to insert
11004 a catchpoint on exceptions. */
11005 const char *catch_exception_sym;
11007 /* The name of the symbol to break on in order to insert
11008 a catchpoint on unhandled exceptions. */
11009 const char *catch_exception_unhandled_sym;
11011 /* The name of the symbol to break on in order to insert
11012 a catchpoint on failed assertions. */
11013 const char *catch_assert_sym;
11015 /* Assuming that the inferior just triggered an unhandled exception
11016 catchpoint, this function is responsible for returning the address
11017 in inferior memory where the name of that exception is stored.
11018 Return zero if the address could not be computed. */
11019 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
11022 static CORE_ADDR ada_unhandled_exception_name_addr (void);
11023 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
11025 /* The following exception support info structure describes how to
11026 implement exception catchpoints with the latest version of the
11027 Ada runtime (as of 2007-03-06). */
11029 static const struct exception_support_info default_exception_support_info =
11031 "__gnat_debug_raise_exception", /* catch_exception_sym */
11032 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11033 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11034 ada_unhandled_exception_name_addr
11037 /* The following exception support info structure describes how to
11038 implement exception catchpoints with a slightly older version
11039 of the Ada runtime. */
11041 static const struct exception_support_info exception_support_info_fallback =
11043 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11044 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11045 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11046 ada_unhandled_exception_name_addr_from_raise
11049 /* Return nonzero if we can detect the exception support routines
11050 described in EINFO.
11052 This function errors out if an abnormal situation is detected
11053 (for instance, if we find the exception support routines, but
11054 that support is found to be incomplete). */
11057 ada_has_this_exception_support (const struct exception_support_info *einfo)
11059 struct symbol *sym;
11061 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11062 that should be compiled with debugging information. As a result, we
11063 expect to find that symbol in the symtabs. */
11065 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11068 /* Perhaps we did not find our symbol because the Ada runtime was
11069 compiled without debugging info, or simply stripped of it.
11070 It happens on some GNU/Linux distributions for instance, where
11071 users have to install a separate debug package in order to get
11072 the runtime's debugging info. In that situation, let the user
11073 know why we cannot insert an Ada exception catchpoint.
11075 Note: Just for the purpose of inserting our Ada exception
11076 catchpoint, we could rely purely on the associated minimal symbol.
11077 But we would be operating in degraded mode anyway, since we are
11078 still lacking the debugging info needed later on to extract
11079 the name of the exception being raised (this name is printed in
11080 the catchpoint message, and is also used when trying to catch
11081 a specific exception). We do not handle this case for now. */
11082 struct minimal_symbol *msym
11083 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11085 if (msym && MSYMBOL_TYPE (msym) != mst_solib_trampoline)
11086 error (_("Your Ada runtime appears to be missing some debugging "
11087 "information.\nCannot insert Ada exception catchpoint "
11088 "in this configuration."));
11093 /* Make sure that the symbol we found corresponds to a function. */
11095 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11096 error (_("Symbol \"%s\" is not a function (class = %d)"),
11097 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11102 /* Inspect the Ada runtime and determine which exception info structure
11103 should be used to provide support for exception catchpoints.
11105 This function will always set the per-inferior exception_info,
11106 or raise an error. */
11109 ada_exception_support_info_sniffer (void)
11111 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11113 /* If the exception info is already known, then no need to recompute it. */
11114 if (data->exception_info != NULL)
11117 /* Check the latest (default) exception support info. */
11118 if (ada_has_this_exception_support (&default_exception_support_info))
11120 data->exception_info = &default_exception_support_info;
11124 /* Try our fallback exception suport info. */
11125 if (ada_has_this_exception_support (&exception_support_info_fallback))
11127 data->exception_info = &exception_support_info_fallback;
11131 /* Sometimes, it is normal for us to not be able to find the routine
11132 we are looking for. This happens when the program is linked with
11133 the shared version of the GNAT runtime, and the program has not been
11134 started yet. Inform the user of these two possible causes if
11137 if (ada_update_initial_language (language_unknown) != language_ada)
11138 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11140 /* If the symbol does not exist, then check that the program is
11141 already started, to make sure that shared libraries have been
11142 loaded. If it is not started, this may mean that the symbol is
11143 in a shared library. */
11145 if (ptid_get_pid (inferior_ptid) == 0)
11146 error (_("Unable to insert catchpoint. Try to start the program first."));
11148 /* At this point, we know that we are debugging an Ada program and
11149 that the inferior has been started, but we still are not able to
11150 find the run-time symbols. That can mean that we are in
11151 configurable run time mode, or that a-except as been optimized
11152 out by the linker... In any case, at this point it is not worth
11153 supporting this feature. */
11155 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11158 /* True iff FRAME is very likely to be that of a function that is
11159 part of the runtime system. This is all very heuristic, but is
11160 intended to be used as advice as to what frames are uninteresting
11164 is_known_support_routine (struct frame_info *frame)
11166 struct symtab_and_line sal;
11168 enum language func_lang;
11170 const char *fullname;
11172 /* If this code does not have any debugging information (no symtab),
11173 This cannot be any user code. */
11175 find_frame_sal (frame, &sal);
11176 if (sal.symtab == NULL)
11179 /* If there is a symtab, but the associated source file cannot be
11180 located, then assume this is not user code: Selecting a frame
11181 for which we cannot display the code would not be very helpful
11182 for the user. This should also take care of case such as VxWorks
11183 where the kernel has some debugging info provided for a few units. */
11185 fullname = symtab_to_fullname (sal.symtab);
11186 if (access (fullname, R_OK) != 0)
11189 /* Check the unit filename againt the Ada runtime file naming.
11190 We also check the name of the objfile against the name of some
11191 known system libraries that sometimes come with debugging info
11194 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11196 re_comp (known_runtime_file_name_patterns[i]);
11197 if (re_exec (lbasename (sal.symtab->filename)))
11199 if (sal.symtab->objfile != NULL
11200 && re_exec (objfile_name (sal.symtab->objfile)))
11204 /* Check whether the function is a GNAT-generated entity. */
11206 find_frame_funname (frame, &func_name, &func_lang, NULL);
11207 if (func_name == NULL)
11210 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11212 re_comp (known_auxiliary_function_name_patterns[i]);
11213 if (re_exec (func_name))
11224 /* Find the first frame that contains debugging information and that is not
11225 part of the Ada run-time, starting from FI and moving upward. */
11228 ada_find_printable_frame (struct frame_info *fi)
11230 for (; fi != NULL; fi = get_prev_frame (fi))
11232 if (!is_known_support_routine (fi))
11241 /* Assuming that the inferior just triggered an unhandled exception
11242 catchpoint, return the address in inferior memory where the name
11243 of the exception is stored.
11245 Return zero if the address could not be computed. */
11248 ada_unhandled_exception_name_addr (void)
11250 return parse_and_eval_address ("e.full_name");
11253 /* Same as ada_unhandled_exception_name_addr, except that this function
11254 should be used when the inferior uses an older version of the runtime,
11255 where the exception name needs to be extracted from a specific frame
11256 several frames up in the callstack. */
11259 ada_unhandled_exception_name_addr_from_raise (void)
11262 struct frame_info *fi;
11263 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11264 struct cleanup *old_chain;
11266 /* To determine the name of this exception, we need to select
11267 the frame corresponding to RAISE_SYM_NAME. This frame is
11268 at least 3 levels up, so we simply skip the first 3 frames
11269 without checking the name of their associated function. */
11270 fi = get_current_frame ();
11271 for (frame_level = 0; frame_level < 3; frame_level += 1)
11273 fi = get_prev_frame (fi);
11275 old_chain = make_cleanup (null_cleanup, NULL);
11279 enum language func_lang;
11281 find_frame_funname (fi, &func_name, &func_lang, NULL);
11282 if (func_name != NULL)
11284 make_cleanup (xfree, func_name);
11286 if (strcmp (func_name,
11287 data->exception_info->catch_exception_sym) == 0)
11288 break; /* We found the frame we were looking for... */
11289 fi = get_prev_frame (fi);
11292 do_cleanups (old_chain);
11298 return parse_and_eval_address ("id.full_name");
11301 /* Assuming the inferior just triggered an Ada exception catchpoint
11302 (of any type), return the address in inferior memory where the name
11303 of the exception is stored, if applicable.
11305 Return zero if the address could not be computed, or if not relevant. */
11308 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
11309 struct breakpoint *b)
11311 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11315 case ada_catch_exception:
11316 return (parse_and_eval_address ("e.full_name"));
11319 case ada_catch_exception_unhandled:
11320 return data->exception_info->unhandled_exception_name_addr ();
11323 case ada_catch_assert:
11324 return 0; /* Exception name is not relevant in this case. */
11328 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11332 return 0; /* Should never be reached. */
11335 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11336 any error that ada_exception_name_addr_1 might cause to be thrown.
11337 When an error is intercepted, a warning with the error message is printed,
11338 and zero is returned. */
11341 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
11342 struct breakpoint *b)
11344 volatile struct gdb_exception e;
11345 CORE_ADDR result = 0;
11347 TRY_CATCH (e, RETURN_MASK_ERROR)
11349 result = ada_exception_name_addr_1 (ex, b);
11354 warning (_("failed to get exception name: %s"), e.message);
11361 static char *ada_exception_catchpoint_cond_string (const char *excep_string);
11363 /* Ada catchpoints.
11365 In the case of catchpoints on Ada exceptions, the catchpoint will
11366 stop the target on every exception the program throws. When a user
11367 specifies the name of a specific exception, we translate this
11368 request into a condition expression (in text form), and then parse
11369 it into an expression stored in each of the catchpoint's locations.
11370 We then use this condition to check whether the exception that was
11371 raised is the one the user is interested in. If not, then the
11372 target is resumed again. We store the name of the requested
11373 exception, in order to be able to re-set the condition expression
11374 when symbols change. */
11376 /* An instance of this type is used to represent an Ada catchpoint
11377 breakpoint location. It includes a "struct bp_location" as a kind
11378 of base class; users downcast to "struct bp_location *" when
11381 struct ada_catchpoint_location
11383 /* The base class. */
11384 struct bp_location base;
11386 /* The condition that checks whether the exception that was raised
11387 is the specific exception the user specified on catchpoint
11389 struct expression *excep_cond_expr;
11392 /* Implement the DTOR method in the bp_location_ops structure for all
11393 Ada exception catchpoint kinds. */
11396 ada_catchpoint_location_dtor (struct bp_location *bl)
11398 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
11400 xfree (al->excep_cond_expr);
11403 /* The vtable to be used in Ada catchpoint locations. */
11405 static const struct bp_location_ops ada_catchpoint_location_ops =
11407 ada_catchpoint_location_dtor
11410 /* An instance of this type is used to represent an Ada catchpoint.
11411 It includes a "struct breakpoint" as a kind of base class; users
11412 downcast to "struct breakpoint *" when needed. */
11414 struct ada_catchpoint
11416 /* The base class. */
11417 struct breakpoint base;
11419 /* The name of the specific exception the user specified. */
11420 char *excep_string;
11423 /* Parse the exception condition string in the context of each of the
11424 catchpoint's locations, and store them for later evaluation. */
11427 create_excep_cond_exprs (struct ada_catchpoint *c)
11429 struct cleanup *old_chain;
11430 struct bp_location *bl;
11433 /* Nothing to do if there's no specific exception to catch. */
11434 if (c->excep_string == NULL)
11437 /* Same if there are no locations... */
11438 if (c->base.loc == NULL)
11441 /* Compute the condition expression in text form, from the specific
11442 expection we want to catch. */
11443 cond_string = ada_exception_catchpoint_cond_string (c->excep_string);
11444 old_chain = make_cleanup (xfree, cond_string);
11446 /* Iterate over all the catchpoint's locations, and parse an
11447 expression for each. */
11448 for (bl = c->base.loc; bl != NULL; bl = bl->next)
11450 struct ada_catchpoint_location *ada_loc
11451 = (struct ada_catchpoint_location *) bl;
11452 struct expression *exp = NULL;
11454 if (!bl->shlib_disabled)
11456 volatile struct gdb_exception e;
11460 TRY_CATCH (e, RETURN_MASK_ERROR)
11462 exp = parse_exp_1 (&s, bl->address,
11463 block_for_pc (bl->address), 0);
11467 warning (_("failed to reevaluate internal exception condition "
11468 "for catchpoint %d: %s"),
11469 c->base.number, e.message);
11470 /* There is a bug in GCC on sparc-solaris when building with
11471 optimization which causes EXP to change unexpectedly
11472 (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56982).
11473 The problem should be fixed starting with GCC 4.9.
11474 In the meantime, work around it by forcing EXP back
11480 ada_loc->excep_cond_expr = exp;
11483 do_cleanups (old_chain);
11486 /* Implement the DTOR method in the breakpoint_ops structure for all
11487 exception catchpoint kinds. */
11490 dtor_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
11492 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11494 xfree (c->excep_string);
11496 bkpt_breakpoint_ops.dtor (b);
11499 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11500 structure for all exception catchpoint kinds. */
11502 static struct bp_location *
11503 allocate_location_exception (enum ada_exception_catchpoint_kind ex,
11504 struct breakpoint *self)
11506 struct ada_catchpoint_location *loc;
11508 loc = XNEW (struct ada_catchpoint_location);
11509 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
11510 loc->excep_cond_expr = NULL;
11514 /* Implement the RE_SET method in the breakpoint_ops structure for all
11515 exception catchpoint kinds. */
11518 re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
11520 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11522 /* Call the base class's method. This updates the catchpoint's
11524 bkpt_breakpoint_ops.re_set (b);
11526 /* Reparse the exception conditional expressions. One for each
11528 create_excep_cond_exprs (c);
11531 /* Returns true if we should stop for this breakpoint hit. If the
11532 user specified a specific exception, we only want to cause a stop
11533 if the program thrown that exception. */
11536 should_stop_exception (const struct bp_location *bl)
11538 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
11539 const struct ada_catchpoint_location *ada_loc
11540 = (const struct ada_catchpoint_location *) bl;
11541 volatile struct gdb_exception ex;
11544 /* With no specific exception, should always stop. */
11545 if (c->excep_string == NULL)
11548 if (ada_loc->excep_cond_expr == NULL)
11550 /* We will have a NULL expression if back when we were creating
11551 the expressions, this location's had failed to parse. */
11556 TRY_CATCH (ex, RETURN_MASK_ALL)
11558 struct value *mark;
11560 mark = value_mark ();
11561 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
11562 value_free_to_mark (mark);
11565 exception_fprintf (gdb_stderr, ex,
11566 _("Error in testing exception condition:\n"));
11570 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
11571 for all exception catchpoint kinds. */
11574 check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
11576 bs->stop = should_stop_exception (bs->bp_location_at);
11579 /* Implement the PRINT_IT method in the breakpoint_ops structure
11580 for all exception catchpoint kinds. */
11582 static enum print_stop_action
11583 print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
11585 struct ui_out *uiout = current_uiout;
11586 struct breakpoint *b = bs->breakpoint_at;
11588 annotate_catchpoint (b->number);
11590 if (ui_out_is_mi_like_p (uiout))
11592 ui_out_field_string (uiout, "reason",
11593 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
11594 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
11597 ui_out_text (uiout,
11598 b->disposition == disp_del ? "\nTemporary catchpoint "
11599 : "\nCatchpoint ");
11600 ui_out_field_int (uiout, "bkptno", b->number);
11601 ui_out_text (uiout, ", ");
11605 case ada_catch_exception:
11606 case ada_catch_exception_unhandled:
11608 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
11609 char exception_name[256];
11613 read_memory (addr, (gdb_byte *) exception_name,
11614 sizeof (exception_name) - 1);
11615 exception_name [sizeof (exception_name) - 1] = '\0';
11619 /* For some reason, we were unable to read the exception
11620 name. This could happen if the Runtime was compiled
11621 without debugging info, for instance. In that case,
11622 just replace the exception name by the generic string
11623 "exception" - it will read as "an exception" in the
11624 notification we are about to print. */
11625 memcpy (exception_name, "exception", sizeof ("exception"));
11627 /* In the case of unhandled exception breakpoints, we print
11628 the exception name as "unhandled EXCEPTION_NAME", to make
11629 it clearer to the user which kind of catchpoint just got
11630 hit. We used ui_out_text to make sure that this extra
11631 info does not pollute the exception name in the MI case. */
11632 if (ex == ada_catch_exception_unhandled)
11633 ui_out_text (uiout, "unhandled ");
11634 ui_out_field_string (uiout, "exception-name", exception_name);
11637 case ada_catch_assert:
11638 /* In this case, the name of the exception is not really
11639 important. Just print "failed assertion" to make it clearer
11640 that his program just hit an assertion-failure catchpoint.
11641 We used ui_out_text because this info does not belong in
11643 ui_out_text (uiout, "failed assertion");
11646 ui_out_text (uiout, " at ");
11647 ada_find_printable_frame (get_current_frame ());
11649 return PRINT_SRC_AND_LOC;
11652 /* Implement the PRINT_ONE method in the breakpoint_ops structure
11653 for all exception catchpoint kinds. */
11656 print_one_exception (enum ada_exception_catchpoint_kind ex,
11657 struct breakpoint *b, struct bp_location **last_loc)
11659 struct ui_out *uiout = current_uiout;
11660 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11661 struct value_print_options opts;
11663 get_user_print_options (&opts);
11664 if (opts.addressprint)
11666 annotate_field (4);
11667 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
11670 annotate_field (5);
11671 *last_loc = b->loc;
11674 case ada_catch_exception:
11675 if (c->excep_string != NULL)
11677 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11679 ui_out_field_string (uiout, "what", msg);
11683 ui_out_field_string (uiout, "what", "all Ada exceptions");
11687 case ada_catch_exception_unhandled:
11688 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
11691 case ada_catch_assert:
11692 ui_out_field_string (uiout, "what", "failed Ada assertions");
11696 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11701 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
11702 for all exception catchpoint kinds. */
11705 print_mention_exception (enum ada_exception_catchpoint_kind ex,
11706 struct breakpoint *b)
11708 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11709 struct ui_out *uiout = current_uiout;
11711 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
11712 : _("Catchpoint "));
11713 ui_out_field_int (uiout, "bkptno", b->number);
11714 ui_out_text (uiout, ": ");
11718 case ada_catch_exception:
11719 if (c->excep_string != NULL)
11721 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
11722 struct cleanup *old_chain = make_cleanup (xfree, info);
11724 ui_out_text (uiout, info);
11725 do_cleanups (old_chain);
11728 ui_out_text (uiout, _("all Ada exceptions"));
11731 case ada_catch_exception_unhandled:
11732 ui_out_text (uiout, _("unhandled Ada exceptions"));
11735 case ada_catch_assert:
11736 ui_out_text (uiout, _("failed Ada assertions"));
11740 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11745 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11746 for all exception catchpoint kinds. */
11749 print_recreate_exception (enum ada_exception_catchpoint_kind ex,
11750 struct breakpoint *b, struct ui_file *fp)
11752 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
11756 case ada_catch_exception:
11757 fprintf_filtered (fp, "catch exception");
11758 if (c->excep_string != NULL)
11759 fprintf_filtered (fp, " %s", c->excep_string);
11762 case ada_catch_exception_unhandled:
11763 fprintf_filtered (fp, "catch exception unhandled");
11766 case ada_catch_assert:
11767 fprintf_filtered (fp, "catch assert");
11771 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11773 print_recreate_thread (b, fp);
11776 /* Virtual table for "catch exception" breakpoints. */
11779 dtor_catch_exception (struct breakpoint *b)
11781 dtor_exception (ada_catch_exception, b);
11784 static struct bp_location *
11785 allocate_location_catch_exception (struct breakpoint *self)
11787 return allocate_location_exception (ada_catch_exception, self);
11791 re_set_catch_exception (struct breakpoint *b)
11793 re_set_exception (ada_catch_exception, b);
11797 check_status_catch_exception (bpstat bs)
11799 check_status_exception (ada_catch_exception, bs);
11802 static enum print_stop_action
11803 print_it_catch_exception (bpstat bs)
11805 return print_it_exception (ada_catch_exception, bs);
11809 print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
11811 print_one_exception (ada_catch_exception, b, last_loc);
11815 print_mention_catch_exception (struct breakpoint *b)
11817 print_mention_exception (ada_catch_exception, b);
11821 print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
11823 print_recreate_exception (ada_catch_exception, b, fp);
11826 static struct breakpoint_ops catch_exception_breakpoint_ops;
11828 /* Virtual table for "catch exception unhandled" breakpoints. */
11831 dtor_catch_exception_unhandled (struct breakpoint *b)
11833 dtor_exception (ada_catch_exception_unhandled, b);
11836 static struct bp_location *
11837 allocate_location_catch_exception_unhandled (struct breakpoint *self)
11839 return allocate_location_exception (ada_catch_exception_unhandled, self);
11843 re_set_catch_exception_unhandled (struct breakpoint *b)
11845 re_set_exception (ada_catch_exception_unhandled, b);
11849 check_status_catch_exception_unhandled (bpstat bs)
11851 check_status_exception (ada_catch_exception_unhandled, bs);
11854 static enum print_stop_action
11855 print_it_catch_exception_unhandled (bpstat bs)
11857 return print_it_exception (ada_catch_exception_unhandled, bs);
11861 print_one_catch_exception_unhandled (struct breakpoint *b,
11862 struct bp_location **last_loc)
11864 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
11868 print_mention_catch_exception_unhandled (struct breakpoint *b)
11870 print_mention_exception (ada_catch_exception_unhandled, b);
11874 print_recreate_catch_exception_unhandled (struct breakpoint *b,
11875 struct ui_file *fp)
11877 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
11880 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
11882 /* Virtual table for "catch assert" breakpoints. */
11885 dtor_catch_assert (struct breakpoint *b)
11887 dtor_exception (ada_catch_assert, b);
11890 static struct bp_location *
11891 allocate_location_catch_assert (struct breakpoint *self)
11893 return allocate_location_exception (ada_catch_assert, self);
11897 re_set_catch_assert (struct breakpoint *b)
11899 re_set_exception (ada_catch_assert, b);
11903 check_status_catch_assert (bpstat bs)
11905 check_status_exception (ada_catch_assert, bs);
11908 static enum print_stop_action
11909 print_it_catch_assert (bpstat bs)
11911 return print_it_exception (ada_catch_assert, bs);
11915 print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
11917 print_one_exception (ada_catch_assert, b, last_loc);
11921 print_mention_catch_assert (struct breakpoint *b)
11923 print_mention_exception (ada_catch_assert, b);
11927 print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
11929 print_recreate_exception (ada_catch_assert, b, fp);
11932 static struct breakpoint_ops catch_assert_breakpoint_ops;
11934 /* Return a newly allocated copy of the first space-separated token
11935 in ARGSP, and then adjust ARGSP to point immediately after that
11938 Return NULL if ARGPS does not contain any more tokens. */
11941 ada_get_next_arg (char **argsp)
11943 char *args = *argsp;
11947 args = skip_spaces (args);
11948 if (args[0] == '\0')
11949 return NULL; /* No more arguments. */
11951 /* Find the end of the current argument. */
11953 end = skip_to_space (args);
11955 /* Adjust ARGSP to point to the start of the next argument. */
11959 /* Make a copy of the current argument and return it. */
11961 result = xmalloc (end - args + 1);
11962 strncpy (result, args, end - args);
11963 result[end - args] = '\0';
11968 /* Split the arguments specified in a "catch exception" command.
11969 Set EX to the appropriate catchpoint type.
11970 Set EXCEP_STRING to the name of the specific exception if
11971 specified by the user.
11972 If a condition is found at the end of the arguments, the condition
11973 expression is stored in COND_STRING (memory must be deallocated
11974 after use). Otherwise COND_STRING is set to NULL. */
11977 catch_ada_exception_command_split (char *args,
11978 enum ada_exception_catchpoint_kind *ex,
11979 char **excep_string,
11980 char **cond_string)
11982 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
11983 char *exception_name;
11986 exception_name = ada_get_next_arg (&args);
11987 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
11989 /* This is not an exception name; this is the start of a condition
11990 expression for a catchpoint on all exceptions. So, "un-get"
11991 this token, and set exception_name to NULL. */
11992 xfree (exception_name);
11993 exception_name = NULL;
11996 make_cleanup (xfree, exception_name);
11998 /* Check to see if we have a condition. */
12000 args = skip_spaces (args);
12001 if (strncmp (args, "if", 2) == 0
12002 && (isspace (args[2]) || args[2] == '\0'))
12005 args = skip_spaces (args);
12007 if (args[0] == '\0')
12008 error (_("Condition missing after `if' keyword"));
12009 cond = xstrdup (args);
12010 make_cleanup (xfree, cond);
12012 args += strlen (args);
12015 /* Check that we do not have any more arguments. Anything else
12018 if (args[0] != '\0')
12019 error (_("Junk at end of expression"));
12021 discard_cleanups (old_chain);
12023 if (exception_name == NULL)
12025 /* Catch all exceptions. */
12026 *ex = ada_catch_exception;
12027 *excep_string = NULL;
12029 else if (strcmp (exception_name, "unhandled") == 0)
12031 /* Catch unhandled exceptions. */
12032 *ex = ada_catch_exception_unhandled;
12033 *excep_string = NULL;
12037 /* Catch a specific exception. */
12038 *ex = ada_catch_exception;
12039 *excep_string = exception_name;
12041 *cond_string = cond;
12044 /* Return the name of the symbol on which we should break in order to
12045 implement a catchpoint of the EX kind. */
12047 static const char *
12048 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
12050 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12052 gdb_assert (data->exception_info != NULL);
12056 case ada_catch_exception:
12057 return (data->exception_info->catch_exception_sym);
12059 case ada_catch_exception_unhandled:
12060 return (data->exception_info->catch_exception_unhandled_sym);
12062 case ada_catch_assert:
12063 return (data->exception_info->catch_assert_sym);
12066 internal_error (__FILE__, __LINE__,
12067 _("unexpected catchpoint kind (%d)"), ex);
12071 /* Return the breakpoint ops "virtual table" used for catchpoints
12074 static const struct breakpoint_ops *
12075 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
12079 case ada_catch_exception:
12080 return (&catch_exception_breakpoint_ops);
12082 case ada_catch_exception_unhandled:
12083 return (&catch_exception_unhandled_breakpoint_ops);
12085 case ada_catch_assert:
12086 return (&catch_assert_breakpoint_ops);
12089 internal_error (__FILE__, __LINE__,
12090 _("unexpected catchpoint kind (%d)"), ex);
12094 /* Return the condition that will be used to match the current exception
12095 being raised with the exception that the user wants to catch. This
12096 assumes that this condition is used when the inferior just triggered
12097 an exception catchpoint.
12099 The string returned is a newly allocated string that needs to be
12100 deallocated later. */
12103 ada_exception_catchpoint_cond_string (const char *excep_string)
12107 /* The standard exceptions are a special case. They are defined in
12108 runtime units that have been compiled without debugging info; if
12109 EXCEP_STRING is the not-fully-qualified name of a standard
12110 exception (e.g. "constraint_error") then, during the evaluation
12111 of the condition expression, the symbol lookup on this name would
12112 *not* return this standard exception. The catchpoint condition
12113 may then be set only on user-defined exceptions which have the
12114 same not-fully-qualified name (e.g. my_package.constraint_error).
12116 To avoid this unexcepted behavior, these standard exceptions are
12117 systematically prefixed by "standard". This means that "catch
12118 exception constraint_error" is rewritten into "catch exception
12119 standard.constraint_error".
12121 If an exception named contraint_error is defined in another package of
12122 the inferior program, then the only way to specify this exception as a
12123 breakpoint condition is to use its fully-qualified named:
12124 e.g. my_package.constraint_error. */
12126 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12128 if (strcmp (standard_exc [i], excep_string) == 0)
12130 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
12134 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
12137 /* Return the symtab_and_line that should be used to insert an exception
12138 catchpoint of the TYPE kind.
12140 EXCEP_STRING should contain the name of a specific exception that
12141 the catchpoint should catch, or NULL otherwise.
12143 ADDR_STRING returns the name of the function where the real
12144 breakpoint that implements the catchpoints is set, depending on the
12145 type of catchpoint we need to create. */
12147 static struct symtab_and_line
12148 ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
12149 char **addr_string, const struct breakpoint_ops **ops)
12151 const char *sym_name;
12152 struct symbol *sym;
12154 /* First, find out which exception support info to use. */
12155 ada_exception_support_info_sniffer ();
12157 /* Then lookup the function on which we will break in order to catch
12158 the Ada exceptions requested by the user. */
12159 sym_name = ada_exception_sym_name (ex);
12160 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12162 /* We can assume that SYM is not NULL at this stage. If the symbol
12163 did not exist, ada_exception_support_info_sniffer would have
12164 raised an exception.
12166 Also, ada_exception_support_info_sniffer should have already
12167 verified that SYM is a function symbol. */
12168 gdb_assert (sym != NULL);
12169 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
12171 /* Set ADDR_STRING. */
12172 *addr_string = xstrdup (sym_name);
12175 *ops = ada_exception_breakpoint_ops (ex);
12177 return find_function_start_sal (sym, 1);
12180 /* Create an Ada exception catchpoint.
12182 EX_KIND is the kind of exception catchpoint to be created.
12184 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12185 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12186 of the exception to which this catchpoint applies. When not NULL,
12187 the string must be allocated on the heap, and its deallocation
12188 is no longer the responsibility of the caller.
12190 COND_STRING, if not NULL, is the catchpoint condition. This string
12191 must be allocated on the heap, and its deallocation is no longer
12192 the responsibility of the caller.
12194 TEMPFLAG, if nonzero, means that the underlying breakpoint
12195 should be temporary.
12197 FROM_TTY is the usual argument passed to all commands implementations. */
12200 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
12201 enum ada_exception_catchpoint_kind ex_kind,
12202 char *excep_string,
12208 struct ada_catchpoint *c;
12209 char *addr_string = NULL;
12210 const struct breakpoint_ops *ops = NULL;
12211 struct symtab_and_line sal
12212 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
12214 c = XNEW (struct ada_catchpoint);
12215 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
12216 ops, tempflag, disabled, from_tty);
12217 c->excep_string = excep_string;
12218 create_excep_cond_exprs (c);
12219 if (cond_string != NULL)
12220 set_breakpoint_condition (&c->base, cond_string, from_tty);
12221 install_breakpoint (0, &c->base, 1);
12224 /* Implement the "catch exception" command. */
12227 catch_ada_exception_command (char *arg, int from_tty,
12228 struct cmd_list_element *command)
12230 struct gdbarch *gdbarch = get_current_arch ();
12232 enum ada_exception_catchpoint_kind ex_kind;
12233 char *excep_string = NULL;
12234 char *cond_string = NULL;
12236 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12240 catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
12242 create_ada_exception_catchpoint (gdbarch, ex_kind,
12243 excep_string, cond_string,
12244 tempflag, 1 /* enabled */,
12248 /* Split the arguments specified in a "catch assert" command.
12250 ARGS contains the command's arguments (or the empty string if
12251 no arguments were passed).
12253 If ARGS contains a condition, set COND_STRING to that condition
12254 (the memory needs to be deallocated after use). */
12257 catch_ada_assert_command_split (char *args, char **cond_string)
12259 args = skip_spaces (args);
12261 /* Check whether a condition was provided. */
12262 if (strncmp (args, "if", 2) == 0
12263 && (isspace (args[2]) || args[2] == '\0'))
12266 args = skip_spaces (args);
12267 if (args[0] == '\0')
12268 error (_("condition missing after `if' keyword"));
12269 *cond_string = xstrdup (args);
12272 /* Otherwise, there should be no other argument at the end of
12274 else if (args[0] != '\0')
12275 error (_("Junk at end of arguments."));
12278 /* Implement the "catch assert" command. */
12281 catch_assert_command (char *arg, int from_tty,
12282 struct cmd_list_element *command)
12284 struct gdbarch *gdbarch = get_current_arch ();
12286 char *cond_string = NULL;
12288 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12292 catch_ada_assert_command_split (arg, &cond_string);
12293 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
12295 tempflag, 1 /* enabled */,
12299 /* Return non-zero if the symbol SYM is an Ada exception object. */
12302 ada_is_exception_sym (struct symbol *sym)
12304 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
12306 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12307 && SYMBOL_CLASS (sym) != LOC_BLOCK
12308 && SYMBOL_CLASS (sym) != LOC_CONST
12309 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12310 && type_name != NULL && strcmp (type_name, "exception") == 0);
12313 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12314 Ada exception object. This matches all exceptions except the ones
12315 defined by the Ada language. */
12318 ada_is_non_standard_exception_sym (struct symbol *sym)
12322 if (!ada_is_exception_sym (sym))
12325 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12326 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
12327 return 0; /* A standard exception. */
12329 /* Numeric_Error is also a standard exception, so exclude it.
12330 See the STANDARD_EXC description for more details as to why
12331 this exception is not listed in that array. */
12332 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
12338 /* A helper function for qsort, comparing two struct ada_exc_info
12341 The comparison is determined first by exception name, and then
12342 by exception address. */
12345 compare_ada_exception_info (const void *a, const void *b)
12347 const struct ada_exc_info *exc_a = (struct ada_exc_info *) a;
12348 const struct ada_exc_info *exc_b = (struct ada_exc_info *) b;
12351 result = strcmp (exc_a->name, exc_b->name);
12355 if (exc_a->addr < exc_b->addr)
12357 if (exc_a->addr > exc_b->addr)
12363 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12364 routine, but keeping the first SKIP elements untouched.
12366 All duplicates are also removed. */
12369 sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info) **exceptions,
12372 struct ada_exc_info *to_sort
12373 = VEC_address (ada_exc_info, *exceptions) + skip;
12375 = VEC_length (ada_exc_info, *exceptions) - skip;
12378 qsort (to_sort, to_sort_len, sizeof (struct ada_exc_info),
12379 compare_ada_exception_info);
12381 for (i = 1, j = 1; i < to_sort_len; i++)
12382 if (compare_ada_exception_info (&to_sort[i], &to_sort[j - 1]) != 0)
12383 to_sort[j++] = to_sort[i];
12385 VEC_truncate(ada_exc_info, *exceptions, skip + to_sort_len);
12388 /* A function intended as the "name_matcher" callback in the struct
12389 quick_symbol_functions' expand_symtabs_matching method.
12391 SEARCH_NAME is the symbol's search name.
12393 If USER_DATA is not NULL, it is a pointer to a regext_t object
12394 used to match the symbol (by natural name). Otherwise, when USER_DATA
12395 is null, no filtering is performed, and all symbols are a positive
12399 ada_exc_search_name_matches (const char *search_name, void *user_data)
12401 regex_t *preg = user_data;
12406 /* In Ada, the symbol "search name" is a linkage name, whereas
12407 the regular expression used to do the matching refers to
12408 the natural name. So match against the decoded name. */
12409 return (regexec (preg, ada_decode (search_name), 0, NULL, 0) == 0);
12412 /* Add all exceptions defined by the Ada standard whose name match
12413 a regular expression.
12415 If PREG is not NULL, then this regexp_t object is used to
12416 perform the symbol name matching. Otherwise, no name-based
12417 filtering is performed.
12419 EXCEPTIONS is a vector of exceptions to which matching exceptions
12423 ada_add_standard_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12427 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12430 || regexec (preg, standard_exc[i], 0, NULL, 0) == 0)
12432 struct bound_minimal_symbol msymbol
12433 = ada_lookup_simple_minsym (standard_exc[i]);
12435 if (msymbol.minsym != NULL)
12437 struct ada_exc_info info
12438 = {standard_exc[i], SYMBOL_VALUE_ADDRESS (msymbol.minsym)};
12440 VEC_safe_push (ada_exc_info, *exceptions, &info);
12446 /* Add all Ada exceptions defined locally and accessible from the given
12449 If PREG is not NULL, then this regexp_t object is used to
12450 perform the symbol name matching. Otherwise, no name-based
12451 filtering is performed.
12453 EXCEPTIONS is a vector of exceptions to which matching exceptions
12457 ada_add_exceptions_from_frame (regex_t *preg, struct frame_info *frame,
12458 VEC(ada_exc_info) **exceptions)
12460 struct block *block = get_frame_block (frame, 0);
12464 struct block_iterator iter;
12465 struct symbol *sym;
12467 ALL_BLOCK_SYMBOLS (block, iter, sym)
12469 switch (SYMBOL_CLASS (sym))
12476 if (ada_is_exception_sym (sym))
12478 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
12479 SYMBOL_VALUE_ADDRESS (sym)};
12481 VEC_safe_push (ada_exc_info, *exceptions, &info);
12485 if (BLOCK_FUNCTION (block) != NULL)
12487 block = BLOCK_SUPERBLOCK (block);
12491 /* Add all exceptions defined globally whose name name match
12492 a regular expression, excluding standard exceptions.
12494 The reason we exclude standard exceptions is that they need
12495 to be handled separately: Standard exceptions are defined inside
12496 a runtime unit which is normally not compiled with debugging info,
12497 and thus usually do not show up in our symbol search. However,
12498 if the unit was in fact built with debugging info, we need to
12499 exclude them because they would duplicate the entry we found
12500 during the special loop that specifically searches for those
12501 standard exceptions.
12503 If PREG is not NULL, then this regexp_t object is used to
12504 perform the symbol name matching. Otherwise, no name-based
12505 filtering is performed.
12507 EXCEPTIONS is a vector of exceptions to which matching exceptions
12511 ada_add_global_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
12513 struct objfile *objfile;
12516 expand_symtabs_matching (NULL, ada_exc_search_name_matches,
12517 VARIABLES_DOMAIN, preg);
12519 ALL_PRIMARY_SYMTABS (objfile, s)
12521 struct blockvector *bv = BLOCKVECTOR (s);
12524 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
12526 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
12527 struct block_iterator iter;
12528 struct symbol *sym;
12530 ALL_BLOCK_SYMBOLS (b, iter, sym)
12531 if (ada_is_non_standard_exception_sym (sym)
12533 || regexec (preg, SYMBOL_NATURAL_NAME (sym),
12536 struct ada_exc_info info
12537 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
12539 VEC_safe_push (ada_exc_info, *exceptions, &info);
12545 /* Implements ada_exceptions_list with the regular expression passed
12546 as a regex_t, rather than a string.
12548 If not NULL, PREG is used to filter out exceptions whose names
12549 do not match. Otherwise, all exceptions are listed. */
12551 static VEC(ada_exc_info) *
12552 ada_exceptions_list_1 (regex_t *preg)
12554 VEC(ada_exc_info) *result = NULL;
12555 struct cleanup *old_chain
12556 = make_cleanup (VEC_cleanup (ada_exc_info), &result);
12559 /* First, list the known standard exceptions. These exceptions
12560 need to be handled separately, as they are usually defined in
12561 runtime units that have been compiled without debugging info. */
12563 ada_add_standard_exceptions (preg, &result);
12565 /* Next, find all exceptions whose scope is local and accessible
12566 from the currently selected frame. */
12568 if (has_stack_frames ())
12570 prev_len = VEC_length (ada_exc_info, result);
12571 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
12573 if (VEC_length (ada_exc_info, result) > prev_len)
12574 sort_remove_dups_ada_exceptions_list (&result, prev_len);
12577 /* Add all exceptions whose scope is global. */
12579 prev_len = VEC_length (ada_exc_info, result);
12580 ada_add_global_exceptions (preg, &result);
12581 if (VEC_length (ada_exc_info, result) > prev_len)
12582 sort_remove_dups_ada_exceptions_list (&result, prev_len);
12584 discard_cleanups (old_chain);
12588 /* Return a vector of ada_exc_info.
12590 If REGEXP is NULL, all exceptions are included in the result.
12591 Otherwise, it should contain a valid regular expression,
12592 and only the exceptions whose names match that regular expression
12593 are included in the result.
12595 The exceptions are sorted in the following order:
12596 - Standard exceptions (defined by the Ada language), in
12597 alphabetical order;
12598 - Exceptions only visible from the current frame, in
12599 alphabetical order;
12600 - Exceptions whose scope is global, in alphabetical order. */
12602 VEC(ada_exc_info) *
12603 ada_exceptions_list (const char *regexp)
12605 VEC(ada_exc_info) *result = NULL;
12606 struct cleanup *old_chain = NULL;
12609 if (regexp != NULL)
12610 old_chain = compile_rx_or_error (®, regexp,
12611 _("invalid regular expression"));
12613 result = ada_exceptions_list_1 (regexp != NULL ? ® : NULL);
12615 if (old_chain != NULL)
12616 do_cleanups (old_chain);
12620 /* Implement the "info exceptions" command. */
12623 info_exceptions_command (char *regexp, int from_tty)
12625 VEC(ada_exc_info) *exceptions;
12626 struct cleanup *cleanup;
12627 struct gdbarch *gdbarch = get_current_arch ();
12629 struct ada_exc_info *info;
12631 exceptions = ada_exceptions_list (regexp);
12632 cleanup = make_cleanup (VEC_cleanup (ada_exc_info), &exceptions);
12634 if (regexp != NULL)
12636 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
12638 printf_filtered (_("All defined Ada exceptions:\n"));
12640 for (ix = 0; VEC_iterate(ada_exc_info, exceptions, ix, info); ix++)
12641 printf_filtered ("%s: %s\n", info->name, paddress (gdbarch, info->addr));
12643 do_cleanups (cleanup);
12647 /* Information about operators given special treatment in functions
12649 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
12651 #define ADA_OPERATORS \
12652 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
12653 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
12654 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
12655 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
12656 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
12657 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
12658 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
12659 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
12660 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
12661 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
12662 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
12663 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
12664 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
12665 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
12666 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
12667 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
12668 OP_DEFN (OP_OTHERS, 1, 1, 0) \
12669 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
12670 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
12673 ada_operator_length (const struct expression *exp, int pc, int *oplenp,
12676 switch (exp->elts[pc - 1].opcode)
12679 operator_length_standard (exp, pc, oplenp, argsp);
12682 #define OP_DEFN(op, len, args, binop) \
12683 case op: *oplenp = len; *argsp = args; break;
12689 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
12694 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
12699 /* Implementation of the exp_descriptor method operator_check. */
12702 ada_operator_check (struct expression *exp, int pos,
12703 int (*objfile_func) (struct objfile *objfile, void *data),
12706 const union exp_element *const elts = exp->elts;
12707 struct type *type = NULL;
12709 switch (elts[pos].opcode)
12711 case UNOP_IN_RANGE:
12713 type = elts[pos + 1].type;
12717 return operator_check_standard (exp, pos, objfile_func, data);
12720 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
12722 if (type && TYPE_OBJFILE (type)
12723 && (*objfile_func) (TYPE_OBJFILE (type), data))
12730 ada_op_name (enum exp_opcode opcode)
12735 return op_name_standard (opcode);
12737 #define OP_DEFN(op, len, args, binop) case op: return #op;
12742 return "OP_AGGREGATE";
12744 return "OP_CHOICES";
12750 /* As for operator_length, but assumes PC is pointing at the first
12751 element of the operator, and gives meaningful results only for the
12752 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
12755 ada_forward_operator_length (struct expression *exp, int pc,
12756 int *oplenp, int *argsp)
12758 switch (exp->elts[pc].opcode)
12761 *oplenp = *argsp = 0;
12764 #define OP_DEFN(op, len, args, binop) \
12765 case op: *oplenp = len; *argsp = args; break;
12771 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
12776 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
12782 int len = longest_to_int (exp->elts[pc + 1].longconst);
12784 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
12792 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
12794 enum exp_opcode op = exp->elts[elt].opcode;
12799 ada_forward_operator_length (exp, elt, &oplen, &nargs);
12803 /* Ada attributes ('Foo). */
12806 case OP_ATR_LENGTH:
12810 case OP_ATR_MODULUS:
12817 case UNOP_IN_RANGE:
12819 /* XXX: gdb_sprint_host_address, type_sprint */
12820 fprintf_filtered (stream, _("Type @"));
12821 gdb_print_host_address (exp->elts[pc + 1].type, stream);
12822 fprintf_filtered (stream, " (");
12823 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
12824 fprintf_filtered (stream, ")");
12826 case BINOP_IN_BOUNDS:
12827 fprintf_filtered (stream, " (%d)",
12828 longest_to_int (exp->elts[pc + 2].longconst));
12830 case TERNOP_IN_RANGE:
12835 case OP_DISCRETE_RANGE:
12836 case OP_POSITIONAL:
12843 char *name = &exp->elts[elt + 2].string;
12844 int len = longest_to_int (exp->elts[elt + 1].longconst);
12846 fprintf_filtered (stream, "Text: `%.*s'", len, name);
12851 return dump_subexp_body_standard (exp, stream, elt);
12855 for (i = 0; i < nargs; i += 1)
12856 elt = dump_subexp (exp, stream, elt);
12861 /* The Ada extension of print_subexp (q.v.). */
12864 ada_print_subexp (struct expression *exp, int *pos,
12865 struct ui_file *stream, enum precedence prec)
12867 int oplen, nargs, i;
12869 enum exp_opcode op = exp->elts[pc].opcode;
12871 ada_forward_operator_length (exp, pc, &oplen, &nargs);
12878 print_subexp_standard (exp, pos, stream, prec);
12882 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
12885 case BINOP_IN_BOUNDS:
12886 /* XXX: sprint_subexp */
12887 print_subexp (exp, pos, stream, PREC_SUFFIX);
12888 fputs_filtered (" in ", stream);
12889 print_subexp (exp, pos, stream, PREC_SUFFIX);
12890 fputs_filtered ("'range", stream);
12891 if (exp->elts[pc + 1].longconst > 1)
12892 fprintf_filtered (stream, "(%ld)",
12893 (long) exp->elts[pc + 1].longconst);
12896 case TERNOP_IN_RANGE:
12897 if (prec >= PREC_EQUAL)
12898 fputs_filtered ("(", stream);
12899 /* XXX: sprint_subexp */
12900 print_subexp (exp, pos, stream, PREC_SUFFIX);
12901 fputs_filtered (" in ", stream);
12902 print_subexp (exp, pos, stream, PREC_EQUAL);
12903 fputs_filtered (" .. ", stream);
12904 print_subexp (exp, pos, stream, PREC_EQUAL);
12905 if (prec >= PREC_EQUAL)
12906 fputs_filtered (")", stream);
12911 case OP_ATR_LENGTH:
12915 case OP_ATR_MODULUS:
12920 if (exp->elts[*pos].opcode == OP_TYPE)
12922 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
12923 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
12924 &type_print_raw_options);
12928 print_subexp (exp, pos, stream, PREC_SUFFIX);
12929 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
12934 for (tem = 1; tem < nargs; tem += 1)
12936 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
12937 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
12939 fputs_filtered (")", stream);
12944 type_print (exp->elts[pc + 1].type, "", stream, 0);
12945 fputs_filtered ("'(", stream);
12946 print_subexp (exp, pos, stream, PREC_PREFIX);
12947 fputs_filtered (")", stream);
12950 case UNOP_IN_RANGE:
12951 /* XXX: sprint_subexp */
12952 print_subexp (exp, pos, stream, PREC_SUFFIX);
12953 fputs_filtered (" in ", stream);
12954 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
12955 &type_print_raw_options);
12958 case OP_DISCRETE_RANGE:
12959 print_subexp (exp, pos, stream, PREC_SUFFIX);
12960 fputs_filtered ("..", stream);
12961 print_subexp (exp, pos, stream, PREC_SUFFIX);
12965 fputs_filtered ("others => ", stream);
12966 print_subexp (exp, pos, stream, PREC_SUFFIX);
12970 for (i = 0; i < nargs-1; i += 1)
12973 fputs_filtered ("|", stream);
12974 print_subexp (exp, pos, stream, PREC_SUFFIX);
12976 fputs_filtered (" => ", stream);
12977 print_subexp (exp, pos, stream, PREC_SUFFIX);
12980 case OP_POSITIONAL:
12981 print_subexp (exp, pos, stream, PREC_SUFFIX);
12985 fputs_filtered ("(", stream);
12986 for (i = 0; i < nargs; i += 1)
12989 fputs_filtered (", ", stream);
12990 print_subexp (exp, pos, stream, PREC_SUFFIX);
12992 fputs_filtered (")", stream);
12997 /* Table mapping opcodes into strings for printing operators
12998 and precedences of the operators. */
13000 static const struct op_print ada_op_print_tab[] = {
13001 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13002 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13003 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13004 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13005 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13006 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13007 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13008 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13009 {"<=", BINOP_LEQ, PREC_ORDER, 0},
13010 {">=", BINOP_GEQ, PREC_ORDER, 0},
13011 {">", BINOP_GTR, PREC_ORDER, 0},
13012 {"<", BINOP_LESS, PREC_ORDER, 0},
13013 {">>", BINOP_RSH, PREC_SHIFT, 0},
13014 {"<<", BINOP_LSH, PREC_SHIFT, 0},
13015 {"+", BINOP_ADD, PREC_ADD, 0},
13016 {"-", BINOP_SUB, PREC_ADD, 0},
13017 {"&", BINOP_CONCAT, PREC_ADD, 0},
13018 {"*", BINOP_MUL, PREC_MUL, 0},
13019 {"/", BINOP_DIV, PREC_MUL, 0},
13020 {"rem", BINOP_REM, PREC_MUL, 0},
13021 {"mod", BINOP_MOD, PREC_MUL, 0},
13022 {"**", BINOP_EXP, PREC_REPEAT, 0},
13023 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13024 {"-", UNOP_NEG, PREC_PREFIX, 0},
13025 {"+", UNOP_PLUS, PREC_PREFIX, 0},
13026 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13027 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13028 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
13029 {".all", UNOP_IND, PREC_SUFFIX, 1},
13030 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13031 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
13035 enum ada_primitive_types {
13036 ada_primitive_type_int,
13037 ada_primitive_type_long,
13038 ada_primitive_type_short,
13039 ada_primitive_type_char,
13040 ada_primitive_type_float,
13041 ada_primitive_type_double,
13042 ada_primitive_type_void,
13043 ada_primitive_type_long_long,
13044 ada_primitive_type_long_double,
13045 ada_primitive_type_natural,
13046 ada_primitive_type_positive,
13047 ada_primitive_type_system_address,
13048 nr_ada_primitive_types
13052 ada_language_arch_info (struct gdbarch *gdbarch,
13053 struct language_arch_info *lai)
13055 const struct builtin_type *builtin = builtin_type (gdbarch);
13057 lai->primitive_type_vector
13058 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
13061 lai->primitive_type_vector [ada_primitive_type_int]
13062 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13064 lai->primitive_type_vector [ada_primitive_type_long]
13065 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13066 0, "long_integer");
13067 lai->primitive_type_vector [ada_primitive_type_short]
13068 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13069 0, "short_integer");
13070 lai->string_char_type
13071 = lai->primitive_type_vector [ada_primitive_type_char]
13072 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
13073 lai->primitive_type_vector [ada_primitive_type_float]
13074 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13076 lai->primitive_type_vector [ada_primitive_type_double]
13077 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13078 "long_float", NULL);
13079 lai->primitive_type_vector [ada_primitive_type_long_long]
13080 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13081 0, "long_long_integer");
13082 lai->primitive_type_vector [ada_primitive_type_long_double]
13083 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13084 "long_long_float", NULL);
13085 lai->primitive_type_vector [ada_primitive_type_natural]
13086 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13088 lai->primitive_type_vector [ada_primitive_type_positive]
13089 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13091 lai->primitive_type_vector [ada_primitive_type_void]
13092 = builtin->builtin_void;
13094 lai->primitive_type_vector [ada_primitive_type_system_address]
13095 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
13096 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
13097 = "system__address";
13099 lai->bool_type_symbol = NULL;
13100 lai->bool_type_default = builtin->builtin_bool;
13103 /* Language vector */
13105 /* Not really used, but needed in the ada_language_defn. */
13108 emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
13110 ada_emit_char (c, type, stream, quoter, 1);
13116 warnings_issued = 0;
13117 return ada_parse ();
13120 static const struct exp_descriptor ada_exp_descriptor = {
13122 ada_operator_length,
13123 ada_operator_check,
13125 ada_dump_subexp_body,
13126 ada_evaluate_subexp
13129 /* Implement the "la_get_symbol_name_cmp" language_defn method
13132 static symbol_name_cmp_ftype
13133 ada_get_symbol_name_cmp (const char *lookup_name)
13135 if (should_use_wild_match (lookup_name))
13138 return compare_names;
13141 /* Implement the "la_read_var_value" language_defn method for Ada. */
13143 static struct value *
13144 ada_read_var_value (struct symbol *var, struct frame_info *frame)
13146 struct block *frame_block = NULL;
13147 struct symbol *renaming_sym = NULL;
13149 /* The only case where default_read_var_value is not sufficient
13150 is when VAR is a renaming... */
13152 frame_block = get_frame_block (frame, NULL);
13154 renaming_sym = ada_find_renaming_symbol (var, frame_block);
13155 if (renaming_sym != NULL)
13156 return ada_read_renaming_var_value (renaming_sym, frame_block);
13158 /* This is a typical case where we expect the default_read_var_value
13159 function to work. */
13160 return default_read_var_value (var, frame);
13163 const struct language_defn ada_language_defn = {
13164 "ada", /* Language name */
13168 case_sensitive_on, /* Yes, Ada is case-insensitive, but
13169 that's not quite what this means. */
13171 macro_expansion_no,
13172 &ada_exp_descriptor,
13176 ada_printchar, /* Print a character constant */
13177 ada_printstr, /* Function to print string constant */
13178 emit_char, /* Function to print single char (not used) */
13179 ada_print_type, /* Print a type using appropriate syntax */
13180 ada_print_typedef, /* Print a typedef using appropriate syntax */
13181 ada_val_print, /* Print a value using appropriate syntax */
13182 ada_value_print, /* Print a top-level value */
13183 ada_read_var_value, /* la_read_var_value */
13184 NULL, /* Language specific skip_trampoline */
13185 NULL, /* name_of_this */
13186 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
13187 basic_lookup_transparent_type, /* lookup_transparent_type */
13188 ada_la_decode, /* Language specific symbol demangler */
13189 NULL, /* Language specific
13190 class_name_from_physname */
13191 ada_op_print_tab, /* expression operators for printing */
13192 0, /* c-style arrays */
13193 1, /* String lower bound */
13194 ada_get_gdb_completer_word_break_characters,
13195 ada_make_symbol_completion_list,
13196 ada_language_arch_info,
13197 ada_print_array_index,
13198 default_pass_by_reference,
13200 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
13201 ada_iterate_over_symbols,
13206 /* Provide a prototype to silence -Wmissing-prototypes. */
13207 extern initialize_file_ftype _initialize_ada_language;
13209 /* Command-list for the "set/show ada" prefix command. */
13210 static struct cmd_list_element *set_ada_list;
13211 static struct cmd_list_element *show_ada_list;
13213 /* Implement the "set ada" prefix command. */
13216 set_ada_command (char *arg, int from_tty)
13218 printf_unfiltered (_(\
13219 "\"set ada\" must be followed by the name of a setting.\n"));
13220 help_list (set_ada_list, "set ada ", -1, gdb_stdout);
13223 /* Implement the "show ada" prefix command. */
13226 show_ada_command (char *args, int from_tty)
13228 cmd_show_list (show_ada_list, from_tty, "");
13232 initialize_ada_catchpoint_ops (void)
13234 struct breakpoint_ops *ops;
13236 initialize_breakpoint_ops ();
13238 ops = &catch_exception_breakpoint_ops;
13239 *ops = bkpt_breakpoint_ops;
13240 ops->dtor = dtor_catch_exception;
13241 ops->allocate_location = allocate_location_catch_exception;
13242 ops->re_set = re_set_catch_exception;
13243 ops->check_status = check_status_catch_exception;
13244 ops->print_it = print_it_catch_exception;
13245 ops->print_one = print_one_catch_exception;
13246 ops->print_mention = print_mention_catch_exception;
13247 ops->print_recreate = print_recreate_catch_exception;
13249 ops = &catch_exception_unhandled_breakpoint_ops;
13250 *ops = bkpt_breakpoint_ops;
13251 ops->dtor = dtor_catch_exception_unhandled;
13252 ops->allocate_location = allocate_location_catch_exception_unhandled;
13253 ops->re_set = re_set_catch_exception_unhandled;
13254 ops->check_status = check_status_catch_exception_unhandled;
13255 ops->print_it = print_it_catch_exception_unhandled;
13256 ops->print_one = print_one_catch_exception_unhandled;
13257 ops->print_mention = print_mention_catch_exception_unhandled;
13258 ops->print_recreate = print_recreate_catch_exception_unhandled;
13260 ops = &catch_assert_breakpoint_ops;
13261 *ops = bkpt_breakpoint_ops;
13262 ops->dtor = dtor_catch_assert;
13263 ops->allocate_location = allocate_location_catch_assert;
13264 ops->re_set = re_set_catch_assert;
13265 ops->check_status = check_status_catch_assert;
13266 ops->print_it = print_it_catch_assert;
13267 ops->print_one = print_one_catch_assert;
13268 ops->print_mention = print_mention_catch_assert;
13269 ops->print_recreate = print_recreate_catch_assert;
13273 _initialize_ada_language (void)
13275 add_language (&ada_language_defn);
13277 initialize_ada_catchpoint_ops ();
13279 add_prefix_cmd ("ada", no_class, set_ada_command,
13280 _("Prefix command for changing Ada-specfic settings"),
13281 &set_ada_list, "set ada ", 0, &setlist);
13283 add_prefix_cmd ("ada", no_class, show_ada_command,
13284 _("Generic command for showing Ada-specific settings."),
13285 &show_ada_list, "show ada ", 0, &showlist);
13287 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13288 &trust_pad_over_xvs, _("\
13289 Enable or disable an optimization trusting PAD types over XVS types"), _("\
13290 Show whether an optimization trusting PAD types over XVS types is activated"),
13292 This is related to the encoding used by the GNAT compiler. The debugger\n\
13293 should normally trust the contents of PAD types, but certain older versions\n\
13294 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13295 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13296 work around this bug. It is always safe to turn this option \"off\", but\n\
13297 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13298 this option to \"off\" unless necessary."),
13299 NULL, NULL, &set_ada_list, &show_ada_list);
13301 add_catch_command ("exception", _("\
13302 Catch Ada exceptions, when raised.\n\
13303 With an argument, catch only exceptions with the given name."),
13304 catch_ada_exception_command,
13308 add_catch_command ("assert", _("\
13309 Catch failed Ada assertions, when raised.\n\
13310 With an argument, catch only exceptions with the given name."),
13311 catch_assert_command,
13316 varsize_limit = 65536;
13318 add_info ("exceptions", info_exceptions_command,
13320 List all Ada exception names.\n\
13321 If a regular expression is passed as an argument, only those matching\n\
13322 the regular expression are listed."));
13324 obstack_init (&symbol_list_obstack);
13326 decoded_names_store = htab_create_alloc
13327 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
13328 NULL, xcalloc, xfree);
13330 /* Setup per-inferior data. */
13331 observer_attach_inferior_exit (ada_inferior_exit);
13333 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);