1 /* Ada language support routines for GDB, the GNU debugger. Copyright (C)
3 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005, 2007
4 Free Software Foundation, Inc.
6 This file is part of GDB.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
24 #include "gdb_string.h"
28 #include "gdb_regex.h"
33 #include "expression.h"
34 #include "parser-defs.h"
40 #include "breakpoint.h"
43 #include "gdb_obstack.h"
45 #include "completer.h"
52 #include "dictionary.h"
53 #include "exceptions.h"
60 #ifndef ADA_RETAIN_DOTS
61 #define ADA_RETAIN_DOTS 0
64 /* Define whether or not the C operator '/' truncates towards zero for
65 differently signed operands (truncation direction is undefined in C).
66 Copied from valarith.c. */
68 #ifndef TRUNCATION_TOWARDS_ZERO
69 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
72 static void extract_string (CORE_ADDR addr, char *buf);
74 static void modify_general_field (char *, LONGEST, int, int);
76 static struct type *desc_base_type (struct type *);
78 static struct type *desc_bounds_type (struct type *);
80 static struct value *desc_bounds (struct value *);
82 static int fat_pntr_bounds_bitpos (struct type *);
84 static int fat_pntr_bounds_bitsize (struct type *);
86 static struct type *desc_data_type (struct type *);
88 static struct value *desc_data (struct value *);
90 static int fat_pntr_data_bitpos (struct type *);
92 static int fat_pntr_data_bitsize (struct type *);
94 static struct value *desc_one_bound (struct value *, int, int);
96 static int desc_bound_bitpos (struct type *, int, int);
98 static int desc_bound_bitsize (struct type *, int, int);
100 static struct type *desc_index_type (struct type *, int);
102 static int desc_arity (struct type *);
104 static int ada_type_match (struct type *, struct type *, int);
106 static int ada_args_match (struct symbol *, struct value **, int);
108 static struct value *ensure_lval (struct value *, CORE_ADDR *);
110 static struct value *convert_actual (struct value *, struct type *,
113 static struct value *make_array_descriptor (struct type *, struct value *,
116 static void ada_add_block_symbols (struct obstack *,
117 struct block *, const char *,
118 domain_enum, struct objfile *, int);
120 static int is_nonfunction (struct ada_symbol_info *, int);
122 static void add_defn_to_vec (struct obstack *, struct symbol *,
125 static int num_defns_collected (struct obstack *);
127 static struct ada_symbol_info *defns_collected (struct obstack *, int);
129 static struct partial_symbol *ada_lookup_partial_symbol (struct partial_symtab
130 *, const char *, int,
133 static struct symtab *symtab_for_sym (struct symbol *);
135 static struct value *resolve_subexp (struct expression **, int *, int,
138 static void replace_operator_with_call (struct expression **, int, int, int,
139 struct symbol *, struct block *);
141 static int possible_user_operator_p (enum exp_opcode, struct value **);
143 static char *ada_op_name (enum exp_opcode);
145 static const char *ada_decoded_op_name (enum exp_opcode);
147 static int numeric_type_p (struct type *);
149 static int integer_type_p (struct type *);
151 static int scalar_type_p (struct type *);
153 static int discrete_type_p (struct type *);
155 static enum ada_renaming_category parse_old_style_renaming (struct type *,
160 static struct symbol *find_old_style_renaming_symbol (const char *,
163 static struct type *ada_lookup_struct_elt_type (struct type *, char *,
166 static struct value *evaluate_subexp (struct type *, struct expression *,
169 static struct value *evaluate_subexp_type (struct expression *, int *);
171 static int is_dynamic_field (struct type *, int);
173 static struct type *to_fixed_variant_branch_type (struct type *,
175 CORE_ADDR, struct value *);
177 static struct type *to_fixed_array_type (struct type *, struct value *, int);
179 static struct type *to_fixed_range_type (char *, struct value *,
182 static struct type *to_static_fixed_type (struct type *);
183 static struct type *static_unwrap_type (struct type *type);
185 static struct value *unwrap_value (struct value *);
187 static struct type *packed_array_type (struct type *, long *);
189 static struct type *decode_packed_array_type (struct type *);
191 static struct value *decode_packed_array (struct value *);
193 static struct value *value_subscript_packed (struct value *, int,
196 static void move_bits (gdb_byte *, int, const gdb_byte *, int, int);
198 static struct value *coerce_unspec_val_to_type (struct value *,
201 static struct value *get_var_value (char *, char *);
203 static int lesseq_defined_than (struct symbol *, struct symbol *);
205 static int equiv_types (struct type *, struct type *);
207 static int is_name_suffix (const char *);
209 static int wild_match (const char *, int, const char *);
211 static struct value *ada_coerce_ref (struct value *);
213 static LONGEST pos_atr (struct value *);
215 static struct value *value_pos_atr (struct value *);
217 static struct value *value_val_atr (struct type *, struct value *);
219 static struct symbol *standard_lookup (const char *, const struct block *,
222 static struct value *ada_search_struct_field (char *, struct value *, int,
225 static struct value *ada_value_primitive_field (struct value *, int, int,
228 static int find_struct_field (char *, struct type *, int,
229 struct type **, int *, int *, int *, int *);
231 static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
234 static struct value *ada_to_fixed_value (struct value *);
236 static int ada_resolve_function (struct ada_symbol_info *, int,
237 struct value **, int, const char *,
240 static struct value *ada_coerce_to_simple_array (struct value *);
242 static int ada_is_direct_array_type (struct type *);
244 static void ada_language_arch_info (struct gdbarch *,
245 struct language_arch_info *);
247 static void check_size (const struct type *);
249 static struct value *ada_index_struct_field (int, struct value *, int,
252 static struct value *assign_aggregate (struct value *, struct value *,
253 struct expression *, int *, enum noside);
255 static void aggregate_assign_from_choices (struct value *, struct value *,
257 int *, LONGEST *, int *,
258 int, LONGEST, LONGEST);
260 static void aggregate_assign_positional (struct value *, struct value *,
262 int *, LONGEST *, int *, int,
266 static void aggregate_assign_others (struct value *, struct value *,
268 int *, LONGEST *, int, LONGEST, LONGEST);
271 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
274 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
277 static void ada_forward_operator_length (struct expression *, int, int *,
282 /* Maximum-sized dynamic type. */
283 static unsigned int varsize_limit;
285 /* FIXME: brobecker/2003-09-17: No longer a const because it is
286 returned by a function that does not return a const char *. */
287 static char *ada_completer_word_break_characters =
289 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
291 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
294 /* The name of the symbol to use to get the name of the main subprogram. */
295 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
296 = "__gnat_ada_main_program_name";
298 /* Limit on the number of warnings to raise per expression evaluation. */
299 static int warning_limit = 2;
301 /* Number of warning messages issued; reset to 0 by cleanups after
302 expression evaluation. */
303 static int warnings_issued = 0;
305 static const char *known_runtime_file_name_patterns[] = {
306 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
309 static const char *known_auxiliary_function_name_patterns[] = {
310 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
313 /* Space for allocating results of ada_lookup_symbol_list. */
314 static struct obstack symbol_list_obstack;
318 /* Given DECODED_NAME a string holding a symbol name in its
319 decoded form (ie using the Ada dotted notation), returns
320 its unqualified name. */
323 ada_unqualified_name (const char *decoded_name)
325 const char *result = strrchr (decoded_name, '.');
328 result++; /* Skip the dot... */
330 result = decoded_name;
335 /* Return a string starting with '<', followed by STR, and '>'.
336 The result is good until the next call. */
339 add_angle_brackets (const char *str)
341 static char *result = NULL;
344 result = (char *) xmalloc ((strlen (str) + 3) * sizeof (char));
346 sprintf (result, "<%s>", str);
351 ada_get_gdb_completer_word_break_characters (void)
353 return ada_completer_word_break_characters;
356 /* Print an array element index using the Ada syntax. */
359 ada_print_array_index (struct value *index_value, struct ui_file *stream,
360 int format, enum val_prettyprint pretty)
362 LA_VALUE_PRINT (index_value, stream, format, pretty);
363 fprintf_filtered (stream, " => ");
366 /* Read the string located at ADDR from the inferior and store the
370 extract_string (CORE_ADDR addr, char *buf)
374 /* Loop, reading one byte at a time, until we reach the '\000'
375 end-of-string marker. */
378 target_read_memory (addr + char_index * sizeof (char),
379 buf + char_index * sizeof (char), sizeof (char));
382 while (buf[char_index - 1] != '\000');
385 /* Assuming VECT points to an array of *SIZE objects of size
386 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
387 updating *SIZE as necessary and returning the (new) array. */
390 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
392 if (*size < min_size)
395 if (*size < min_size)
397 vect = xrealloc (vect, *size * element_size);
402 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
403 suffix of FIELD_NAME beginning "___". */
406 field_name_match (const char *field_name, const char *target)
408 int len = strlen (target);
410 (strncmp (field_name, target, len) == 0
411 && (field_name[len] == '\0'
412 || (strncmp (field_name + len, "___", 3) == 0
413 && strcmp (field_name + strlen (field_name) - 6,
418 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
419 FIELD_NAME, and return its index. This function also handles fields
420 whose name have ___ suffixes because the compiler sometimes alters
421 their name by adding such a suffix to represent fields with certain
422 constraints. If the field could not be found, return a negative
423 number if MAYBE_MISSING is set. Otherwise raise an error. */
426 ada_get_field_index (const struct type *type, const char *field_name,
430 for (fieldno = 0; fieldno < TYPE_NFIELDS (type); fieldno++)
431 if (field_name_match (TYPE_FIELD_NAME (type, fieldno), field_name))
435 error (_("Unable to find field %s in struct %s. Aborting"),
436 field_name, TYPE_NAME (type));
441 /* The length of the prefix of NAME prior to any "___" suffix. */
444 ada_name_prefix_len (const char *name)
450 const char *p = strstr (name, "___");
452 return strlen (name);
458 /* Return non-zero if SUFFIX is a suffix of STR.
459 Return zero if STR is null. */
462 is_suffix (const char *str, const char *suffix)
468 len2 = strlen (suffix);
469 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
472 /* Create a value of type TYPE whose contents come from VALADDR, if it
473 is non-null, and whose memory address (in the inferior) is
477 value_from_contents_and_address (struct type *type,
478 const gdb_byte *valaddr,
481 struct value *v = allocate_value (type);
483 set_value_lazy (v, 1);
485 memcpy (value_contents_raw (v), valaddr, TYPE_LENGTH (type));
486 VALUE_ADDRESS (v) = address;
488 VALUE_LVAL (v) = lval_memory;
492 /* The contents of value VAL, treated as a value of type TYPE. The
493 result is an lval in memory if VAL is. */
495 static struct value *
496 coerce_unspec_val_to_type (struct value *val, struct type *type)
498 type = ada_check_typedef (type);
499 if (value_type (val) == type)
503 struct value *result;
505 /* Make sure that the object size is not unreasonable before
506 trying to allocate some memory for it. */
509 result = allocate_value (type);
510 VALUE_LVAL (result) = VALUE_LVAL (val);
511 set_value_bitsize (result, value_bitsize (val));
512 set_value_bitpos (result, value_bitpos (val));
513 VALUE_ADDRESS (result) = VALUE_ADDRESS (val) + value_offset (val);
515 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
516 set_value_lazy (result, 1);
518 memcpy (value_contents_raw (result), value_contents (val),
524 static const gdb_byte *
525 cond_offset_host (const gdb_byte *valaddr, long offset)
530 return valaddr + offset;
534 cond_offset_target (CORE_ADDR address, long offset)
539 return address + offset;
542 /* Issue a warning (as for the definition of warning in utils.c, but
543 with exactly one argument rather than ...), unless the limit on the
544 number of warnings has passed during the evaluation of the current
547 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
548 provided by "complaint". */
549 static void lim_warning (const char *format, ...) ATTR_FORMAT (printf, 1, 2);
552 lim_warning (const char *format, ...)
555 va_start (args, format);
557 warnings_issued += 1;
558 if (warnings_issued <= warning_limit)
559 vwarning (format, args);
564 /* Issue an error if the size of an object of type T is unreasonable,
565 i.e. if it would be a bad idea to allocate a value of this type in
569 check_size (const struct type *type)
571 if (TYPE_LENGTH (type) > varsize_limit)
572 error (_("object size is larger than varsize-limit"));
576 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
577 gdbtypes.h, but some of the necessary definitions in that file
578 seem to have gone missing. */
580 /* Maximum value of a SIZE-byte signed integer type. */
582 max_of_size (int size)
584 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
585 return top_bit | (top_bit - 1);
588 /* Minimum value of a SIZE-byte signed integer type. */
590 min_of_size (int size)
592 return -max_of_size (size) - 1;
595 /* Maximum value of a SIZE-byte unsigned integer type. */
597 umax_of_size (int size)
599 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
600 return top_bit | (top_bit - 1);
603 /* Maximum value of integral type T, as a signed quantity. */
605 max_of_type (struct type *t)
607 if (TYPE_UNSIGNED (t))
608 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
610 return max_of_size (TYPE_LENGTH (t));
613 /* Minimum value of integral type T, as a signed quantity. */
615 min_of_type (struct type *t)
617 if (TYPE_UNSIGNED (t))
620 return min_of_size (TYPE_LENGTH (t));
623 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
625 discrete_type_high_bound (struct type *type)
627 switch (TYPE_CODE (type))
629 case TYPE_CODE_RANGE:
630 return TYPE_HIGH_BOUND (type);
632 return TYPE_FIELD_BITPOS (type, TYPE_NFIELDS (type) - 1);
637 return max_of_type (type);
639 error (_("Unexpected type in discrete_type_high_bound."));
643 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
645 discrete_type_low_bound (struct type *type)
647 switch (TYPE_CODE (type))
649 case TYPE_CODE_RANGE:
650 return TYPE_LOW_BOUND (type);
652 return TYPE_FIELD_BITPOS (type, 0);
657 return min_of_type (type);
659 error (_("Unexpected type in discrete_type_low_bound."));
663 /* The identity on non-range types. For range types, the underlying
664 non-range scalar type. */
667 base_type (struct type *type)
669 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
671 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
673 type = TYPE_TARGET_TYPE (type);
679 /* Language Selection */
681 /* If the main program is in Ada, return language_ada, otherwise return LANG
682 (the main program is in Ada iif the adainit symbol is found).
684 MAIN_PST is not used. */
687 ada_update_initial_language (enum language lang,
688 struct partial_symtab *main_pst)
690 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
691 (struct objfile *) NULL) != NULL)
697 /* If the main procedure is written in Ada, then return its name.
698 The result is good until the next call. Return NULL if the main
699 procedure doesn't appear to be in Ada. */
704 struct minimal_symbol *msym;
705 CORE_ADDR main_program_name_addr;
706 static char main_program_name[1024];
708 /* For Ada, the name of the main procedure is stored in a specific
709 string constant, generated by the binder. Look for that symbol,
710 extract its address, and then read that string. If we didn't find
711 that string, then most probably the main procedure is not written
713 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
717 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
718 if (main_program_name_addr == 0)
719 error (_("Invalid address for Ada main program name."));
721 extract_string (main_program_name_addr, main_program_name);
722 return main_program_name;
725 /* The main procedure doesn't seem to be in Ada. */
731 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
734 const struct ada_opname_map ada_opname_table[] = {
735 {"Oadd", "\"+\"", BINOP_ADD},
736 {"Osubtract", "\"-\"", BINOP_SUB},
737 {"Omultiply", "\"*\"", BINOP_MUL},
738 {"Odivide", "\"/\"", BINOP_DIV},
739 {"Omod", "\"mod\"", BINOP_MOD},
740 {"Orem", "\"rem\"", BINOP_REM},
741 {"Oexpon", "\"**\"", BINOP_EXP},
742 {"Olt", "\"<\"", BINOP_LESS},
743 {"Ole", "\"<=\"", BINOP_LEQ},
744 {"Ogt", "\">\"", BINOP_GTR},
745 {"Oge", "\">=\"", BINOP_GEQ},
746 {"Oeq", "\"=\"", BINOP_EQUAL},
747 {"One", "\"/=\"", BINOP_NOTEQUAL},
748 {"Oand", "\"and\"", BINOP_BITWISE_AND},
749 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
750 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
751 {"Oconcat", "\"&\"", BINOP_CONCAT},
752 {"Oabs", "\"abs\"", UNOP_ABS},
753 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
754 {"Oadd", "\"+\"", UNOP_PLUS},
755 {"Osubtract", "\"-\"", UNOP_NEG},
759 /* Return non-zero if STR should be suppressed in info listings. */
762 is_suppressed_name (const char *str)
764 if (strncmp (str, "_ada_", 5) == 0)
766 if (str[0] == '_' || str[0] == '\000')
771 const char *suffix = strstr (str, "___");
772 if (suffix != NULL && suffix[3] != 'X')
775 suffix = str + strlen (str);
776 for (p = suffix - 1; p != str; p -= 1)
780 if (p[0] == 'X' && p[-1] != '_')
784 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
785 if (strncmp (ada_opname_table[i].encoded, p,
786 strlen (ada_opname_table[i].encoded)) == 0)
795 /* The "encoded" form of DECODED, according to GNAT conventions.
796 The result is valid until the next call to ada_encode. */
799 ada_encode (const char *decoded)
801 static char *encoding_buffer = NULL;
802 static size_t encoding_buffer_size = 0;
809 GROW_VECT (encoding_buffer, encoding_buffer_size,
810 2 * strlen (decoded) + 10);
813 for (p = decoded; *p != '\0'; p += 1)
815 if (!ADA_RETAIN_DOTS && *p == '.')
817 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
822 const struct ada_opname_map *mapping;
824 for (mapping = ada_opname_table;
825 mapping->encoded != NULL
826 && strncmp (mapping->decoded, p,
827 strlen (mapping->decoded)) != 0; mapping += 1)
829 if (mapping->encoded == NULL)
830 error (_("invalid Ada operator name: %s"), p);
831 strcpy (encoding_buffer + k, mapping->encoded);
832 k += strlen (mapping->encoded);
837 encoding_buffer[k] = *p;
842 encoding_buffer[k] = '\0';
843 return encoding_buffer;
846 /* Return NAME folded to lower case, or, if surrounded by single
847 quotes, unfolded, but with the quotes stripped away. Result good
851 ada_fold_name (const char *name)
853 static char *fold_buffer = NULL;
854 static size_t fold_buffer_size = 0;
856 int len = strlen (name);
857 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
861 strncpy (fold_buffer, name + 1, len - 2);
862 fold_buffer[len - 2] = '\000';
867 for (i = 0; i <= len; i += 1)
868 fold_buffer[i] = tolower (name[i]);
874 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
877 is_lower_alphanum (const char c)
879 return (isdigit (c) || (isalpha (c) && islower (c)));
882 /* Remove either of these suffixes:
887 These are suffixes introduced by the compiler for entities such as
888 nested subprogram for instance, in order to avoid name clashes.
889 They do not serve any purpose for the debugger. */
892 ada_remove_trailing_digits (const char *encoded, int *len)
894 if (*len > 1 && isdigit (encoded[*len - 1]))
897 while (i > 0 && isdigit (encoded[i]))
899 if (i >= 0 && encoded[i] == '.')
901 else if (i >= 0 && encoded[i] == '$')
903 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
905 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
910 /* Remove the suffix introduced by the compiler for protected object
914 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
916 /* Remove trailing N. */
918 /* Protected entry subprograms are broken into two
919 separate subprograms: The first one is unprotected, and has
920 a 'N' suffix; the second is the protected version, and has
921 the 'P' suffix. The second calls the first one after handling
922 the protection. Since the P subprograms are internally generated,
923 we leave these names undecoded, giving the user a clue that this
924 entity is internal. */
927 && encoded[*len - 1] == 'N'
928 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
932 /* If ENCODED follows the GNAT entity encoding conventions, then return
933 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
936 The resulting string is valid until the next call of ada_decode.
937 If the string is unchanged by decoding, the original string pointer
941 ada_decode (const char *encoded)
948 static char *decoding_buffer = NULL;
949 static size_t decoding_buffer_size = 0;
951 /* The name of the Ada main procedure starts with "_ada_".
952 This prefix is not part of the decoded name, so skip this part
953 if we see this prefix. */
954 if (strncmp (encoded, "_ada_", 5) == 0)
957 /* If the name starts with '_', then it is not a properly encoded
958 name, so do not attempt to decode it. Similarly, if the name
959 starts with '<', the name should not be decoded. */
960 if (encoded[0] == '_' || encoded[0] == '<')
963 len0 = strlen (encoded);
965 ada_remove_trailing_digits (encoded, &len0);
966 ada_remove_po_subprogram_suffix (encoded, &len0);
968 /* Remove the ___X.* suffix if present. Do not forget to verify that
969 the suffix is located before the current "end" of ENCODED. We want
970 to avoid re-matching parts of ENCODED that have previously been
971 marked as discarded (by decrementing LEN0). */
972 p = strstr (encoded, "___");
973 if (p != NULL && p - encoded < len0 - 3)
981 /* Remove any trailing TKB suffix. It tells us that this symbol
982 is for the body of a task, but that information does not actually
983 appear in the decoded name. */
985 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
988 /* Remove trailing "B" suffixes. */
989 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
991 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
994 /* Make decoded big enough for possible expansion by operator name. */
996 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
997 decoded = decoding_buffer;
999 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1001 if (len0 > 1 && isdigit (encoded[len0 - 1]))
1004 while ((i >= 0 && isdigit (encoded[i]))
1005 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1007 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1009 else if (encoded[i] == '$')
1013 /* The first few characters that are not alphabetic are not part
1014 of any encoding we use, so we can copy them over verbatim. */
1016 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1017 decoded[j] = encoded[i];
1022 /* Is this a symbol function? */
1023 if (at_start_name && encoded[i] == 'O')
1026 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1028 int op_len = strlen (ada_opname_table[k].encoded);
1029 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1031 && !isalnum (encoded[i + op_len]))
1033 strcpy (decoded + j, ada_opname_table[k].decoded);
1036 j += strlen (ada_opname_table[k].decoded);
1040 if (ada_opname_table[k].encoded != NULL)
1045 /* Replace "TK__" with "__", which will eventually be translated
1046 into "." (just below). */
1048 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1051 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1052 be translated into "." (just below). These are internal names
1053 generated for anonymous blocks inside which our symbol is nested. */
1055 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1056 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1057 && isdigit (encoded [i+4]))
1061 while (k < len0 && isdigit (encoded[k]))
1062 k++; /* Skip any extra digit. */
1064 /* Double-check that the "__B_{DIGITS}+" sequence we found
1065 is indeed followed by "__". */
1066 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1070 /* Remove _E{DIGITS}+[sb] */
1072 /* Just as for protected object subprograms, there are 2 categories
1073 of subprograms created by the compiler for each entry. The first
1074 one implements the actual entry code, and has a suffix following
1075 the convention above; the second one implements the barrier and
1076 uses the same convention as above, except that the 'E' is replaced
1079 Just as above, we do not decode the name of barrier functions
1080 to give the user a clue that the code he is debugging has been
1081 internally generated. */
1083 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1084 && isdigit (encoded[i+2]))
1088 while (k < len0 && isdigit (encoded[k]))
1092 && (encoded[k] == 'b' || encoded[k] == 's'))
1095 /* Just as an extra precaution, make sure that if this
1096 suffix is followed by anything else, it is a '_'.
1097 Otherwise, we matched this sequence by accident. */
1099 || (k < len0 && encoded[k] == '_'))
1104 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1105 the GNAT front-end in protected object subprograms. */
1108 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1110 /* Backtrack a bit up until we reach either the begining of
1111 the encoded name, or "__". Make sure that we only find
1112 digits or lowercase characters. */
1113 const char *ptr = encoded + i - 1;
1115 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1118 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1122 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1124 /* This is a X[bn]* sequence not separated from the previous
1125 part of the name with a non-alpha-numeric character (in other
1126 words, immediately following an alpha-numeric character), then
1127 verify that it is placed at the end of the encoded name. If
1128 not, then the encoding is not valid and we should abort the
1129 decoding. Otherwise, just skip it, it is used in body-nested
1133 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1137 else if (!ADA_RETAIN_DOTS
1138 && i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1140 /* Replace '__' by '.'. */
1148 /* It's a character part of the decoded name, so just copy it
1150 decoded[j] = encoded[i];
1155 decoded[j] = '\000';
1157 /* Decoded names should never contain any uppercase character.
1158 Double-check this, and abort the decoding if we find one. */
1160 for (i = 0; decoded[i] != '\0'; i += 1)
1161 if (isupper (decoded[i]) || decoded[i] == ' ')
1164 if (strcmp (decoded, encoded) == 0)
1170 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1171 decoded = decoding_buffer;
1172 if (encoded[0] == '<')
1173 strcpy (decoded, encoded);
1175 sprintf (decoded, "<%s>", encoded);
1180 /* Table for keeping permanent unique copies of decoded names. Once
1181 allocated, names in this table are never released. While this is a
1182 storage leak, it should not be significant unless there are massive
1183 changes in the set of decoded names in successive versions of a
1184 symbol table loaded during a single session. */
1185 static struct htab *decoded_names_store;
1187 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1188 in the language-specific part of GSYMBOL, if it has not been
1189 previously computed. Tries to save the decoded name in the same
1190 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1191 in any case, the decoded symbol has a lifetime at least that of
1193 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1194 const, but nevertheless modified to a semantically equivalent form
1195 when a decoded name is cached in it.
1199 ada_decode_symbol (const struct general_symbol_info *gsymbol)
1202 (char **) &gsymbol->language_specific.cplus_specific.demangled_name;
1203 if (*resultp == NULL)
1205 const char *decoded = ada_decode (gsymbol->name);
1206 if (gsymbol->obj_section != NULL)
1208 struct objfile *objf = gsymbol->obj_section->objfile;
1209 *resultp = obsavestring (decoded, strlen (decoded),
1210 &objf->objfile_obstack);
1212 /* Sometimes, we can't find a corresponding objfile, in which
1213 case, we put the result on the heap. Since we only decode
1214 when needed, we hope this usually does not cause a
1215 significant memory leak (FIXME). */
1216 if (*resultp == NULL)
1218 char **slot = (char **) htab_find_slot (decoded_names_store,
1221 *slot = xstrdup (decoded);
1230 ada_la_decode (const char *encoded, int options)
1232 return xstrdup (ada_decode (encoded));
1235 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1236 suffixes that encode debugging information or leading _ada_ on
1237 SYM_NAME (see is_name_suffix commentary for the debugging
1238 information that is ignored). If WILD, then NAME need only match a
1239 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1240 either argument is NULL. */
1243 ada_match_name (const char *sym_name, const char *name, int wild)
1245 if (sym_name == NULL || name == NULL)
1248 return wild_match (name, strlen (name), sym_name);
1251 int len_name = strlen (name);
1252 return (strncmp (sym_name, name, len_name) == 0
1253 && is_name_suffix (sym_name + len_name))
1254 || (strncmp (sym_name, "_ada_", 5) == 0
1255 && strncmp (sym_name + 5, name, len_name) == 0
1256 && is_name_suffix (sym_name + len_name + 5));
1260 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1261 suppressed in info listings. */
1264 ada_suppress_symbol_printing (struct symbol *sym)
1266 if (SYMBOL_DOMAIN (sym) == STRUCT_DOMAIN)
1269 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym));
1275 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1277 static char *bound_name[] = {
1278 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1279 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1282 /* Maximum number of array dimensions we are prepared to handle. */
1284 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1286 /* Like modify_field, but allows bitpos > wordlength. */
1289 modify_general_field (char *addr, LONGEST fieldval, int bitpos, int bitsize)
1291 modify_field (addr + bitpos / 8, fieldval, bitpos % 8, bitsize);
1295 /* The desc_* routines return primitive portions of array descriptors
1298 /* The descriptor or array type, if any, indicated by TYPE; removes
1299 level of indirection, if needed. */
1301 static struct type *
1302 desc_base_type (struct type *type)
1306 type = ada_check_typedef (type);
1308 && (TYPE_CODE (type) == TYPE_CODE_PTR
1309 || TYPE_CODE (type) == TYPE_CODE_REF))
1310 return ada_check_typedef (TYPE_TARGET_TYPE (type));
1315 /* True iff TYPE indicates a "thin" array pointer type. */
1318 is_thin_pntr (struct type *type)
1321 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1322 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1325 /* The descriptor type for thin pointer type TYPE. */
1327 static struct type *
1328 thin_descriptor_type (struct type *type)
1330 struct type *base_type = desc_base_type (type);
1331 if (base_type == NULL)
1333 if (is_suffix (ada_type_name (base_type), "___XVE"))
1337 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1338 if (alt_type == NULL)
1345 /* A pointer to the array data for thin-pointer value VAL. */
1347 static struct value *
1348 thin_data_pntr (struct value *val)
1350 struct type *type = value_type (val);
1351 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1352 return value_cast (desc_data_type (thin_descriptor_type (type)),
1355 return value_from_longest (desc_data_type (thin_descriptor_type (type)),
1356 VALUE_ADDRESS (val) + value_offset (val));
1359 /* True iff TYPE indicates a "thick" array pointer type. */
1362 is_thick_pntr (struct type *type)
1364 type = desc_base_type (type);
1365 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1366 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1369 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1370 pointer to one, the type of its bounds data; otherwise, NULL. */
1372 static struct type *
1373 desc_bounds_type (struct type *type)
1377 type = desc_base_type (type);
1381 else if (is_thin_pntr (type))
1383 type = thin_descriptor_type (type);
1386 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1388 return ada_check_typedef (r);
1390 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1392 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1394 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1399 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1400 one, a pointer to its bounds data. Otherwise NULL. */
1402 static struct value *
1403 desc_bounds (struct value *arr)
1405 struct type *type = ada_check_typedef (value_type (arr));
1406 if (is_thin_pntr (type))
1408 struct type *bounds_type =
1409 desc_bounds_type (thin_descriptor_type (type));
1412 if (bounds_type == NULL)
1413 error (_("Bad GNAT array descriptor"));
1415 /* NOTE: The following calculation is not really kosher, but
1416 since desc_type is an XVE-encoded type (and shouldn't be),
1417 the correct calculation is a real pain. FIXME (and fix GCC). */
1418 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1419 addr = value_as_long (arr);
1421 addr = VALUE_ADDRESS (arr) + value_offset (arr);
1424 value_from_longest (lookup_pointer_type (bounds_type),
1425 addr - TYPE_LENGTH (bounds_type));
1428 else if (is_thick_pntr (type))
1429 return value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1430 _("Bad GNAT array descriptor"));
1435 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1436 position of the field containing the address of the bounds data. */
1439 fat_pntr_bounds_bitpos (struct type *type)
1441 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1444 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1445 size of the field containing the address of the bounds data. */
1448 fat_pntr_bounds_bitsize (struct type *type)
1450 type = desc_base_type (type);
1452 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1453 return TYPE_FIELD_BITSIZE (type, 1);
1455 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1458 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1459 pointer to one, the type of its array data (a
1460 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1461 ada_type_of_array to get an array type with bounds data. */
1463 static struct type *
1464 desc_data_type (struct type *type)
1466 type = desc_base_type (type);
1468 /* NOTE: The following is bogus; see comment in desc_bounds. */
1469 if (is_thin_pntr (type))
1470 return lookup_pointer_type
1471 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)));
1472 else if (is_thick_pntr (type))
1473 return lookup_struct_elt_type (type, "P_ARRAY", 1);
1478 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1481 static struct value *
1482 desc_data (struct value *arr)
1484 struct type *type = value_type (arr);
1485 if (is_thin_pntr (type))
1486 return thin_data_pntr (arr);
1487 else if (is_thick_pntr (type))
1488 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1489 _("Bad GNAT array descriptor"));
1495 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1496 position of the field containing the address of the data. */
1499 fat_pntr_data_bitpos (struct type *type)
1501 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1504 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1505 size of the field containing the address of the data. */
1508 fat_pntr_data_bitsize (struct type *type)
1510 type = desc_base_type (type);
1512 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1513 return TYPE_FIELD_BITSIZE (type, 0);
1515 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1518 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1519 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1520 bound, if WHICH is 1. The first bound is I=1. */
1522 static struct value *
1523 desc_one_bound (struct value *bounds, int i, int which)
1525 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1526 _("Bad GNAT array descriptor bounds"));
1529 /* If BOUNDS is an array-bounds structure type, return the bit position
1530 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1531 bound, if WHICH is 1. The first bound is I=1. */
1534 desc_bound_bitpos (struct type *type, int i, int which)
1536 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1539 /* If BOUNDS is an array-bounds structure type, return the bit field size
1540 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1541 bound, if WHICH is 1. The first bound is I=1. */
1544 desc_bound_bitsize (struct type *type, int i, int which)
1546 type = desc_base_type (type);
1548 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1549 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1551 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1554 /* If TYPE is the type of an array-bounds structure, the type of its
1555 Ith bound (numbering from 1). Otherwise, NULL. */
1557 static struct type *
1558 desc_index_type (struct type *type, int i)
1560 type = desc_base_type (type);
1562 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1563 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1568 /* The number of index positions in the array-bounds type TYPE.
1569 Return 0 if TYPE is NULL. */
1572 desc_arity (struct type *type)
1574 type = desc_base_type (type);
1577 return TYPE_NFIELDS (type) / 2;
1581 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1582 an array descriptor type (representing an unconstrained array
1586 ada_is_direct_array_type (struct type *type)
1590 type = ada_check_typedef (type);
1591 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1592 || ada_is_array_descriptor_type (type));
1595 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1599 ada_is_array_type (struct type *type)
1602 && (TYPE_CODE (type) == TYPE_CODE_PTR
1603 || TYPE_CODE (type) == TYPE_CODE_REF))
1604 type = TYPE_TARGET_TYPE (type);
1605 return ada_is_direct_array_type (type);
1608 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1611 ada_is_simple_array_type (struct type *type)
1615 type = ada_check_typedef (type);
1616 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1617 || (TYPE_CODE (type) == TYPE_CODE_PTR
1618 && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY));
1621 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1624 ada_is_array_descriptor_type (struct type *type)
1626 struct type *data_type = desc_data_type (type);
1630 type = ada_check_typedef (type);
1633 && ((TYPE_CODE (data_type) == TYPE_CODE_PTR
1634 && TYPE_TARGET_TYPE (data_type) != NULL
1635 && TYPE_CODE (TYPE_TARGET_TYPE (data_type)) == TYPE_CODE_ARRAY)
1636 || TYPE_CODE (data_type) == TYPE_CODE_ARRAY)
1637 && desc_arity (desc_bounds_type (type)) > 0;
1640 /* Non-zero iff type is a partially mal-formed GNAT array
1641 descriptor. FIXME: This is to compensate for some problems with
1642 debugging output from GNAT. Re-examine periodically to see if it
1646 ada_is_bogus_array_descriptor (struct type *type)
1650 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1651 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1652 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1653 && !ada_is_array_descriptor_type (type);
1657 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1658 (fat pointer) returns the type of the array data described---specifically,
1659 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1660 in from the descriptor; otherwise, they are left unspecified. If
1661 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1662 returns NULL. The result is simply the type of ARR if ARR is not
1665 ada_type_of_array (struct value *arr, int bounds)
1667 if (ada_is_packed_array_type (value_type (arr)))
1668 return decode_packed_array_type (value_type (arr));
1670 if (!ada_is_array_descriptor_type (value_type (arr)))
1671 return value_type (arr);
1675 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr))));
1678 struct type *elt_type;
1680 struct value *descriptor;
1681 struct objfile *objf = TYPE_OBJFILE (value_type (arr));
1683 elt_type = ada_array_element_type (value_type (arr), -1);
1684 arity = ada_array_arity (value_type (arr));
1686 if (elt_type == NULL || arity == 0)
1687 return ada_check_typedef (value_type (arr));
1689 descriptor = desc_bounds (arr);
1690 if (value_as_long (descriptor) == 0)
1694 struct type *range_type = alloc_type (objf);
1695 struct type *array_type = alloc_type (objf);
1696 struct value *low = desc_one_bound (descriptor, arity, 0);
1697 struct value *high = desc_one_bound (descriptor, arity, 1);
1700 create_range_type (range_type, value_type (low),
1701 longest_to_int (value_as_long (low)),
1702 longest_to_int (value_as_long (high)));
1703 elt_type = create_array_type (array_type, elt_type, range_type);
1706 return lookup_pointer_type (elt_type);
1710 /* If ARR does not represent an array, returns ARR unchanged.
1711 Otherwise, returns either a standard GDB array with bounds set
1712 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1713 GDB array. Returns NULL if ARR is a null fat pointer. */
1716 ada_coerce_to_simple_array_ptr (struct value *arr)
1718 if (ada_is_array_descriptor_type (value_type (arr)))
1720 struct type *arrType = ada_type_of_array (arr, 1);
1721 if (arrType == NULL)
1723 return value_cast (arrType, value_copy (desc_data (arr)));
1725 else if (ada_is_packed_array_type (value_type (arr)))
1726 return decode_packed_array (arr);
1731 /* If ARR does not represent an array, returns ARR unchanged.
1732 Otherwise, returns a standard GDB array describing ARR (which may
1733 be ARR itself if it already is in the proper form). */
1735 static struct value *
1736 ada_coerce_to_simple_array (struct value *arr)
1738 if (ada_is_array_descriptor_type (value_type (arr)))
1740 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1742 error (_("Bounds unavailable for null array pointer."));
1743 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
1744 return value_ind (arrVal);
1746 else if (ada_is_packed_array_type (value_type (arr)))
1747 return decode_packed_array (arr);
1752 /* If TYPE represents a GNAT array type, return it translated to an
1753 ordinary GDB array type (possibly with BITSIZE fields indicating
1754 packing). For other types, is the identity. */
1757 ada_coerce_to_simple_array_type (struct type *type)
1759 struct value *mark = value_mark ();
1760 struct value *dummy = value_from_longest (builtin_type_long, 0);
1761 struct type *result;
1762 deprecated_set_value_type (dummy, type);
1763 result = ada_type_of_array (dummy, 0);
1764 value_free_to_mark (mark);
1768 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1771 ada_is_packed_array_type (struct type *type)
1775 type = desc_base_type (type);
1776 type = ada_check_typedef (type);
1778 ada_type_name (type) != NULL
1779 && strstr (ada_type_name (type), "___XP") != NULL;
1782 /* Given that TYPE is a standard GDB array type with all bounds filled
1783 in, and that the element size of its ultimate scalar constituents
1784 (that is, either its elements, or, if it is an array of arrays, its
1785 elements' elements, etc.) is *ELT_BITS, return an identical type,
1786 but with the bit sizes of its elements (and those of any
1787 constituent arrays) recorded in the BITSIZE components of its
1788 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1791 static struct type *
1792 packed_array_type (struct type *type, long *elt_bits)
1794 struct type *new_elt_type;
1795 struct type *new_type;
1796 LONGEST low_bound, high_bound;
1798 type = ada_check_typedef (type);
1799 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1802 new_type = alloc_type (TYPE_OBJFILE (type));
1803 new_elt_type = packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
1805 create_array_type (new_type, new_elt_type, TYPE_FIELD_TYPE (type, 0));
1806 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
1807 TYPE_NAME (new_type) = ada_type_name (type);
1809 if (get_discrete_bounds (TYPE_FIELD_TYPE (type, 0),
1810 &low_bound, &high_bound) < 0)
1811 low_bound = high_bound = 0;
1812 if (high_bound < low_bound)
1813 *elt_bits = TYPE_LENGTH (new_type) = 0;
1816 *elt_bits *= (high_bound - low_bound + 1);
1817 TYPE_LENGTH (new_type) =
1818 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
1821 TYPE_FIXED_INSTANCE (new_type) = 1;
1825 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1827 static struct type *
1828 decode_packed_array_type (struct type *type)
1831 struct block **blocks;
1832 char *raw_name = ada_type_name (ada_check_typedef (type));
1835 struct type *shadow_type;
1840 raw_name = ada_type_name (desc_base_type (type));
1845 name = (char *) alloca (strlen (raw_name) + 1);
1846 tail = strstr (raw_name, "___XP");
1847 type = desc_base_type (type);
1849 memcpy (name, raw_name, tail - raw_name);
1850 name[tail - raw_name] = '\000';
1852 sym = standard_lookup (name, get_selected_block (0), VAR_DOMAIN);
1853 if (sym == NULL || SYMBOL_TYPE (sym) == NULL)
1855 lim_warning (_("could not find bounds information on packed array"));
1858 shadow_type = SYMBOL_TYPE (sym);
1860 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
1862 lim_warning (_("could not understand bounds information on packed array"));
1866 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1869 (_("could not understand bit size information on packed array"));
1873 return packed_array_type (shadow_type, &bits);
1876 /* Given that ARR is a struct value *indicating a GNAT packed array,
1877 returns a simple array that denotes that array. Its type is a
1878 standard GDB array type except that the BITSIZEs of the array
1879 target types are set to the number of bits in each element, and the
1880 type length is set appropriately. */
1882 static struct value *
1883 decode_packed_array (struct value *arr)
1887 arr = ada_coerce_ref (arr);
1888 if (TYPE_CODE (value_type (arr)) == TYPE_CODE_PTR)
1889 arr = ada_value_ind (arr);
1891 type = decode_packed_array_type (value_type (arr));
1894 error (_("can't unpack array"));
1898 if (gdbarch_bits_big_endian (current_gdbarch)
1899 && ada_is_modular_type (value_type (arr)))
1901 /* This is a (right-justified) modular type representing a packed
1902 array with no wrapper. In order to interpret the value through
1903 the (left-justified) packed array type we just built, we must
1904 first left-justify it. */
1905 int bit_size, bit_pos;
1908 mod = ada_modulus (value_type (arr)) - 1;
1915 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
1916 arr = ada_value_primitive_packed_val (arr, NULL,
1917 bit_pos / HOST_CHAR_BIT,
1918 bit_pos % HOST_CHAR_BIT,
1923 return coerce_unspec_val_to_type (arr, type);
1927 /* The value of the element of packed array ARR at the ARITY indices
1928 given in IND. ARR must be a simple array. */
1930 static struct value *
1931 value_subscript_packed (struct value *arr, int arity, struct value **ind)
1934 int bits, elt_off, bit_off;
1935 long elt_total_bit_offset;
1936 struct type *elt_type;
1940 elt_total_bit_offset = 0;
1941 elt_type = ada_check_typedef (value_type (arr));
1942 for (i = 0; i < arity; i += 1)
1944 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
1945 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
1947 (_("attempt to do packed indexing of something other than a packed array"));
1950 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
1951 LONGEST lowerbound, upperbound;
1954 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
1956 lim_warning (_("don't know bounds of array"));
1957 lowerbound = upperbound = 0;
1960 idx = value_as_long (value_pos_atr (ind[i]));
1961 if (idx < lowerbound || idx > upperbound)
1962 lim_warning (_("packed array index %ld out of bounds"), (long) idx);
1963 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
1964 elt_total_bit_offset += (idx - lowerbound) * bits;
1965 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
1968 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
1969 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
1971 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
1976 /* Non-zero iff TYPE includes negative integer values. */
1979 has_negatives (struct type *type)
1981 switch (TYPE_CODE (type))
1986 return !TYPE_UNSIGNED (type);
1987 case TYPE_CODE_RANGE:
1988 return TYPE_LOW_BOUND (type) < 0;
1993 /* Create a new value of type TYPE from the contents of OBJ starting
1994 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1995 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1996 assigning through the result will set the field fetched from.
1997 VALADDR is ignored unless OBJ is NULL, in which case,
1998 VALADDR+OFFSET must address the start of storage containing the
1999 packed value. The value returned in this case is never an lval.
2000 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2003 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2004 long offset, int bit_offset, int bit_size,
2008 int src, /* Index into the source area */
2009 targ, /* Index into the target area */
2010 srcBitsLeft, /* Number of source bits left to move */
2011 nsrc, ntarg, /* Number of source and target bytes */
2012 unusedLS, /* Number of bits in next significant
2013 byte of source that are unused */
2014 accumSize; /* Number of meaningful bits in accum */
2015 unsigned char *bytes; /* First byte containing data to unpack */
2016 unsigned char *unpacked;
2017 unsigned long accum; /* Staging area for bits being transferred */
2019 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2020 /* Transmit bytes from least to most significant; delta is the direction
2021 the indices move. */
2022 int delta = gdbarch_bits_big_endian (current_gdbarch) ? -1 : 1;
2024 type = ada_check_typedef (type);
2028 v = allocate_value (type);
2029 bytes = (unsigned char *) (valaddr + offset);
2031 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2034 VALUE_ADDRESS (obj) + value_offset (obj) + offset);
2035 bytes = (unsigned char *) alloca (len);
2036 read_memory (VALUE_ADDRESS (v), bytes, len);
2040 v = allocate_value (type);
2041 bytes = (unsigned char *) value_contents (obj) + offset;
2046 VALUE_LVAL (v) = VALUE_LVAL (obj);
2047 if (VALUE_LVAL (obj) == lval_internalvar)
2048 VALUE_LVAL (v) = lval_internalvar_component;
2049 VALUE_ADDRESS (v) = VALUE_ADDRESS (obj) + value_offset (obj) + offset;
2050 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2051 set_value_bitsize (v, bit_size);
2052 if (value_bitpos (v) >= HOST_CHAR_BIT)
2054 VALUE_ADDRESS (v) += 1;
2055 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2059 set_value_bitsize (v, bit_size);
2060 unpacked = (unsigned char *) value_contents (v);
2062 srcBitsLeft = bit_size;
2064 ntarg = TYPE_LENGTH (type);
2068 memset (unpacked, 0, TYPE_LENGTH (type));
2071 else if (gdbarch_bits_big_endian (current_gdbarch))
2074 if (has_negatives (type)
2075 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2079 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2082 switch (TYPE_CODE (type))
2084 case TYPE_CODE_ARRAY:
2085 case TYPE_CODE_UNION:
2086 case TYPE_CODE_STRUCT:
2087 /* Non-scalar values must be aligned at a byte boundary... */
2089 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2090 /* ... And are placed at the beginning (most-significant) bytes
2092 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2096 targ = TYPE_LENGTH (type) - 1;
2102 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2105 unusedLS = bit_offset;
2108 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
2115 /* Mask for removing bits of the next source byte that are not
2116 part of the value. */
2117 unsigned int unusedMSMask =
2118 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2120 /* Sign-extend bits for this byte. */
2121 unsigned int signMask = sign & ~unusedMSMask;
2123 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2124 accumSize += HOST_CHAR_BIT - unusedLS;
2125 if (accumSize >= HOST_CHAR_BIT)
2127 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2128 accumSize -= HOST_CHAR_BIT;
2129 accum >>= HOST_CHAR_BIT;
2133 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2140 accum |= sign << accumSize;
2141 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2142 accumSize -= HOST_CHAR_BIT;
2143 accum >>= HOST_CHAR_BIT;
2151 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2152 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2155 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2156 int src_offset, int n)
2158 unsigned int accum, mask;
2159 int accum_bits, chunk_size;
2161 target += targ_offset / HOST_CHAR_BIT;
2162 targ_offset %= HOST_CHAR_BIT;
2163 source += src_offset / HOST_CHAR_BIT;
2164 src_offset %= HOST_CHAR_BIT;
2165 if (gdbarch_bits_big_endian (current_gdbarch))
2167 accum = (unsigned char) *source;
2169 accum_bits = HOST_CHAR_BIT - src_offset;
2174 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2175 accum_bits += HOST_CHAR_BIT;
2177 chunk_size = HOST_CHAR_BIT - targ_offset;
2180 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2181 mask = ((1 << chunk_size) - 1) << unused_right;
2184 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2186 accum_bits -= chunk_size;
2193 accum = (unsigned char) *source >> src_offset;
2195 accum_bits = HOST_CHAR_BIT - src_offset;
2199 accum = accum + ((unsigned char) *source << accum_bits);
2200 accum_bits += HOST_CHAR_BIT;
2202 chunk_size = HOST_CHAR_BIT - targ_offset;
2205 mask = ((1 << chunk_size) - 1) << targ_offset;
2206 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2208 accum_bits -= chunk_size;
2209 accum >>= chunk_size;
2216 /* Store the contents of FROMVAL into the location of TOVAL.
2217 Return a new value with the location of TOVAL and contents of
2218 FROMVAL. Handles assignment into packed fields that have
2219 floating-point or non-scalar types. */
2221 static struct value *
2222 ada_value_assign (struct value *toval, struct value *fromval)
2224 struct type *type = value_type (toval);
2225 int bits = value_bitsize (toval);
2227 toval = ada_coerce_ref (toval);
2228 fromval = ada_coerce_ref (fromval);
2230 if (ada_is_direct_array_type (value_type (toval)))
2231 toval = ada_coerce_to_simple_array (toval);
2232 if (ada_is_direct_array_type (value_type (fromval)))
2233 fromval = ada_coerce_to_simple_array (fromval);
2235 if (!deprecated_value_modifiable (toval))
2236 error (_("Left operand of assignment is not a modifiable lvalue."));
2238 if (VALUE_LVAL (toval) == lval_memory
2240 && (TYPE_CODE (type) == TYPE_CODE_FLT
2241 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2243 int len = (value_bitpos (toval)
2244 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2246 char *buffer = (char *) alloca (len);
2248 CORE_ADDR to_addr = VALUE_ADDRESS (toval) + value_offset (toval);
2250 if (TYPE_CODE (type) == TYPE_CODE_FLT)
2251 fromval = value_cast (type, fromval);
2253 read_memory (to_addr, buffer, len);
2254 from_size = value_bitsize (fromval);
2256 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2257 if (gdbarch_bits_big_endian (current_gdbarch))
2258 move_bits (buffer, value_bitpos (toval),
2259 value_contents (fromval), from_size - bits, bits);
2261 move_bits (buffer, value_bitpos (toval), value_contents (fromval),
2263 write_memory (to_addr, buffer, len);
2264 if (deprecated_memory_changed_hook)
2265 deprecated_memory_changed_hook (to_addr, len);
2267 val = value_copy (toval);
2268 memcpy (value_contents_raw (val), value_contents (fromval),
2269 TYPE_LENGTH (type));
2270 deprecated_set_value_type (val, type);
2275 return value_assign (toval, fromval);
2279 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2280 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2281 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2282 * COMPONENT, and not the inferior's memory. The current contents
2283 * of COMPONENT are ignored. */
2285 value_assign_to_component (struct value *container, struct value *component,
2288 LONGEST offset_in_container =
2289 (LONGEST) (VALUE_ADDRESS (component) + value_offset (component)
2290 - VALUE_ADDRESS (container) - value_offset (container));
2291 int bit_offset_in_container =
2292 value_bitpos (component) - value_bitpos (container);
2295 val = value_cast (value_type (component), val);
2297 if (value_bitsize (component) == 0)
2298 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2300 bits = value_bitsize (component);
2302 if (gdbarch_bits_big_endian (current_gdbarch))
2303 move_bits (value_contents_writeable (container) + offset_in_container,
2304 value_bitpos (container) + bit_offset_in_container,
2305 value_contents (val),
2306 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2309 move_bits (value_contents_writeable (container) + offset_in_container,
2310 value_bitpos (container) + bit_offset_in_container,
2311 value_contents (val), 0, bits);
2314 /* The value of the element of array ARR at the ARITY indices given in IND.
2315 ARR may be either a simple array, GNAT array descriptor, or pointer
2319 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2323 struct type *elt_type;
2325 elt = ada_coerce_to_simple_array (arr);
2327 elt_type = ada_check_typedef (value_type (elt));
2328 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2329 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2330 return value_subscript_packed (elt, arity, ind);
2332 for (k = 0; k < arity; k += 1)
2334 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2335 error (_("too many subscripts (%d expected)"), k);
2336 elt = value_subscript (elt, value_pos_atr (ind[k]));
2341 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2342 value of the element of *ARR at the ARITY indices given in
2343 IND. Does not read the entire array into memory. */
2346 ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
2351 for (k = 0; k < arity; k += 1)
2356 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2357 error (_("too many subscripts (%d expected)"), k);
2358 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2360 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2361 idx = value_pos_atr (ind[k]);
2363 idx = value_sub (idx, value_from_longest (builtin_type_int, lwb));
2364 arr = value_add (arr, idx);
2365 type = TYPE_TARGET_TYPE (type);
2368 return value_ind (arr);
2371 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2372 actual type of ARRAY_PTR is ignored), returns a reference to
2373 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2374 bound of this array is LOW, as per Ada rules. */
2375 static struct value *
2376 ada_value_slice_ptr (struct value *array_ptr, struct type *type,
2379 CORE_ADDR base = value_as_address (array_ptr)
2380 + ((low - TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type)))
2381 * TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
2382 struct type *index_type =
2383 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)),
2385 struct type *slice_type =
2386 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2387 return value_from_pointer (lookup_reference_type (slice_type), base);
2391 static struct value *
2392 ada_value_slice (struct value *array, int low, int high)
2394 struct type *type = value_type (array);
2395 struct type *index_type =
2396 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2397 struct type *slice_type =
2398 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2399 return value_cast (slice_type, value_slice (array, low, high - low + 1));
2402 /* If type is a record type in the form of a standard GNAT array
2403 descriptor, returns the number of dimensions for type. If arr is a
2404 simple array, returns the number of "array of"s that prefix its
2405 type designation. Otherwise, returns 0. */
2408 ada_array_arity (struct type *type)
2415 type = desc_base_type (type);
2418 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2419 return desc_arity (desc_bounds_type (type));
2421 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2424 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2430 /* If TYPE is a record type in the form of a standard GNAT array
2431 descriptor or a simple array type, returns the element type for
2432 TYPE after indexing by NINDICES indices, or by all indices if
2433 NINDICES is -1. Otherwise, returns NULL. */
2436 ada_array_element_type (struct type *type, int nindices)
2438 type = desc_base_type (type);
2440 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2443 struct type *p_array_type;
2445 p_array_type = desc_data_type (type);
2447 k = ada_array_arity (type);
2451 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2452 if (nindices >= 0 && k > nindices)
2454 p_array_type = TYPE_TARGET_TYPE (p_array_type);
2455 while (k > 0 && p_array_type != NULL)
2457 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2460 return p_array_type;
2462 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2464 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
2466 type = TYPE_TARGET_TYPE (type);
2475 /* The type of nth index in arrays of given type (n numbering from 1).
2476 Does not examine memory. */
2479 ada_index_type (struct type *type, int n)
2481 struct type *result_type;
2483 type = desc_base_type (type);
2485 if (n > ada_array_arity (type))
2488 if (ada_is_simple_array_type (type))
2492 for (i = 1; i < n; i += 1)
2493 type = TYPE_TARGET_TYPE (type);
2494 result_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 0));
2495 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2496 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2497 perhaps stabsread.c would make more sense. */
2498 if (result_type == NULL || TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2499 result_type = builtin_type_int;
2504 return desc_index_type (desc_bounds_type (type), n);
2507 /* Given that arr is an array type, returns the lower bound of the
2508 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2509 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2510 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2511 bounds type. It works for other arrays with bounds supplied by
2512 run-time quantities other than discriminants. */
2515 ada_array_bound_from_type (struct type * arr_type, int n, int which,
2516 struct type ** typep)
2519 struct type *index_type_desc;
2521 if (ada_is_packed_array_type (arr_type))
2522 arr_type = decode_packed_array_type (arr_type);
2524 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2527 *typep = builtin_type_int;
2528 return (LONGEST) - which;
2531 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2532 type = TYPE_TARGET_TYPE (arr_type);
2536 index_type_desc = ada_find_parallel_type (type, "___XA");
2537 if (index_type_desc == NULL)
2539 struct type *index_type;
2543 type = TYPE_TARGET_TYPE (type);
2547 index_type = TYPE_INDEX_TYPE (type);
2549 *typep = index_type;
2551 /* The index type is either a range type or an enumerated type.
2552 For the range type, we have some macros that allow us to
2553 extract the value of the low and high bounds. But they
2554 do now work for enumerated types. The expressions used
2555 below work for both range and enum types. */
2557 (LONGEST) (which == 0
2558 ? TYPE_FIELD_BITPOS (index_type, 0)
2559 : TYPE_FIELD_BITPOS (index_type,
2560 TYPE_NFIELDS (index_type) - 1));
2564 struct type *index_type =
2565 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n - 1),
2566 NULL, TYPE_OBJFILE (arr_type));
2569 *typep = index_type;
2572 (LONGEST) (which == 0
2573 ? TYPE_LOW_BOUND (index_type)
2574 : TYPE_HIGH_BOUND (index_type));
2578 /* Given that arr is an array value, returns the lower bound of the
2579 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2580 WHICH is 1. This routine will also work for arrays with bounds
2581 supplied by run-time quantities other than discriminants. */
2584 ada_array_bound (struct value *arr, int n, int which)
2586 struct type *arr_type = value_type (arr);
2588 if (ada_is_packed_array_type (arr_type))
2589 return ada_array_bound (decode_packed_array (arr), n, which);
2590 else if (ada_is_simple_array_type (arr_type))
2593 LONGEST v = ada_array_bound_from_type (arr_type, n, which, &type);
2594 return value_from_longest (type, v);
2597 return desc_one_bound (desc_bounds (arr), n, which);
2600 /* Given that arr is an array value, returns the length of the
2601 nth index. This routine will also work for arrays with bounds
2602 supplied by run-time quantities other than discriminants.
2603 Does not work for arrays indexed by enumeration types with representation
2604 clauses at the moment. */
2607 ada_array_length (struct value *arr, int n)
2609 struct type *arr_type = ada_check_typedef (value_type (arr));
2611 if (ada_is_packed_array_type (arr_type))
2612 return ada_array_length (decode_packed_array (arr), n);
2614 if (ada_is_simple_array_type (arr_type))
2618 ada_array_bound_from_type (arr_type, n, 1, &type) -
2619 ada_array_bound_from_type (arr_type, n, 0, NULL) + 1;
2620 return value_from_longest (type, v);
2624 value_from_longest (builtin_type_int32,
2625 value_as_long (desc_one_bound (desc_bounds (arr),
2627 - value_as_long (desc_one_bound (desc_bounds (arr),
2631 /* An empty array whose type is that of ARR_TYPE (an array type),
2632 with bounds LOW to LOW-1. */
2634 static struct value *
2635 empty_array (struct type *arr_type, int low)
2637 struct type *index_type =
2638 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type)),
2640 struct type *elt_type = ada_array_element_type (arr_type, 1);
2641 return allocate_value (create_array_type (NULL, elt_type, index_type));
2645 /* Name resolution */
2647 /* The "decoded" name for the user-definable Ada operator corresponding
2651 ada_decoded_op_name (enum exp_opcode op)
2655 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
2657 if (ada_opname_table[i].op == op)
2658 return ada_opname_table[i].decoded;
2660 error (_("Could not find operator name for opcode"));
2664 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2665 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2666 undefined namespace) and converts operators that are
2667 user-defined into appropriate function calls. If CONTEXT_TYPE is
2668 non-null, it provides a preferred result type [at the moment, only
2669 type void has any effect---causing procedures to be preferred over
2670 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2671 return type is preferred. May change (expand) *EXP. */
2674 resolve (struct expression **expp, int void_context_p)
2678 resolve_subexp (expp, &pc, 1, void_context_p ? builtin_type_void : NULL);
2681 /* Resolve the operator of the subexpression beginning at
2682 position *POS of *EXPP. "Resolving" consists of replacing
2683 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2684 with their resolutions, replacing built-in operators with
2685 function calls to user-defined operators, where appropriate, and,
2686 when DEPROCEDURE_P is non-zero, converting function-valued variables
2687 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2688 are as in ada_resolve, above. */
2690 static struct value *
2691 resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
2692 struct type *context_type)
2696 struct expression *exp; /* Convenience: == *expp. */
2697 enum exp_opcode op = (*expp)->elts[pc].opcode;
2698 struct value **argvec; /* Vector of operand types (alloca'ed). */
2699 int nargs; /* Number of operands. */
2706 /* Pass one: resolve operands, saving their types and updating *pos,
2711 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2712 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2717 resolve_subexp (expp, pos, 0, NULL);
2719 nargs = longest_to_int (exp->elts[pc + 1].longconst);
2724 resolve_subexp (expp, pos, 0, NULL);
2729 resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2732 case OP_ATR_MODULUS:
2742 case TERNOP_IN_RANGE:
2743 case BINOP_IN_BOUNDS:
2749 case OP_DISCRETE_RANGE:
2751 ada_forward_operator_length (exp, pc, &oplen, &nargs);
2760 arg1 = resolve_subexp (expp, pos, 0, NULL);
2762 resolve_subexp (expp, pos, 1, NULL);
2764 resolve_subexp (expp, pos, 1, value_type (arg1));
2781 case BINOP_LOGICAL_AND:
2782 case BINOP_LOGICAL_OR:
2783 case BINOP_BITWISE_AND:
2784 case BINOP_BITWISE_IOR:
2785 case BINOP_BITWISE_XOR:
2788 case BINOP_NOTEQUAL:
2795 case BINOP_SUBSCRIPT:
2803 case UNOP_LOGICAL_NOT:
2819 case OP_INTERNALVAR:
2829 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2832 case STRUCTOP_STRUCT:
2833 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2846 error (_("Unexpected operator during name resolution"));
2849 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
2850 for (i = 0; i < nargs; i += 1)
2851 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
2855 /* Pass two: perform any resolution on principal operator. */
2862 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
2864 struct ada_symbol_info *candidates;
2868 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2869 (exp->elts[pc + 2].symbol),
2870 exp->elts[pc + 1].block, VAR_DOMAIN,
2873 if (n_candidates > 1)
2875 /* Types tend to get re-introduced locally, so if there
2876 are any local symbols that are not types, first filter
2879 for (j = 0; j < n_candidates; j += 1)
2880 switch (SYMBOL_CLASS (candidates[j].sym))
2885 case LOC_REGPARM_ADDR:
2893 if (j < n_candidates)
2896 while (j < n_candidates)
2898 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
2900 candidates[j] = candidates[n_candidates - 1];
2909 if (n_candidates == 0)
2910 error (_("No definition found for %s"),
2911 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2912 else if (n_candidates == 1)
2914 else if (deprocedure_p
2915 && !is_nonfunction (candidates, n_candidates))
2917 i = ada_resolve_function
2918 (candidates, n_candidates, NULL, 0,
2919 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
2922 error (_("Could not find a match for %s"),
2923 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2927 printf_filtered (_("Multiple matches for %s\n"),
2928 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2929 user_select_syms (candidates, n_candidates, 1);
2933 exp->elts[pc + 1].block = candidates[i].block;
2934 exp->elts[pc + 2].symbol = candidates[i].sym;
2935 if (innermost_block == NULL
2936 || contained_in (candidates[i].block, innermost_block))
2937 innermost_block = candidates[i].block;
2941 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
2944 replace_operator_with_call (expp, pc, 0, 0,
2945 exp->elts[pc + 2].symbol,
2946 exp->elts[pc + 1].block);
2953 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2954 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2956 struct ada_symbol_info *candidates;
2960 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2961 (exp->elts[pc + 5].symbol),
2962 exp->elts[pc + 4].block, VAR_DOMAIN,
2964 if (n_candidates == 1)
2968 i = ada_resolve_function
2969 (candidates, n_candidates,
2971 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
2974 error (_("Could not find a match for %s"),
2975 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
2978 exp->elts[pc + 4].block = candidates[i].block;
2979 exp->elts[pc + 5].symbol = candidates[i].sym;
2980 if (innermost_block == NULL
2981 || contained_in (candidates[i].block, innermost_block))
2982 innermost_block = candidates[i].block;
2993 case BINOP_BITWISE_AND:
2994 case BINOP_BITWISE_IOR:
2995 case BINOP_BITWISE_XOR:
2997 case BINOP_NOTEQUAL:
3005 case UNOP_LOGICAL_NOT:
3007 if (possible_user_operator_p (op, argvec))
3009 struct ada_symbol_info *candidates;
3013 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3014 (struct block *) NULL, VAR_DOMAIN,
3016 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
3017 ada_decoded_op_name (op), NULL);
3021 replace_operator_with_call (expp, pc, nargs, 1,
3022 candidates[i].sym, candidates[i].block);
3033 return evaluate_subexp_type (exp, pos);
3036 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3037 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3038 a non-pointer. A type of 'void' (which is never a valid expression type)
3039 by convention matches anything. */
3040 /* The term "match" here is rather loose. The match is heuristic and
3041 liberal. FIXME: TOO liberal, in fact. */
3044 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3046 ftype = ada_check_typedef (ftype);
3047 atype = ada_check_typedef (atype);
3049 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3050 ftype = TYPE_TARGET_TYPE (ftype);
3051 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3052 atype = TYPE_TARGET_TYPE (atype);
3054 if (TYPE_CODE (ftype) == TYPE_CODE_VOID
3055 || TYPE_CODE (atype) == TYPE_CODE_VOID)
3058 switch (TYPE_CODE (ftype))
3063 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3064 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3065 TYPE_TARGET_TYPE (atype), 0);
3068 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3070 case TYPE_CODE_ENUM:
3071 case TYPE_CODE_RANGE:
3072 switch (TYPE_CODE (atype))
3075 case TYPE_CODE_ENUM:
3076 case TYPE_CODE_RANGE:
3082 case TYPE_CODE_ARRAY:
3083 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3084 || ada_is_array_descriptor_type (atype));
3086 case TYPE_CODE_STRUCT:
3087 if (ada_is_array_descriptor_type (ftype))
3088 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3089 || ada_is_array_descriptor_type (atype));
3091 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3092 && !ada_is_array_descriptor_type (atype));
3094 case TYPE_CODE_UNION:
3096 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3100 /* Return non-zero if the formals of FUNC "sufficiently match" the
3101 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3102 may also be an enumeral, in which case it is treated as a 0-
3103 argument function. */
3106 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3109 struct type *func_type = SYMBOL_TYPE (func);
3111 if (SYMBOL_CLASS (func) == LOC_CONST
3112 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3113 return (n_actuals == 0);
3114 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3117 if (TYPE_NFIELDS (func_type) != n_actuals)
3120 for (i = 0; i < n_actuals; i += 1)
3122 if (actuals[i] == NULL)
3126 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type, i));
3127 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3129 if (!ada_type_match (ftype, atype, 1))
3136 /* False iff function type FUNC_TYPE definitely does not produce a value
3137 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3138 FUNC_TYPE is not a valid function type with a non-null return type
3139 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3142 return_match (struct type *func_type, struct type *context_type)
3144 struct type *return_type;
3146 if (func_type == NULL)
3149 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3150 return_type = base_type (TYPE_TARGET_TYPE (func_type));
3152 return_type = base_type (func_type);
3153 if (return_type == NULL)
3156 context_type = base_type (context_type);
3158 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3159 return context_type == NULL || return_type == context_type;
3160 else if (context_type == NULL)
3161 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3163 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3167 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3168 function (if any) that matches the types of the NARGS arguments in
3169 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3170 that returns that type, then eliminate matches that don't. If
3171 CONTEXT_TYPE is void and there is at least one match that does not
3172 return void, eliminate all matches that do.
3174 Asks the user if there is more than one match remaining. Returns -1
3175 if there is no such symbol or none is selected. NAME is used
3176 solely for messages. May re-arrange and modify SYMS in
3177 the process; the index returned is for the modified vector. */
3180 ada_resolve_function (struct ada_symbol_info syms[],
3181 int nsyms, struct value **args, int nargs,
3182 const char *name, struct type *context_type)
3185 int m; /* Number of hits */
3186 struct type *fallback;
3187 struct type *return_type;
3189 return_type = context_type;
3190 if (context_type == NULL)
3191 fallback = builtin_type_void;
3198 for (k = 0; k < nsyms; k += 1)
3200 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
3202 if (ada_args_match (syms[k].sym, args, nargs)
3203 && return_match (type, return_type))
3209 if (m > 0 || return_type == fallback)
3212 return_type = fallback;
3219 printf_filtered (_("Multiple matches for %s\n"), name);
3220 user_select_syms (syms, m, 1);
3226 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3227 in a listing of choices during disambiguation (see sort_choices, below).
3228 The idea is that overloadings of a subprogram name from the
3229 same package should sort in their source order. We settle for ordering
3230 such symbols by their trailing number (__N or $N). */
3233 encoded_ordered_before (char *N0, char *N1)
3237 else if (N0 == NULL)
3242 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3244 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3246 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3247 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3251 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3254 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3256 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3257 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3259 return (strcmp (N0, N1) < 0);
3263 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3267 sort_choices (struct ada_symbol_info syms[], int nsyms)
3270 for (i = 1; i < nsyms; i += 1)
3272 struct ada_symbol_info sym = syms[i];
3275 for (j = i - 1; j >= 0; j -= 1)
3277 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3278 SYMBOL_LINKAGE_NAME (sym.sym)))
3280 syms[j + 1] = syms[j];
3286 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3287 by asking the user (if necessary), returning the number selected,
3288 and setting the first elements of SYMS items. Error if no symbols
3291 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3292 to be re-integrated one of these days. */
3295 user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
3298 int *chosen = (int *) alloca (sizeof (int) * nsyms);
3300 int first_choice = (max_results == 1) ? 1 : 2;
3301 const char *select_mode = multiple_symbols_select_mode ();
3303 if (max_results < 1)
3304 error (_("Request to select 0 symbols!"));
3308 if (select_mode == multiple_symbols_cancel)
3310 canceled because the command is ambiguous\n\
3311 See set/show multiple-symbol."));
3313 /* If select_mode is "all", then return all possible symbols.
3314 Only do that if more than one symbol can be selected, of course.
3315 Otherwise, display the menu as usual. */
3316 if (select_mode == multiple_symbols_all && max_results > 1)
3319 printf_unfiltered (_("[0] cancel\n"));
3320 if (max_results > 1)
3321 printf_unfiltered (_("[1] all\n"));
3323 sort_choices (syms, nsyms);
3325 for (i = 0; i < nsyms; i += 1)
3327 if (syms[i].sym == NULL)
3330 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3332 struct symtab_and_line sal =
3333 find_function_start_sal (syms[i].sym, 1);
3334 if (sal.symtab == NULL)
3335 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3337 SYMBOL_PRINT_NAME (syms[i].sym),
3340 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3341 SYMBOL_PRINT_NAME (syms[i].sym),
3342 sal.symtab->filename, sal.line);
3348 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3349 && SYMBOL_TYPE (syms[i].sym) != NULL
3350 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
3351 struct symtab *symtab = symtab_for_sym (syms[i].sym);
3353 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
3354 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3356 SYMBOL_PRINT_NAME (syms[i].sym),
3357 symtab->filename, SYMBOL_LINE (syms[i].sym));
3358 else if (is_enumeral
3359 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
3361 printf_unfiltered (("[%d] "), i + first_choice);
3362 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
3364 printf_unfiltered (_("'(%s) (enumeral)\n"),
3365 SYMBOL_PRINT_NAME (syms[i].sym));
3367 else if (symtab != NULL)
3368 printf_unfiltered (is_enumeral
3369 ? _("[%d] %s in %s (enumeral)\n")
3370 : _("[%d] %s at %s:?\n"),
3372 SYMBOL_PRINT_NAME (syms[i].sym),
3375 printf_unfiltered (is_enumeral
3376 ? _("[%d] %s (enumeral)\n")
3377 : _("[%d] %s at ?\n"),
3379 SYMBOL_PRINT_NAME (syms[i].sym));
3383 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3386 for (i = 0; i < n_chosen; i += 1)
3387 syms[i] = syms[chosen[i]];
3392 /* Read and validate a set of numeric choices from the user in the
3393 range 0 .. N_CHOICES-1. Place the results in increasing
3394 order in CHOICES[0 .. N-1], and return N.
3396 The user types choices as a sequence of numbers on one line
3397 separated by blanks, encoding them as follows:
3399 + A choice of 0 means to cancel the selection, throwing an error.
3400 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3401 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3403 The user is not allowed to choose more than MAX_RESULTS values.
3405 ANNOTATION_SUFFIX, if present, is used to annotate the input
3406 prompts (for use with the -f switch). */
3409 get_selections (int *choices, int n_choices, int max_results,
3410 int is_all_choice, char *annotation_suffix)
3415 int first_choice = is_all_choice ? 2 : 1;
3417 prompt = getenv ("PS2");
3421 args = command_line_input (prompt, 0, annotation_suffix);
3424 error_no_arg (_("one or more choice numbers"));
3428 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3429 order, as given in args. Choices are validated. */
3435 while (isspace (*args))
3437 if (*args == '\0' && n_chosen == 0)
3438 error_no_arg (_("one or more choice numbers"));
3439 else if (*args == '\0')
3442 choice = strtol (args, &args2, 10);
3443 if (args == args2 || choice < 0
3444 || choice > n_choices + first_choice - 1)
3445 error (_("Argument must be choice number"));
3449 error (_("cancelled"));
3451 if (choice < first_choice)
3453 n_chosen = n_choices;
3454 for (j = 0; j < n_choices; j += 1)
3458 choice -= first_choice;
3460 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3464 if (j < 0 || choice != choices[j])
3467 for (k = n_chosen - 1; k > j; k -= 1)
3468 choices[k + 1] = choices[k];
3469 choices[j + 1] = choice;
3474 if (n_chosen > max_results)
3475 error (_("Select no more than %d of the above"), max_results);
3480 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3481 on the function identified by SYM and BLOCK, and taking NARGS
3482 arguments. Update *EXPP as needed to hold more space. */
3485 replace_operator_with_call (struct expression **expp, int pc, int nargs,
3486 int oplen, struct symbol *sym,
3487 struct block *block)
3489 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3490 symbol, -oplen for operator being replaced). */
3491 struct expression *newexp = (struct expression *)
3492 xmalloc (sizeof (struct expression)
3493 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
3494 struct expression *exp = *expp;
3496 newexp->nelts = exp->nelts + 7 - oplen;
3497 newexp->language_defn = exp->language_defn;
3498 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
3499 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
3500 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
3502 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3503 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3505 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3506 newexp->elts[pc + 4].block = block;
3507 newexp->elts[pc + 5].symbol = sym;
3513 /* Type-class predicates */
3515 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3519 numeric_type_p (struct type *type)
3525 switch (TYPE_CODE (type))
3530 case TYPE_CODE_RANGE:
3531 return (type == TYPE_TARGET_TYPE (type)
3532 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3539 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3542 integer_type_p (struct type *type)
3548 switch (TYPE_CODE (type))
3552 case TYPE_CODE_RANGE:
3553 return (type == TYPE_TARGET_TYPE (type)
3554 || integer_type_p (TYPE_TARGET_TYPE (type)));
3561 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3564 scalar_type_p (struct type *type)
3570 switch (TYPE_CODE (type))
3573 case TYPE_CODE_RANGE:
3574 case TYPE_CODE_ENUM:
3583 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3586 discrete_type_p (struct type *type)
3592 switch (TYPE_CODE (type))
3595 case TYPE_CODE_RANGE:
3596 case TYPE_CODE_ENUM:
3604 /* Returns non-zero if OP with operands in the vector ARGS could be
3605 a user-defined function. Errs on the side of pre-defined operators
3606 (i.e., result 0). */
3609 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3611 struct type *type0 =
3612 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3613 struct type *type1 =
3614 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3628 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3632 case BINOP_BITWISE_AND:
3633 case BINOP_BITWISE_IOR:
3634 case BINOP_BITWISE_XOR:
3635 return (!(integer_type_p (type0) && integer_type_p (type1)));
3638 case BINOP_NOTEQUAL:
3643 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3646 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
3649 return (!(numeric_type_p (type0) && integer_type_p (type1)));
3653 case UNOP_LOGICAL_NOT:
3655 return (!numeric_type_p (type0));
3664 1. In the following, we assume that a renaming type's name may
3665 have an ___XD suffix. It would be nice if this went away at some
3667 2. We handle both the (old) purely type-based representation of
3668 renamings and the (new) variable-based encoding. At some point,
3669 it is devoutly to be hoped that the former goes away
3670 (FIXME: hilfinger-2007-07-09).
3671 3. Subprogram renamings are not implemented, although the XRS
3672 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3674 /* If SYM encodes a renaming,
3676 <renaming> renames <renamed entity>,
3678 sets *LEN to the length of the renamed entity's name,
3679 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3680 the string describing the subcomponent selected from the renamed
3681 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3682 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3683 are undefined). Otherwise, returns a value indicating the category
3684 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3685 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3686 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3687 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3688 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3689 may be NULL, in which case they are not assigned.
3691 [Currently, however, GCC does not generate subprogram renamings.] */
3693 enum ada_renaming_category
3694 ada_parse_renaming (struct symbol *sym,
3695 const char **renamed_entity, int *len,
3696 const char **renaming_expr)
3698 enum ada_renaming_category kind;
3703 return ADA_NOT_RENAMING;
3704 switch (SYMBOL_CLASS (sym))
3707 return ADA_NOT_RENAMING;
3709 return parse_old_style_renaming (SYMBOL_TYPE (sym),
3710 renamed_entity, len, renaming_expr);
3714 case LOC_OPTIMIZED_OUT:
3715 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
3717 return ADA_NOT_RENAMING;
3721 kind = ADA_OBJECT_RENAMING;
3725 kind = ADA_EXCEPTION_RENAMING;
3729 kind = ADA_PACKAGE_RENAMING;
3733 kind = ADA_SUBPROGRAM_RENAMING;
3737 return ADA_NOT_RENAMING;
3741 if (renamed_entity != NULL)
3742 *renamed_entity = info;
3743 suffix = strstr (info, "___XE");
3744 if (suffix == NULL || suffix == info)
3745 return ADA_NOT_RENAMING;
3747 *len = strlen (info) - strlen (suffix);
3749 if (renaming_expr != NULL)
3750 *renaming_expr = suffix;
3754 /* Assuming TYPE encodes a renaming according to the old encoding in
3755 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3756 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3757 ADA_NOT_RENAMING otherwise. */
3758 static enum ada_renaming_category
3759 parse_old_style_renaming (struct type *type,
3760 const char **renamed_entity, int *len,
3761 const char **renaming_expr)
3763 enum ada_renaming_category kind;
3768 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
3769 || TYPE_NFIELDS (type) != 1)
3770 return ADA_NOT_RENAMING;
3772 name = type_name_no_tag (type);
3774 return ADA_NOT_RENAMING;
3776 name = strstr (name, "___XR");
3778 return ADA_NOT_RENAMING;
3783 kind = ADA_OBJECT_RENAMING;
3786 kind = ADA_EXCEPTION_RENAMING;
3789 kind = ADA_PACKAGE_RENAMING;
3792 kind = ADA_SUBPROGRAM_RENAMING;
3795 return ADA_NOT_RENAMING;
3798 info = TYPE_FIELD_NAME (type, 0);
3800 return ADA_NOT_RENAMING;
3801 if (renamed_entity != NULL)
3802 *renamed_entity = info;
3803 suffix = strstr (info, "___XE");
3804 if (renaming_expr != NULL)
3805 *renaming_expr = suffix + 5;
3806 if (suffix == NULL || suffix == info)
3807 return ADA_NOT_RENAMING;
3809 *len = suffix - info;
3815 /* Evaluation: Function Calls */
3817 /* Return an lvalue containing the value VAL. This is the identity on
3818 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3819 on the stack, using and updating *SP as the stack pointer, and
3820 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3822 static struct value *
3823 ensure_lval (struct value *val, CORE_ADDR *sp)
3825 if (! VALUE_LVAL (val))
3827 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
3829 /* The following is taken from the structure-return code in
3830 call_function_by_hand. FIXME: Therefore, some refactoring seems
3832 if (gdbarch_inner_than (current_gdbarch, 1, 2))
3834 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3835 reserving sufficient space. */
3837 if (gdbarch_frame_align_p (current_gdbarch))
3838 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3839 VALUE_ADDRESS (val) = *sp;
3843 /* Stack grows upward. Align the frame, allocate space, and
3844 then again, re-align the frame. */
3845 if (gdbarch_frame_align_p (current_gdbarch))
3846 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3847 VALUE_ADDRESS (val) = *sp;
3849 if (gdbarch_frame_align_p (current_gdbarch))
3850 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3852 VALUE_LVAL (val) = lval_memory;
3854 write_memory (VALUE_ADDRESS (val), value_contents_raw (val), len);
3860 /* Return the value ACTUAL, converted to be an appropriate value for a
3861 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3862 allocating any necessary descriptors (fat pointers), or copies of
3863 values not residing in memory, updating it as needed. */
3866 ada_convert_actual (struct value *actual, struct type *formal_type0,
3869 struct type *actual_type = ada_check_typedef (value_type (actual));
3870 struct type *formal_type = ada_check_typedef (formal_type0);
3871 struct type *formal_target =
3872 TYPE_CODE (formal_type) == TYPE_CODE_PTR
3873 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
3874 struct type *actual_target =
3875 TYPE_CODE (actual_type) == TYPE_CODE_PTR
3876 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
3878 if (ada_is_array_descriptor_type (formal_target)
3879 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
3880 return make_array_descriptor (formal_type, actual, sp);
3881 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
3882 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
3884 struct value *result;
3885 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
3886 && ada_is_array_descriptor_type (actual_target))
3887 result = desc_data (actual);
3888 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
3890 if (VALUE_LVAL (actual) != lval_memory)
3893 actual_type = ada_check_typedef (value_type (actual));
3894 val = allocate_value (actual_type);
3895 memcpy ((char *) value_contents_raw (val),
3896 (char *) value_contents (actual),
3897 TYPE_LENGTH (actual_type));
3898 actual = ensure_lval (val, sp);
3900 result = value_addr (actual);
3904 return value_cast_pointers (formal_type, result);
3906 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
3907 return ada_value_ind (actual);
3913 /* Push a descriptor of type TYPE for array value ARR on the stack at
3914 *SP, updating *SP to reflect the new descriptor. Return either
3915 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3916 to-descriptor type rather than a descriptor type), a struct value *
3917 representing a pointer to this descriptor. */
3919 static struct value *
3920 make_array_descriptor (struct type *type, struct value *arr, CORE_ADDR *sp)
3922 struct type *bounds_type = desc_bounds_type (type);
3923 struct type *desc_type = desc_base_type (type);
3924 struct value *descriptor = allocate_value (desc_type);
3925 struct value *bounds = allocate_value (bounds_type);
3928 for (i = ada_array_arity (ada_check_typedef (value_type (arr))); i > 0; i -= 1)
3930 modify_general_field (value_contents_writeable (bounds),
3931 value_as_long (ada_array_bound (arr, i, 0)),
3932 desc_bound_bitpos (bounds_type, i, 0),
3933 desc_bound_bitsize (bounds_type, i, 0));
3934 modify_general_field (value_contents_writeable (bounds),
3935 value_as_long (ada_array_bound (arr, i, 1)),
3936 desc_bound_bitpos (bounds_type, i, 1),
3937 desc_bound_bitsize (bounds_type, i, 1));
3940 bounds = ensure_lval (bounds, sp);
3942 modify_general_field (value_contents_writeable (descriptor),
3943 VALUE_ADDRESS (ensure_lval (arr, sp)),
3944 fat_pntr_data_bitpos (desc_type),
3945 fat_pntr_data_bitsize (desc_type));
3947 modify_general_field (value_contents_writeable (descriptor),
3948 VALUE_ADDRESS (bounds),
3949 fat_pntr_bounds_bitpos (desc_type),
3950 fat_pntr_bounds_bitsize (desc_type));
3952 descriptor = ensure_lval (descriptor, sp);
3954 if (TYPE_CODE (type) == TYPE_CODE_PTR)
3955 return value_addr (descriptor);
3960 /* Dummy definitions for an experimental caching module that is not
3961 * used in the public sources. */
3964 lookup_cached_symbol (const char *name, domain_enum namespace,
3965 struct symbol **sym, struct block **block)
3971 cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
3972 struct block *block)
3978 /* Return the result of a standard (literal, C-like) lookup of NAME in
3979 given DOMAIN, visible from lexical block BLOCK. */
3981 static struct symbol *
3982 standard_lookup (const char *name, const struct block *block,
3987 if (lookup_cached_symbol (name, domain, &sym, NULL))
3989 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
3990 cache_symbol (name, domain, sym, block_found);
3995 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3996 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3997 since they contend in overloading in the same way. */
3999 is_nonfunction (struct ada_symbol_info syms[], int n)
4003 for (i = 0; i < n; i += 1)
4004 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4005 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4006 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
4012 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4013 struct types. Otherwise, they may not. */
4016 equiv_types (struct type *type0, struct type *type1)
4020 if (type0 == NULL || type1 == NULL
4021 || TYPE_CODE (type0) != TYPE_CODE (type1))
4023 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4024 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4025 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4026 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4032 /* True iff SYM0 represents the same entity as SYM1, or one that is
4033 no more defined than that of SYM1. */
4036 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4040 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4041 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4044 switch (SYMBOL_CLASS (sym0))
4050 struct type *type0 = SYMBOL_TYPE (sym0);
4051 struct type *type1 = SYMBOL_TYPE (sym1);
4052 char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4053 char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4054 int len0 = strlen (name0);
4056 TYPE_CODE (type0) == TYPE_CODE (type1)
4057 && (equiv_types (type0, type1)
4058 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4059 && strncmp (name1 + len0, "___XV", 5) == 0));
4062 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4063 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4069 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4070 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4073 add_defn_to_vec (struct obstack *obstackp,
4075 struct block *block)
4079 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
4081 /* Do not try to complete stub types, as the debugger is probably
4082 already scanning all symbols matching a certain name at the
4083 time when this function is called. Trying to replace the stub
4084 type by its associated full type will cause us to restart a scan
4085 which may lead to an infinite recursion. Instead, the client
4086 collecting the matching symbols will end up collecting several
4087 matches, with at least one of them complete. It can then filter
4088 out the stub ones if needed. */
4090 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4092 if (lesseq_defined_than (sym, prevDefns[i].sym))
4094 else if (lesseq_defined_than (prevDefns[i].sym, sym))
4096 prevDefns[i].sym = sym;
4097 prevDefns[i].block = block;
4103 struct ada_symbol_info info;
4107 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4111 /* Number of ada_symbol_info structures currently collected in
4112 current vector in *OBSTACKP. */
4115 num_defns_collected (struct obstack *obstackp)
4117 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4120 /* Vector of ada_symbol_info structures currently collected in current
4121 vector in *OBSTACKP. If FINISH, close off the vector and return
4122 its final address. */
4124 static struct ada_symbol_info *
4125 defns_collected (struct obstack *obstackp, int finish)
4128 return obstack_finish (obstackp);
4130 return (struct ada_symbol_info *) obstack_base (obstackp);
4133 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
4134 Check the global symbols if GLOBAL, the static symbols if not.
4135 Do wild-card match if WILD. */
4137 static struct partial_symbol *
4138 ada_lookup_partial_symbol (struct partial_symtab *pst, const char *name,
4139 int global, domain_enum namespace, int wild)
4141 struct partial_symbol **start;
4142 int name_len = strlen (name);
4143 int length = (global ? pst->n_global_syms : pst->n_static_syms);
4152 pst->objfile->global_psymbols.list + pst->globals_offset :
4153 pst->objfile->static_psymbols.list + pst->statics_offset);
4157 for (i = 0; i < length; i += 1)
4159 struct partial_symbol *psym = start[i];
4161 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
4162 SYMBOL_DOMAIN (psym), namespace)
4163 && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (psym)))
4177 int M = (U + i) >> 1;
4178 struct partial_symbol *psym = start[M];
4179 if (SYMBOL_LINKAGE_NAME (psym)[0] < name[0])
4181 else if (SYMBOL_LINKAGE_NAME (psym)[0] > name[0])
4183 else if (strcmp (SYMBOL_LINKAGE_NAME (psym), name) < 0)
4194 struct partial_symbol *psym = start[i];
4196 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
4197 SYMBOL_DOMAIN (psym), namespace))
4199 int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym), name_len);
4207 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)
4221 int M = (U + i) >> 1;
4222 struct partial_symbol *psym = start[M];
4223 if (SYMBOL_LINKAGE_NAME (psym)[0] < '_')
4225 else if (SYMBOL_LINKAGE_NAME (psym)[0] > '_')
4227 else if (strcmp (SYMBOL_LINKAGE_NAME (psym), "_ada_") < 0)
4238 struct partial_symbol *psym = start[i];
4240 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
4241 SYMBOL_DOMAIN (psym), namespace))
4245 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym)[0];
4248 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym), 5);
4250 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym) + 5,
4260 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)
4270 /* Find a symbol table containing symbol SYM or NULL if none. */
4272 static struct symtab *
4273 symtab_for_sym (struct symbol *sym)
4276 struct objfile *objfile;
4278 struct symbol *tmp_sym;
4279 struct dict_iterator iter;
4282 ALL_PRIMARY_SYMTABS (objfile, s)
4284 switch (SYMBOL_CLASS (sym))
4292 case LOC_CONST_BYTES:
4293 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
4294 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4296 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
4297 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4303 switch (SYMBOL_CLASS (sym))
4308 case LOC_REGPARM_ADDR:
4312 for (j = FIRST_LOCAL_BLOCK;
4313 j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s)); j += 1)
4315 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), j);
4316 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4327 /* Return a minimal symbol matching NAME according to Ada decoding
4328 rules. Returns NULL if there is no such minimal symbol. Names
4329 prefixed with "standard__" are handled specially: "standard__" is
4330 first stripped off, and only static and global symbols are searched. */
4332 struct minimal_symbol *
4333 ada_lookup_simple_minsym (const char *name)
4335 struct objfile *objfile;
4336 struct minimal_symbol *msymbol;
4339 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
4341 name += sizeof ("standard__") - 1;
4345 wild_match = (strstr (name, "__") == NULL);
4347 ALL_MSYMBOLS (objfile, msymbol)
4349 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match)
4350 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4357 /* For all subprograms that statically enclose the subprogram of the
4358 selected frame, add symbols matching identifier NAME in DOMAIN
4359 and their blocks to the list of data in OBSTACKP, as for
4360 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4364 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4365 const char *name, domain_enum namespace,
4370 /* True if TYPE is definitely an artificial type supplied to a symbol
4371 for which no debugging information was given in the symbol file. */
4374 is_nondebugging_type (struct type *type)
4376 char *name = ada_type_name (type);
4377 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4380 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4381 duplicate other symbols in the list (The only case I know of where
4382 this happens is when object files containing stabs-in-ecoff are
4383 linked with files containing ordinary ecoff debugging symbols (or no
4384 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4385 Returns the number of items in the modified list. */
4388 remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4395 if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
4396 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4397 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4399 for (j = 0; j < nsyms; j += 1)
4402 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4403 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4404 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
4405 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4406 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4407 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
4410 for (k = i + 1; k < nsyms; k += 1)
4411 syms[k - 1] = syms[k];
4424 /* Given a type that corresponds to a renaming entity, use the type name
4425 to extract the scope (package name or function name, fully qualified,
4426 and following the GNAT encoding convention) where this renaming has been
4427 defined. The string returned needs to be deallocated after use. */
4430 xget_renaming_scope (struct type *renaming_type)
4432 /* The renaming types adhere to the following convention:
4433 <scope>__<rename>___<XR extension>.
4434 So, to extract the scope, we search for the "___XR" extension,
4435 and then backtrack until we find the first "__". */
4437 const char *name = type_name_no_tag (renaming_type);
4438 char *suffix = strstr (name, "___XR");
4443 /* Now, backtrack a bit until we find the first "__". Start looking
4444 at suffix - 3, as the <rename> part is at least one character long. */
4446 for (last = suffix - 3; last > name; last--)
4447 if (last[0] == '_' && last[1] == '_')
4450 /* Make a copy of scope and return it. */
4452 scope_len = last - name;
4453 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
4455 strncpy (scope, name, scope_len);
4456 scope[scope_len] = '\0';
4461 /* Return nonzero if NAME corresponds to a package name. */
4464 is_package_name (const char *name)
4466 /* Here, We take advantage of the fact that no symbols are generated
4467 for packages, while symbols are generated for each function.
4468 So the condition for NAME represent a package becomes equivalent
4469 to NAME not existing in our list of symbols. There is only one
4470 small complication with library-level functions (see below). */
4474 /* If it is a function that has not been defined at library level,
4475 then we should be able to look it up in the symbols. */
4476 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4479 /* Library-level function names start with "_ada_". See if function
4480 "_ada_" followed by NAME can be found. */
4482 /* Do a quick check that NAME does not contain "__", since library-level
4483 functions names cannot contain "__" in them. */
4484 if (strstr (name, "__") != NULL)
4487 fun_name = xstrprintf ("_ada_%s", name);
4489 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4492 /* Return nonzero if SYM corresponds to a renaming entity that is
4493 not visible from FUNCTION_NAME. */
4496 old_renaming_is_invisible (const struct symbol *sym, char *function_name)
4500 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4503 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
4505 make_cleanup (xfree, scope);
4507 /* If the rename has been defined in a package, then it is visible. */
4508 if (is_package_name (scope))
4511 /* Check that the rename is in the current function scope by checking
4512 that its name starts with SCOPE. */
4514 /* If the function name starts with "_ada_", it means that it is
4515 a library-level function. Strip this prefix before doing the
4516 comparison, as the encoding for the renaming does not contain
4518 if (strncmp (function_name, "_ada_", 5) == 0)
4521 return (strncmp (function_name, scope, strlen (scope)) != 0);
4524 /* Remove entries from SYMS that corresponds to a renaming entity that
4525 is not visible from the function associated with CURRENT_BLOCK or
4526 that is superfluous due to the presence of more specific renaming
4527 information. Places surviving symbols in the initial entries of
4528 SYMS and returns the number of surviving symbols.
4531 First, in cases where an object renaming is implemented as a
4532 reference variable, GNAT may produce both the actual reference
4533 variable and the renaming encoding. In this case, we discard the
4536 Second, GNAT emits a type following a specified encoding for each renaming
4537 entity. Unfortunately, STABS currently does not support the definition
4538 of types that are local to a given lexical block, so all renamings types
4539 are emitted at library level. As a consequence, if an application
4540 contains two renaming entities using the same name, and a user tries to
4541 print the value of one of these entities, the result of the ada symbol
4542 lookup will also contain the wrong renaming type.
4544 This function partially covers for this limitation by attempting to
4545 remove from the SYMS list renaming symbols that should be visible
4546 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4547 method with the current information available. The implementation
4548 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4550 - When the user tries to print a rename in a function while there
4551 is another rename entity defined in a package: Normally, the
4552 rename in the function has precedence over the rename in the
4553 package, so the latter should be removed from the list. This is
4554 currently not the case.
4556 - This function will incorrectly remove valid renames if
4557 the CURRENT_BLOCK corresponds to a function which symbol name
4558 has been changed by an "Export" pragma. As a consequence,
4559 the user will be unable to print such rename entities. */
4562 remove_irrelevant_renamings (struct ada_symbol_info *syms,
4563 int nsyms, const struct block *current_block)
4565 struct symbol *current_function;
4566 char *current_function_name;
4568 int is_new_style_renaming;
4570 /* If there is both a renaming foo___XR... encoded as a variable and
4571 a simple variable foo in the same block, discard the latter.
4572 First, zero out such symbols, then compress. */
4573 is_new_style_renaming = 0;
4574 for (i = 0; i < nsyms; i += 1)
4576 struct symbol *sym = syms[i].sym;
4577 struct block *block = syms[i].block;
4581 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4583 name = SYMBOL_LINKAGE_NAME (sym);
4584 suffix = strstr (name, "___XR");
4588 int name_len = suffix - name;
4590 is_new_style_renaming = 1;
4591 for (j = 0; j < nsyms; j += 1)
4592 if (i != j && syms[j].sym != NULL
4593 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
4595 && block == syms[j].block)
4599 if (is_new_style_renaming)
4603 for (j = k = 0; j < nsyms; j += 1)
4604 if (syms[j].sym != NULL)
4612 /* Extract the function name associated to CURRENT_BLOCK.
4613 Abort if unable to do so. */
4615 if (current_block == NULL)
4618 current_function = block_linkage_function (current_block);
4619 if (current_function == NULL)
4622 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4623 if (current_function_name == NULL)
4626 /* Check each of the symbols, and remove it from the list if it is
4627 a type corresponding to a renaming that is out of the scope of
4628 the current block. */
4633 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
4634 == ADA_OBJECT_RENAMING
4635 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4638 for (j = i + 1; j < nsyms; j += 1)
4639 syms[j - 1] = syms[j];
4649 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4650 scope and in global scopes, returning the number of matches. Sets
4651 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4652 indicating the symbols found and the blocks and symbol tables (if
4653 any) in which they were found. This vector are transient---good only to
4654 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4655 symbol match within the nest of blocks whose innermost member is BLOCK0,
4656 is the one match returned (no other matches in that or
4657 enclosing blocks is returned). If there are any matches in or
4658 surrounding BLOCK0, then these alone are returned. Otherwise, the
4659 search extends to global and file-scope (static) symbol tables.
4660 Names prefixed with "standard__" are handled specially: "standard__"
4661 is first stripped off, and only static and global symbols are searched. */
4664 ada_lookup_symbol_list (const char *name0, const struct block *block0,
4665 domain_enum namespace,
4666 struct ada_symbol_info **results)
4670 struct partial_symtab *ps;
4671 struct blockvector *bv;
4672 struct objfile *objfile;
4673 struct block *block;
4675 struct minimal_symbol *msymbol;
4681 obstack_free (&symbol_list_obstack, NULL);
4682 obstack_init (&symbol_list_obstack);
4686 /* Search specified block and its superiors. */
4688 wild_match = (strstr (name0, "__") == NULL);
4690 block = (struct block *) block0; /* FIXME: No cast ought to be
4691 needed, but adding const will
4692 have a cascade effect. */
4693 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
4697 name = name0 + sizeof ("standard__") - 1;
4701 while (block != NULL)
4704 ada_add_block_symbols (&symbol_list_obstack, block, name,
4705 namespace, NULL, wild_match);
4707 /* If we found a non-function match, assume that's the one. */
4708 if (is_nonfunction (defns_collected (&symbol_list_obstack, 0),
4709 num_defns_collected (&symbol_list_obstack)))
4712 block = BLOCK_SUPERBLOCK (block);
4715 /* If no luck so far, try to find NAME as a local symbol in some lexically
4716 enclosing subprogram. */
4717 if (num_defns_collected (&symbol_list_obstack) == 0 && block_depth > 2)
4718 add_symbols_from_enclosing_procs (&symbol_list_obstack,
4719 name, namespace, wild_match);
4721 /* If we found ANY matches among non-global symbols, we're done. */
4723 if (num_defns_collected (&symbol_list_obstack) > 0)
4727 if (lookup_cached_symbol (name0, namespace, &sym, &block))
4730 add_defn_to_vec (&symbol_list_obstack, sym, block);
4734 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4735 tables, and psymtab's. */
4737 ALL_PRIMARY_SYMTABS (objfile, s)
4740 bv = BLOCKVECTOR (s);
4741 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4742 ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
4743 objfile, wild_match);
4746 if (namespace == VAR_DOMAIN)
4748 ALL_MSYMBOLS (objfile, msymbol)
4750 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match))
4752 switch (MSYMBOL_TYPE (msymbol))
4754 case mst_solib_trampoline:
4757 s = find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol));
4760 int ndefns0 = num_defns_collected (&symbol_list_obstack);
4762 bv = BLOCKVECTOR (s);
4763 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4764 ada_add_block_symbols (&symbol_list_obstack, block,
4765 SYMBOL_LINKAGE_NAME (msymbol),
4766 namespace, objfile, wild_match);
4768 if (num_defns_collected (&symbol_list_obstack) == ndefns0)
4770 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
4771 ada_add_block_symbols (&symbol_list_obstack, block,
4772 SYMBOL_LINKAGE_NAME (msymbol),
4782 ALL_PSYMTABS (objfile, ps)
4786 && ada_lookup_partial_symbol (ps, name, 1, namespace, wild_match))
4788 s = PSYMTAB_TO_SYMTAB (ps);
4791 bv = BLOCKVECTOR (s);
4792 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4793 ada_add_block_symbols (&symbol_list_obstack, block, name,
4794 namespace, objfile, wild_match);
4798 /* Now add symbols from all per-file blocks if we've gotten no hits
4799 (Not strictly correct, but perhaps better than an error).
4800 Do the symtabs first, then check the psymtabs. */
4802 if (num_defns_collected (&symbol_list_obstack) == 0)
4805 ALL_PRIMARY_SYMTABS (objfile, s)
4808 bv = BLOCKVECTOR (s);
4809 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
4810 ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
4811 objfile, wild_match);
4814 ALL_PSYMTABS (objfile, ps)
4818 && ada_lookup_partial_symbol (ps, name, 0, namespace, wild_match))
4820 s = PSYMTAB_TO_SYMTAB (ps);
4821 bv = BLOCKVECTOR (s);
4824 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
4825 ada_add_block_symbols (&symbol_list_obstack, block, name,
4826 namespace, objfile, wild_match);
4832 ndefns = num_defns_collected (&symbol_list_obstack);
4833 *results = defns_collected (&symbol_list_obstack, 1);
4835 ndefns = remove_extra_symbols (*results, ndefns);
4838 cache_symbol (name0, namespace, NULL, NULL);
4840 if (ndefns == 1 && cacheIfUnique)
4841 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
4843 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
4849 ada_lookup_encoded_symbol (const char *name, const struct block *block0,
4850 domain_enum namespace, struct block **block_found)
4852 struct ada_symbol_info *candidates;
4855 n_candidates = ada_lookup_symbol_list (name, block0, namespace, &candidates);
4857 if (n_candidates == 0)
4860 if (block_found != NULL)
4861 *block_found = candidates[0].block;
4863 return fixup_symbol_section (candidates[0].sym, NULL);
4866 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4867 scope and in global scopes, or NULL if none. NAME is folded and
4868 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4869 choosing the first symbol if there are multiple choices.
4870 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4871 table in which the symbol was found (in both cases, these
4872 assignments occur only if the pointers are non-null). */
4874 ada_lookup_symbol (const char *name, const struct block *block0,
4875 domain_enum namespace, int *is_a_field_of_this)
4877 if (is_a_field_of_this != NULL)
4878 *is_a_field_of_this = 0;
4881 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
4882 block0, namespace, NULL);
4885 static struct symbol *
4886 ada_lookup_symbol_nonlocal (const char *name,
4887 const char *linkage_name,
4888 const struct block *block,
4889 const domain_enum domain)
4891 if (linkage_name == NULL)
4892 linkage_name = name;
4893 return ada_lookup_symbol (linkage_name, block_static_block (block), domain,
4898 /* True iff STR is a possible encoded suffix of a normal Ada name
4899 that is to be ignored for matching purposes. Suffixes of parallel
4900 names (e.g., XVE) are not included here. Currently, the possible suffixes
4901 are given by either of the regular expression:
4903 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
4904 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4905 _E[0-9]+[bs]$ [protected object entry suffixes]
4906 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4908 Also, any leading "__[0-9]+" sequence is skipped before the suffix
4909 match is performed. This sequence is used to differentiate homonyms,
4910 is an optional part of a valid name suffix. */
4913 is_name_suffix (const char *str)
4916 const char *matching;
4917 const int len = strlen (str);
4919 /* Skip optional leading __[0-9]+. */
4921 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
4924 while (isdigit (str[0]))
4930 if (str[0] == '.' || str[0] == '$')
4933 while (isdigit (matching[0]))
4935 if (matching[0] == '\0')
4941 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
4944 while (isdigit (matching[0]))
4946 if (matching[0] == '\0')
4951 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4952 with a N at the end. Unfortunately, the compiler uses the same
4953 convention for other internal types it creates. So treating
4954 all entity names that end with an "N" as a name suffix causes
4955 some regressions. For instance, consider the case of an enumerated
4956 type. To support the 'Image attribute, it creates an array whose
4958 Having a single character like this as a suffix carrying some
4959 information is a bit risky. Perhaps we should change the encoding
4960 to be something like "_N" instead. In the meantime, do not do
4961 the following check. */
4962 /* Protected Object Subprograms */
4963 if (len == 1 && str [0] == 'N')
4968 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
4971 while (isdigit (matching[0]))
4973 if ((matching[0] == 'b' || matching[0] == 's')
4974 && matching [1] == '\0')
4978 /* ??? We should not modify STR directly, as we are doing below. This
4979 is fine in this case, but may become problematic later if we find
4980 that this alternative did not work, and want to try matching
4981 another one from the begining of STR. Since we modified it, we
4982 won't be able to find the begining of the string anymore! */
4986 while (str[0] != '_' && str[0] != '\0')
4988 if (str[0] != 'n' && str[0] != 'b')
4994 if (str[0] == '\000')
4999 if (str[1] != '_' || str[2] == '\000')
5003 if (strcmp (str + 3, "JM") == 0)
5005 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5006 the LJM suffix in favor of the JM one. But we will
5007 still accept LJM as a valid suffix for a reasonable
5008 amount of time, just to allow ourselves to debug programs
5009 compiled using an older version of GNAT. */
5010 if (strcmp (str + 3, "LJM") == 0)
5014 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5015 || str[4] == 'U' || str[4] == 'P')
5017 if (str[4] == 'R' && str[5] != 'T')
5021 if (!isdigit (str[2]))
5023 for (k = 3; str[k] != '\0'; k += 1)
5024 if (!isdigit (str[k]) && str[k] != '_')
5028 if (str[0] == '$' && isdigit (str[1]))
5030 for (k = 2; str[k] != '\0'; k += 1)
5031 if (!isdigit (str[k]) && str[k] != '_')
5038 /* Return nonzero if the given string starts with a dot ('.')
5039 followed by zero or more digits.
5041 Note: brobecker/2003-11-10: A forward declaration has not been
5042 added at the begining of this file yet, because this function
5043 is only used to work around a problem found during wild matching
5044 when trying to match minimal symbol names against symbol names
5045 obtained from dwarf-2 data. This function is therefore currently
5046 only used in wild_match() and is likely to be deleted when the
5047 problem in dwarf-2 is fixed. */
5050 is_dot_digits_suffix (const char *str)
5056 while (isdigit (str[0]))
5058 return (str[0] == '\0');
5061 /* Return non-zero if the string starting at NAME and ending before
5062 NAME_END contains no capital letters. */
5065 is_valid_name_for_wild_match (const char *name0)
5067 const char *decoded_name = ada_decode (name0);
5070 for (i=0; decoded_name[i] != '\0'; i++)
5071 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5077 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
5078 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
5079 informational suffixes of NAME (i.e., for which is_name_suffix is
5083 wild_match (const char *patn0, int patn_len, const char *name0)
5090 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
5091 stored in the symbol table for nested function names is sometimes
5092 different from the name of the associated entity stored in
5093 the dwarf-2 data: This is the case for nested subprograms, where
5094 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
5095 while the symbol name from the dwarf-2 data does not.
5097 Although the DWARF-2 standard documents that entity names stored
5098 in the dwarf-2 data should be identical to the name as seen in
5099 the source code, GNAT takes a different approach as we already use
5100 a special encoding mechanism to convey the information so that
5101 a C debugger can still use the information generated to debug
5102 Ada programs. A corollary is that the symbol names in the dwarf-2
5103 data should match the names found in the symbol table. I therefore
5104 consider this issue as a compiler defect.
5106 Until the compiler is properly fixed, we work-around the problem
5107 by ignoring such suffixes during the match. We do so by making
5108 a copy of PATN0 and NAME0, and then by stripping such a suffix
5109 if present. We then perform the match on the resulting strings. */
5112 name_len = strlen (name0);
5114 name = name_start = (char *) alloca ((name_len + 1) * sizeof (char));
5115 strcpy (name, name0);
5116 dot = strrchr (name, '.');
5117 if (dot != NULL && is_dot_digits_suffix (dot))
5120 patn = (char *) alloca ((patn_len + 1) * sizeof (char));
5121 strncpy (patn, patn0, patn_len);
5122 patn[patn_len] = '\0';
5123 dot = strrchr (patn, '.');
5124 if (dot != NULL && is_dot_digits_suffix (dot))
5127 patn_len = dot - patn;
5131 /* Now perform the wild match. */
5133 name_len = strlen (name);
5134 if (name_len >= patn_len + 5 && strncmp (name, "_ada_", 5) == 0
5135 && strncmp (patn, name + 5, patn_len) == 0
5136 && is_name_suffix (name + patn_len + 5))
5139 while (name_len >= patn_len)
5141 if (strncmp (patn, name, patn_len) == 0
5142 && is_name_suffix (name + patn_len))
5143 return (name == name_start || is_valid_name_for_wild_match (name0));
5150 && name[0] != '.' && (name[0] != '_' || name[1] != '_'));
5155 if (!islower (name[2]))
5162 if (!islower (name[1]))
5173 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5174 vector *defn_symbols, updating the list of symbols in OBSTACKP
5175 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5176 OBJFILE is the section containing BLOCK.
5177 SYMTAB is recorded with each symbol added. */
5180 ada_add_block_symbols (struct obstack *obstackp,
5181 struct block *block, const char *name,
5182 domain_enum domain, struct objfile *objfile,
5185 struct dict_iterator iter;
5186 int name_len = strlen (name);
5187 /* A matching argument symbol, if any. */
5188 struct symbol *arg_sym;
5189 /* Set true when we find a matching non-argument symbol. */
5198 ALL_BLOCK_SYMBOLS (block, iter, sym)
5200 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5201 SYMBOL_DOMAIN (sym), domain)
5202 && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (sym)))
5204 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5206 else if (SYMBOL_IS_ARGUMENT (sym))
5211 add_defn_to_vec (obstackp,
5212 fixup_symbol_section (sym, objfile),
5220 ALL_BLOCK_SYMBOLS (block, iter, sym)
5222 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5223 SYMBOL_DOMAIN (sym), domain))
5225 int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym), name_len);
5227 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len))
5229 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5231 if (SYMBOL_IS_ARGUMENT (sym))
5236 add_defn_to_vec (obstackp,
5237 fixup_symbol_section (sym, objfile),
5246 if (!found_sym && arg_sym != NULL)
5248 add_defn_to_vec (obstackp,
5249 fixup_symbol_section (arg_sym, objfile),
5258 ALL_BLOCK_SYMBOLS (block, iter, sym)
5260 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5261 SYMBOL_DOMAIN (sym), domain))
5265 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5268 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5270 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5275 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5277 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5279 if (SYMBOL_IS_ARGUMENT (sym))
5284 add_defn_to_vec (obstackp,
5285 fixup_symbol_section (sym, objfile),
5293 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5294 They aren't parameters, right? */
5295 if (!found_sym && arg_sym != NULL)
5297 add_defn_to_vec (obstackp,
5298 fixup_symbol_section (arg_sym, objfile),
5305 /* Symbol Completion */
5307 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5308 name in a form that's appropriate for the completion. The result
5309 does not need to be deallocated, but is only good until the next call.
5311 TEXT_LEN is equal to the length of TEXT.
5312 Perform a wild match if WILD_MATCH is set.
5313 ENCODED should be set if TEXT represents the start of a symbol name
5314 in its encoded form. */
5317 symbol_completion_match (const char *sym_name,
5318 const char *text, int text_len,
5319 int wild_match, int encoded)
5322 const int verbatim_match = (text[0] == '<');
5327 /* Strip the leading angle bracket. */
5332 /* First, test against the fully qualified name of the symbol. */
5334 if (strncmp (sym_name, text, text_len) == 0)
5337 if (match && !encoded)
5339 /* One needed check before declaring a positive match is to verify
5340 that iff we are doing a verbatim match, the decoded version
5341 of the symbol name starts with '<'. Otherwise, this symbol name
5342 is not a suitable completion. */
5343 const char *sym_name_copy = sym_name;
5344 int has_angle_bracket;
5346 sym_name = ada_decode (sym_name);
5347 has_angle_bracket = (sym_name[0] == '<');
5348 match = (has_angle_bracket == verbatim_match);
5349 sym_name = sym_name_copy;
5352 if (match && !verbatim_match)
5354 /* When doing non-verbatim match, another check that needs to
5355 be done is to verify that the potentially matching symbol name
5356 does not include capital letters, because the ada-mode would
5357 not be able to understand these symbol names without the
5358 angle bracket notation. */
5361 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5366 /* Second: Try wild matching... */
5368 if (!match && wild_match)
5370 /* Since we are doing wild matching, this means that TEXT
5371 may represent an unqualified symbol name. We therefore must
5372 also compare TEXT against the unqualified name of the symbol. */
5373 sym_name = ada_unqualified_name (ada_decode (sym_name));
5375 if (strncmp (sym_name, text, text_len) == 0)
5379 /* Finally: If we found a mach, prepare the result to return. */
5385 sym_name = add_angle_brackets (sym_name);
5388 sym_name = ada_decode (sym_name);
5393 typedef char *char_ptr;
5394 DEF_VEC_P (char_ptr);
5396 /* A companion function to ada_make_symbol_completion_list().
5397 Check if SYM_NAME represents a symbol which name would be suitable
5398 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5399 it is appended at the end of the given string vector SV.
5401 ORIG_TEXT is the string original string from the user command
5402 that needs to be completed. WORD is the entire command on which
5403 completion should be performed. These two parameters are used to
5404 determine which part of the symbol name should be added to the
5406 if WILD_MATCH is set, then wild matching is performed.
5407 ENCODED should be set if TEXT represents a symbol name in its
5408 encoded formed (in which case the completion should also be
5412 symbol_completion_add (VEC(char_ptr) **sv,
5413 const char *sym_name,
5414 const char *text, int text_len,
5415 const char *orig_text, const char *word,
5416 int wild_match, int encoded)
5418 const char *match = symbol_completion_match (sym_name, text, text_len,
5419 wild_match, encoded);
5425 /* We found a match, so add the appropriate completion to the given
5428 if (word == orig_text)
5430 completion = xmalloc (strlen (match) + 5);
5431 strcpy (completion, match);
5433 else if (word > orig_text)
5435 /* Return some portion of sym_name. */
5436 completion = xmalloc (strlen (match) + 5);
5437 strcpy (completion, match + (word - orig_text));
5441 /* Return some of ORIG_TEXT plus sym_name. */
5442 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
5443 strncpy (completion, word, orig_text - word);
5444 completion[orig_text - word] = '\0';
5445 strcat (completion, match);
5448 VEC_safe_push (char_ptr, *sv, completion);
5451 /* Return a list of possible symbol names completing TEXT0. The list
5452 is NULL terminated. WORD is the entire command on which completion
5456 ada_make_symbol_completion_list (char *text0, char *word)
5462 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
5465 struct partial_symtab *ps;
5466 struct minimal_symbol *msymbol;
5467 struct objfile *objfile;
5468 struct block *b, *surrounding_static_block = 0;
5470 struct dict_iterator iter;
5472 if (text0[0] == '<')
5474 text = xstrdup (text0);
5475 make_cleanup (xfree, text);
5476 text_len = strlen (text);
5482 text = xstrdup (ada_encode (text0));
5483 make_cleanup (xfree, text);
5484 text_len = strlen (text);
5485 for (i = 0; i < text_len; i++)
5486 text[i] = tolower (text[i]);
5488 encoded = (strstr (text0, "__") != NULL);
5489 /* If the name contains a ".", then the user is entering a fully
5490 qualified entity name, and the match must not be done in wild
5491 mode. Similarly, if the user wants to complete what looks like
5492 an encoded name, the match must not be done in wild mode. */
5493 wild_match = (strchr (text0, '.') == NULL && !encoded);
5496 /* First, look at the partial symtab symbols. */
5497 ALL_PSYMTABS (objfile, ps)
5499 struct partial_symbol **psym;
5501 /* If the psymtab's been read in we'll get it when we search
5502 through the blockvector. */
5506 for (psym = objfile->global_psymbols.list + ps->globals_offset;
5507 psym < (objfile->global_psymbols.list + ps->globals_offset
5508 + ps->n_global_syms); psym++)
5511 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (*psym),
5512 text, text_len, text0, word,
5513 wild_match, encoded);
5516 for (psym = objfile->static_psymbols.list + ps->statics_offset;
5517 psym < (objfile->static_psymbols.list + ps->statics_offset
5518 + ps->n_static_syms); psym++)
5521 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (*psym),
5522 text, text_len, text0, word,
5523 wild_match, encoded);
5527 /* At this point scan through the misc symbol vectors and add each
5528 symbol you find to the list. Eventually we want to ignore
5529 anything that isn't a text symbol (everything else will be
5530 handled by the psymtab code above). */
5532 ALL_MSYMBOLS (objfile, msymbol)
5535 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
5536 text, text_len, text0, word, wild_match, encoded);
5539 /* Search upwards from currently selected frame (so that we can
5540 complete on local vars. */
5542 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
5544 if (!BLOCK_SUPERBLOCK (b))
5545 surrounding_static_block = b; /* For elmin of dups */
5547 ALL_BLOCK_SYMBOLS (b, iter, sym)
5549 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5550 text, text_len, text0, word,
5551 wild_match, encoded);
5555 /* Go through the symtabs and check the externs and statics for
5556 symbols which match. */
5558 ALL_SYMTABS (objfile, s)
5561 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5562 ALL_BLOCK_SYMBOLS (b, iter, sym)
5564 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5565 text, text_len, text0, word,
5566 wild_match, encoded);
5570 ALL_SYMTABS (objfile, s)
5573 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
5574 /* Don't do this block twice. */
5575 if (b == surrounding_static_block)
5577 ALL_BLOCK_SYMBOLS (b, iter, sym)
5579 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5580 text, text_len, text0, word,
5581 wild_match, encoded);
5585 /* Append the closing NULL entry. */
5586 VEC_safe_push (char_ptr, completions, NULL);
5588 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5589 return the copy. It's unfortunate that we have to make a copy
5590 of an array that we're about to destroy, but there is nothing much
5591 we can do about it. Fortunately, it's typically not a very large
5594 const size_t completions_size =
5595 VEC_length (char_ptr, completions) * sizeof (char *);
5596 char **result = malloc (completions_size);
5598 memcpy (result, VEC_address (char_ptr, completions), completions_size);
5600 VEC_free (char_ptr, completions);
5607 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5608 for tagged types. */
5611 ada_is_dispatch_table_ptr_type (struct type *type)
5615 if (TYPE_CODE (type) != TYPE_CODE_PTR)
5618 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
5622 return (strcmp (name, "ada__tags__dispatch_table") == 0);
5625 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5626 to be invisible to users. */
5629 ada_is_ignored_field (struct type *type, int field_num)
5631 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5634 /* Check the name of that field. */
5636 const char *name = TYPE_FIELD_NAME (type, field_num);
5638 /* Anonymous field names should not be printed.
5639 brobecker/2007-02-20: I don't think this can actually happen
5640 but we don't want to print the value of annonymous fields anyway. */
5644 /* A field named "_parent" is internally generated by GNAT for
5645 tagged types, and should not be printed either. */
5646 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
5650 /* If this is the dispatch table of a tagged type, then ignore. */
5651 if (ada_is_tagged_type (type, 1)
5652 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num)))
5655 /* Not a special field, so it should not be ignored. */
5659 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5660 pointer or reference type whose ultimate target has a tag field. */
5663 ada_is_tagged_type (struct type *type, int refok)
5665 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
5668 /* True iff TYPE represents the type of X'Tag */
5671 ada_is_tag_type (struct type *type)
5673 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
5677 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5678 return (name != NULL
5679 && strcmp (name, "ada__tags__dispatch_table") == 0);
5683 /* The type of the tag on VAL. */
5686 ada_tag_type (struct value *val)
5688 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
5691 /* The value of the tag on VAL. */
5694 ada_value_tag (struct value *val)
5696 return ada_value_struct_elt (val, "_tag", 0);
5699 /* The value of the tag on the object of type TYPE whose contents are
5700 saved at VALADDR, if it is non-null, or is at memory address
5703 static struct value *
5704 value_tag_from_contents_and_address (struct type *type,
5705 const gdb_byte *valaddr,
5708 int tag_byte_offset, dummy1, dummy2;
5709 struct type *tag_type;
5710 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
5713 const gdb_byte *valaddr1 = ((valaddr == NULL)
5715 : valaddr + tag_byte_offset);
5716 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
5718 return value_from_contents_and_address (tag_type, valaddr1, address1);
5723 static struct type *
5724 type_from_tag (struct value *tag)
5726 const char *type_name = ada_tag_name (tag);
5727 if (type_name != NULL)
5728 return ada_find_any_type (ada_encode (type_name));
5739 static int ada_tag_name_1 (void *);
5740 static int ada_tag_name_2 (struct tag_args *);
5742 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5743 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5744 The value stored in ARGS->name is valid until the next call to
5748 ada_tag_name_1 (void *args0)
5750 struct tag_args *args = (struct tag_args *) args0;
5751 static char name[1024];
5755 val = ada_value_struct_elt (args->tag, "tsd", 1);
5757 return ada_tag_name_2 (args);
5758 val = ada_value_struct_elt (val, "expanded_name", 1);
5761 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5762 for (p = name; *p != '\0'; p += 1)
5769 /* Utility function for ada_tag_name_1 that tries the second
5770 representation for the dispatch table (in which there is no
5771 explicit 'tsd' field in the referent of the tag pointer, and instead
5772 the tsd pointer is stored just before the dispatch table. */
5775 ada_tag_name_2 (struct tag_args *args)
5777 struct type *info_type;
5778 static char name[1024];
5780 struct value *val, *valp;
5783 info_type = ada_find_any_type ("ada__tags__type_specific_data");
5784 if (info_type == NULL)
5786 info_type = lookup_pointer_type (lookup_pointer_type (info_type));
5787 valp = value_cast (info_type, args->tag);
5790 val = value_ind (value_add (valp, value_from_longest (builtin_type_int, -1)));
5793 val = ada_value_struct_elt (val, "expanded_name", 1);
5796 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5797 for (p = name; *p != '\0'; p += 1)
5804 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5808 ada_tag_name (struct value *tag)
5810 struct tag_args args;
5811 if (!ada_is_tag_type (value_type (tag)))
5815 catch_errors (ada_tag_name_1, &args, NULL, RETURN_MASK_ALL);
5819 /* The parent type of TYPE, or NULL if none. */
5822 ada_parent_type (struct type *type)
5826 type = ada_check_typedef (type);
5828 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5831 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5832 if (ada_is_parent_field (type, i))
5833 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
5838 /* True iff field number FIELD_NUM of structure type TYPE contains the
5839 parent-type (inherited) fields of a derived type. Assumes TYPE is
5840 a structure type with at least FIELD_NUM+1 fields. */
5843 ada_is_parent_field (struct type *type, int field_num)
5845 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5846 return (name != NULL
5847 && (strncmp (name, "PARENT", 6) == 0
5848 || strncmp (name, "_parent", 7) == 0));
5851 /* True iff field number FIELD_NUM of structure type TYPE is a
5852 transparent wrapper field (which should be silently traversed when doing
5853 field selection and flattened when printing). Assumes TYPE is a
5854 structure type with at least FIELD_NUM+1 fields. Such fields are always
5858 ada_is_wrapper_field (struct type *type, int field_num)
5860 const char *name = TYPE_FIELD_NAME (type, field_num);
5861 return (name != NULL
5862 && (strncmp (name, "PARENT", 6) == 0
5863 || strcmp (name, "REP") == 0
5864 || strncmp (name, "_parent", 7) == 0
5865 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
5868 /* True iff field number FIELD_NUM of structure or union type TYPE
5869 is a variant wrapper. Assumes TYPE is a structure type with at least
5870 FIELD_NUM+1 fields. */
5873 ada_is_variant_part (struct type *type, int field_num)
5875 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5876 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
5877 || (is_dynamic_field (type, field_num)
5878 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
5879 == TYPE_CODE_UNION)));
5882 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5883 whose discriminants are contained in the record type OUTER_TYPE,
5884 returns the type of the controlling discriminant for the variant. */
5887 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
5889 char *name = ada_variant_discrim_name (var_type);
5891 ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
5893 return builtin_type_int;
5898 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5899 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5900 represents a 'when others' clause; otherwise 0. */
5903 ada_is_others_clause (struct type *type, int field_num)
5905 const char *name = TYPE_FIELD_NAME (type, field_num);
5906 return (name != NULL && name[0] == 'O');
5909 /* Assuming that TYPE0 is the type of the variant part of a record,
5910 returns the name of the discriminant controlling the variant.
5911 The value is valid until the next call to ada_variant_discrim_name. */
5914 ada_variant_discrim_name (struct type *type0)
5916 static char *result = NULL;
5917 static size_t result_len = 0;
5920 const char *discrim_end;
5921 const char *discrim_start;
5923 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
5924 type = TYPE_TARGET_TYPE (type0);
5928 name = ada_type_name (type);
5930 if (name == NULL || name[0] == '\000')
5933 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
5936 if (strncmp (discrim_end, "___XVN", 6) == 0)
5939 if (discrim_end == name)
5942 for (discrim_start = discrim_end; discrim_start != name + 3;
5945 if (discrim_start == name + 1)
5947 if ((discrim_start > name + 3
5948 && strncmp (discrim_start - 3, "___", 3) == 0)
5949 || discrim_start[-1] == '.')
5953 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
5954 strncpy (result, discrim_start, discrim_end - discrim_start);
5955 result[discrim_end - discrim_start] = '\0';
5959 /* Scan STR for a subtype-encoded number, beginning at position K.
5960 Put the position of the character just past the number scanned in
5961 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5962 Return 1 if there was a valid number at the given position, and 0
5963 otherwise. A "subtype-encoded" number consists of the absolute value
5964 in decimal, followed by the letter 'm' to indicate a negative number.
5965 Assumes 0m does not occur. */
5968 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
5972 if (!isdigit (str[k]))
5975 /* Do it the hard way so as not to make any assumption about
5976 the relationship of unsigned long (%lu scan format code) and
5979 while (isdigit (str[k]))
5981 RU = RU * 10 + (str[k] - '0');
5988 *R = (-(LONGEST) (RU - 1)) - 1;
5994 /* NOTE on the above: Technically, C does not say what the results of
5995 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5996 number representable as a LONGEST (although either would probably work
5997 in most implementations). When RU>0, the locution in the then branch
5998 above is always equivalent to the negative of RU. */
6005 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6006 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6007 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6010 ada_in_variant (LONGEST val, struct type *type, int field_num)
6012 const char *name = TYPE_FIELD_NAME (type, field_num);
6025 if (!ada_scan_number (name, p + 1, &W, &p))
6034 if (!ada_scan_number (name, p + 1, &L, &p)
6035 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6037 if (val >= L && val <= U)
6049 /* FIXME: Lots of redundancy below. Try to consolidate. */
6051 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6052 ARG_TYPE, extract and return the value of one of its (non-static)
6053 fields. FIELDNO says which field. Differs from value_primitive_field
6054 only in that it can handle packed values of arbitrary type. */
6056 static struct value *
6057 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6058 struct type *arg_type)
6062 arg_type = ada_check_typedef (arg_type);
6063 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6065 /* Handle packed fields. */
6067 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6069 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6070 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
6072 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
6073 offset + bit_pos / 8,
6074 bit_pos % 8, bit_size, type);
6077 return value_primitive_field (arg1, offset, fieldno, arg_type);
6080 /* Find field with name NAME in object of type TYPE. If found,
6081 set the following for each argument that is non-null:
6082 - *FIELD_TYPE_P to the field's type;
6083 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6084 an object of that type;
6085 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6086 - *BIT_SIZE_P to its size in bits if the field is packed, and
6088 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6089 fields up to but not including the desired field, or by the total
6090 number of fields if not found. A NULL value of NAME never
6091 matches; the function just counts visible fields in this case.
6093 Returns 1 if found, 0 otherwise. */
6096 find_struct_field (char *name, struct type *type, int offset,
6097 struct type **field_type_p,
6098 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6103 type = ada_check_typedef (type);
6105 if (field_type_p != NULL)
6106 *field_type_p = NULL;
6107 if (byte_offset_p != NULL)
6109 if (bit_offset_p != NULL)
6111 if (bit_size_p != NULL)
6114 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6116 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6117 int fld_offset = offset + bit_pos / 8;
6118 char *t_field_name = TYPE_FIELD_NAME (type, i);
6120 if (t_field_name == NULL)
6123 else if (name != NULL && field_name_match (t_field_name, name))
6125 int bit_size = TYPE_FIELD_BITSIZE (type, i);
6126 if (field_type_p != NULL)
6127 *field_type_p = TYPE_FIELD_TYPE (type, i);
6128 if (byte_offset_p != NULL)
6129 *byte_offset_p = fld_offset;
6130 if (bit_offset_p != NULL)
6131 *bit_offset_p = bit_pos % 8;
6132 if (bit_size_p != NULL)
6133 *bit_size_p = bit_size;
6136 else if (ada_is_wrapper_field (type, i))
6138 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6139 field_type_p, byte_offset_p, bit_offset_p,
6140 bit_size_p, index_p))
6143 else if (ada_is_variant_part (type, i))
6145 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6148 struct type *field_type
6149 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6151 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
6153 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6155 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6156 field_type_p, byte_offset_p,
6157 bit_offset_p, bit_size_p, index_p))
6161 else if (index_p != NULL)
6167 /* Number of user-visible fields in record type TYPE. */
6170 num_visible_fields (struct type *type)
6174 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6178 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6179 and search in it assuming it has (class) type TYPE.
6180 If found, return value, else return NULL.
6182 Searches recursively through wrapper fields (e.g., '_parent'). */
6184 static struct value *
6185 ada_search_struct_field (char *name, struct value *arg, int offset,
6189 type = ada_check_typedef (type);
6191 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6193 char *t_field_name = TYPE_FIELD_NAME (type, i);
6195 if (t_field_name == NULL)
6198 else if (field_name_match (t_field_name, name))
6199 return ada_value_primitive_field (arg, offset, i, type);
6201 else if (ada_is_wrapper_field (type, i))
6203 struct value *v = /* Do not let indent join lines here. */
6204 ada_search_struct_field (name, arg,
6205 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6206 TYPE_FIELD_TYPE (type, i));
6211 else if (ada_is_variant_part (type, i))
6213 /* PNH: Do we ever get here? See find_struct_field. */
6215 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6216 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6218 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
6220 struct value *v = ada_search_struct_field /* Force line break. */
6222 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6223 TYPE_FIELD_TYPE (field_type, j));
6232 static struct value *ada_index_struct_field_1 (int *, struct value *,
6233 int, struct type *);
6236 /* Return field #INDEX in ARG, where the index is that returned by
6237 * find_struct_field through its INDEX_P argument. Adjust the address
6238 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6239 * If found, return value, else return NULL. */
6241 static struct value *
6242 ada_index_struct_field (int index, struct value *arg, int offset,
6245 return ada_index_struct_field_1 (&index, arg, offset, type);
6249 /* Auxiliary function for ada_index_struct_field. Like
6250 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6253 static struct value *
6254 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6258 type = ada_check_typedef (type);
6260 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6262 if (TYPE_FIELD_NAME (type, i) == NULL)
6264 else if (ada_is_wrapper_field (type, i))
6266 struct value *v = /* Do not let indent join lines here. */
6267 ada_index_struct_field_1 (index_p, arg,
6268 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6269 TYPE_FIELD_TYPE (type, i));
6274 else if (ada_is_variant_part (type, i))
6276 /* PNH: Do we ever get here? See ada_search_struct_field,
6277 find_struct_field. */
6278 error (_("Cannot assign this kind of variant record"));
6280 else if (*index_p == 0)
6281 return ada_value_primitive_field (arg, offset, i, type);
6288 /* Given ARG, a value of type (pointer or reference to a)*
6289 structure/union, extract the component named NAME from the ultimate
6290 target structure/union and return it as a value with its
6291 appropriate type. If ARG is a pointer or reference and the field
6292 is not packed, returns a reference to the field, otherwise the
6293 value of the field (an lvalue if ARG is an lvalue).
6295 The routine searches for NAME among all members of the structure itself
6296 and (recursively) among all members of any wrapper members
6299 If NO_ERR, then simply return NULL in case of error, rather than
6303 ada_value_struct_elt (struct value *arg, char *name, int no_err)
6305 struct type *t, *t1;
6309 t1 = t = ada_check_typedef (value_type (arg));
6310 if (TYPE_CODE (t) == TYPE_CODE_REF)
6312 t1 = TYPE_TARGET_TYPE (t);
6315 t1 = ada_check_typedef (t1);
6316 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
6318 arg = coerce_ref (arg);
6323 while (TYPE_CODE (t) == TYPE_CODE_PTR)
6325 t1 = TYPE_TARGET_TYPE (t);
6328 t1 = ada_check_typedef (t1);
6329 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
6331 arg = value_ind (arg);
6338 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
6342 v = ada_search_struct_field (name, arg, 0, t);
6345 int bit_offset, bit_size, byte_offset;
6346 struct type *field_type;
6349 if (TYPE_CODE (t) == TYPE_CODE_PTR)
6350 address = value_as_address (arg);
6352 address = unpack_pointer (t, value_contents (arg));
6354 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
6355 if (find_struct_field (name, t1, 0,
6356 &field_type, &byte_offset, &bit_offset,
6361 if (TYPE_CODE (t) == TYPE_CODE_REF)
6362 arg = ada_coerce_ref (arg);
6364 arg = ada_value_ind (arg);
6365 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6366 bit_offset, bit_size,
6370 v = value_from_pointer (lookup_reference_type (field_type),
6371 address + byte_offset);
6375 if (v != NULL || no_err)
6378 error (_("There is no member named %s."), name);
6384 error (_("Attempt to extract a component of a value that is not a record."));
6387 /* Given a type TYPE, look up the type of the component of type named NAME.
6388 If DISPP is non-null, add its byte displacement from the beginning of a
6389 structure (pointed to by a value) of type TYPE to *DISPP (does not
6390 work for packed fields).
6392 Matches any field whose name has NAME as a prefix, possibly
6395 TYPE can be either a struct or union. If REFOK, TYPE may also
6396 be a (pointer or reference)+ to a struct or union, and the
6397 ultimate target type will be searched.
6399 Looks recursively into variant clauses and parent types.
6401 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6402 TYPE is not a type of the right kind. */
6404 static struct type *
6405 ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6406 int noerr, int *dispp)
6413 if (refok && type != NULL)
6416 type = ada_check_typedef (type);
6417 if (TYPE_CODE (type) != TYPE_CODE_PTR
6418 && TYPE_CODE (type) != TYPE_CODE_REF)
6420 type = TYPE_TARGET_TYPE (type);
6424 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6425 && TYPE_CODE (type) != TYPE_CODE_UNION))
6431 target_terminal_ours ();
6432 gdb_flush (gdb_stdout);
6434 error (_("Type (null) is not a structure or union type"));
6437 /* XXX: type_sprint */
6438 fprintf_unfiltered (gdb_stderr, _("Type "));
6439 type_print (type, "", gdb_stderr, -1);
6440 error (_(" is not a structure or union type"));
6445 type = to_static_fixed_type (type);
6447 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6449 char *t_field_name = TYPE_FIELD_NAME (type, i);
6453 if (t_field_name == NULL)
6456 else if (field_name_match (t_field_name, name))
6459 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
6460 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6463 else if (ada_is_wrapper_field (type, i))
6466 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
6471 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6476 else if (ada_is_variant_part (type, i))
6479 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6481 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
6484 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
6489 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6500 target_terminal_ours ();
6501 gdb_flush (gdb_stdout);
6504 /* XXX: type_sprint */
6505 fprintf_unfiltered (gdb_stderr, _("Type "));
6506 type_print (type, "", gdb_stderr, -1);
6507 error (_(" has no component named <null>"));
6511 /* XXX: type_sprint */
6512 fprintf_unfiltered (gdb_stderr, _("Type "));
6513 type_print (type, "", gdb_stderr, -1);
6514 error (_(" has no component named %s"), name);
6521 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6522 within a value of type OUTER_TYPE that is stored in GDB at
6523 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6524 numbering from 0) is applicable. Returns -1 if none are. */
6527 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
6528 const gdb_byte *outer_valaddr)
6532 char *discrim_name = ada_variant_discrim_name (var_type);
6533 struct value *outer;
6534 struct value *discrim;
6535 LONGEST discrim_val;
6537 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
6538 discrim = ada_value_struct_elt (outer, discrim_name, 1);
6539 if (discrim == NULL)
6541 discrim_val = value_as_long (discrim);
6544 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
6546 if (ada_is_others_clause (var_type, i))
6548 else if (ada_in_variant (discrim_val, var_type, i))
6552 return others_clause;
6557 /* Dynamic-Sized Records */
6559 /* Strategy: The type ostensibly attached to a value with dynamic size
6560 (i.e., a size that is not statically recorded in the debugging
6561 data) does not accurately reflect the size or layout of the value.
6562 Our strategy is to convert these values to values with accurate,
6563 conventional types that are constructed on the fly. */
6565 /* There is a subtle and tricky problem here. In general, we cannot
6566 determine the size of dynamic records without its data. However,
6567 the 'struct value' data structure, which GDB uses to represent
6568 quantities in the inferior process (the target), requires the size
6569 of the type at the time of its allocation in order to reserve space
6570 for GDB's internal copy of the data. That's why the
6571 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6572 rather than struct value*s.
6574 However, GDB's internal history variables ($1, $2, etc.) are
6575 struct value*s containing internal copies of the data that are not, in
6576 general, the same as the data at their corresponding addresses in
6577 the target. Fortunately, the types we give to these values are all
6578 conventional, fixed-size types (as per the strategy described
6579 above), so that we don't usually have to perform the
6580 'to_fixed_xxx_type' conversions to look at their values.
6581 Unfortunately, there is one exception: if one of the internal
6582 history variables is an array whose elements are unconstrained
6583 records, then we will need to create distinct fixed types for each
6584 element selected. */
6586 /* The upshot of all of this is that many routines take a (type, host
6587 address, target address) triple as arguments to represent a value.
6588 The host address, if non-null, is supposed to contain an internal
6589 copy of the relevant data; otherwise, the program is to consult the
6590 target at the target address. */
6592 /* Assuming that VAL0 represents a pointer value, the result of
6593 dereferencing it. Differs from value_ind in its treatment of
6594 dynamic-sized types. */
6597 ada_value_ind (struct value *val0)
6599 struct value *val = unwrap_value (value_ind (val0));
6600 return ada_to_fixed_value (val);
6603 /* The value resulting from dereferencing any "reference to"
6604 qualifiers on VAL0. */
6606 static struct value *
6607 ada_coerce_ref (struct value *val0)
6609 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
6611 struct value *val = val0;
6612 val = coerce_ref (val);
6613 val = unwrap_value (val);
6614 return ada_to_fixed_value (val);
6620 /* Return OFF rounded upward if necessary to a multiple of
6621 ALIGNMENT (a power of 2). */
6624 align_value (unsigned int off, unsigned int alignment)
6626 return (off + alignment - 1) & ~(alignment - 1);
6629 /* Return the bit alignment required for field #F of template type TYPE. */
6632 field_alignment (struct type *type, int f)
6634 const char *name = TYPE_FIELD_NAME (type, f);
6638 /* The field name should never be null, unless the debugging information
6639 is somehow malformed. In this case, we assume the field does not
6640 require any alignment. */
6644 len = strlen (name);
6646 if (!isdigit (name[len - 1]))
6649 if (isdigit (name[len - 2]))
6650 align_offset = len - 2;
6652 align_offset = len - 1;
6654 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
6655 return TARGET_CHAR_BIT;
6657 return atoi (name + align_offset) * TARGET_CHAR_BIT;
6660 /* Find a symbol named NAME. Ignores ambiguity. */
6663 ada_find_any_symbol (const char *name)
6667 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
6668 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
6671 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
6675 /* Find a type named NAME. Ignores ambiguity. */
6678 ada_find_any_type (const char *name)
6680 struct symbol *sym = ada_find_any_symbol (name);
6683 return SYMBOL_TYPE (sym);
6688 /* Given NAME and an associated BLOCK, search all symbols for
6689 NAME suffixed with "___XR", which is the ``renaming'' symbol
6690 associated to NAME. Return this symbol if found, return
6694 ada_find_renaming_symbol (const char *name, struct block *block)
6698 sym = find_old_style_renaming_symbol (name, block);
6703 /* Not right yet. FIXME pnh 7/20/2007. */
6704 sym = ada_find_any_symbol (name);
6705 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
6711 static struct symbol *
6712 find_old_style_renaming_symbol (const char *name, struct block *block)
6714 const struct symbol *function_sym = block_linkage_function (block);
6717 if (function_sym != NULL)
6719 /* If the symbol is defined inside a function, NAME is not fully
6720 qualified. This means we need to prepend the function name
6721 as well as adding the ``___XR'' suffix to build the name of
6722 the associated renaming symbol. */
6723 char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
6724 /* Function names sometimes contain suffixes used
6725 for instance to qualify nested subprograms. When building
6726 the XR type name, we need to make sure that this suffix is
6727 not included. So do not include any suffix in the function
6728 name length below. */
6729 const int function_name_len = ada_name_prefix_len (function_name);
6730 const int rename_len = function_name_len + 2 /* "__" */
6731 + strlen (name) + 6 /* "___XR\0" */ ;
6733 /* Strip the suffix if necessary. */
6734 function_name[function_name_len] = '\0';
6736 /* Library-level functions are a special case, as GNAT adds
6737 a ``_ada_'' prefix to the function name to avoid namespace
6738 pollution. However, the renaming symbols themselves do not
6739 have this prefix, so we need to skip this prefix if present. */
6740 if (function_name_len > 5 /* "_ada_" */
6741 && strstr (function_name, "_ada_") == function_name)
6742 function_name = function_name + 5;
6744 rename = (char *) alloca (rename_len * sizeof (char));
6745 sprintf (rename, "%s__%s___XR", function_name, name);
6749 const int rename_len = strlen (name) + 6;
6750 rename = (char *) alloca (rename_len * sizeof (char));
6751 sprintf (rename, "%s___XR", name);
6754 return ada_find_any_symbol (rename);
6757 /* Because of GNAT encoding conventions, several GDB symbols may match a
6758 given type name. If the type denoted by TYPE0 is to be preferred to
6759 that of TYPE1 for purposes of type printing, return non-zero;
6760 otherwise return 0. */
6763 ada_prefer_type (struct type *type0, struct type *type1)
6767 else if (type0 == NULL)
6769 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
6771 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
6773 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
6775 else if (ada_is_packed_array_type (type0))
6777 else if (ada_is_array_descriptor_type (type0)
6778 && !ada_is_array_descriptor_type (type1))
6782 const char *type0_name = type_name_no_tag (type0);
6783 const char *type1_name = type_name_no_tag (type1);
6785 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
6786 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
6792 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6793 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6796 ada_type_name (struct type *type)
6800 else if (TYPE_NAME (type) != NULL)
6801 return TYPE_NAME (type);
6803 return TYPE_TAG_NAME (type);
6806 /* Find a parallel type to TYPE whose name is formed by appending
6807 SUFFIX to the name of TYPE. */
6810 ada_find_parallel_type (struct type *type, const char *suffix)
6813 static size_t name_len = 0;
6815 char *typename = ada_type_name (type);
6817 if (typename == NULL)
6820 len = strlen (typename);
6822 GROW_VECT (name, name_len, len + strlen (suffix) + 1);
6824 strcpy (name, typename);
6825 strcpy (name + len, suffix);
6827 return ada_find_any_type (name);
6831 /* If TYPE is a variable-size record type, return the corresponding template
6832 type describing its fields. Otherwise, return NULL. */
6834 static struct type *
6835 dynamic_template_type (struct type *type)
6837 type = ada_check_typedef (type);
6839 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
6840 || ada_type_name (type) == NULL)
6844 int len = strlen (ada_type_name (type));
6845 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
6848 return ada_find_parallel_type (type, "___XVE");
6852 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6853 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6856 is_dynamic_field (struct type *templ_type, int field_num)
6858 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
6860 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
6861 && strstr (name, "___XVL") != NULL;
6864 /* The index of the variant field of TYPE, or -1 if TYPE does not
6865 represent a variant record type. */
6868 variant_field_index (struct type *type)
6872 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6875 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
6877 if (ada_is_variant_part (type, f))
6883 /* A record type with no fields. */
6885 static struct type *
6886 empty_record (struct objfile *objfile)
6888 struct type *type = alloc_type (objfile);
6889 TYPE_CODE (type) = TYPE_CODE_STRUCT;
6890 TYPE_NFIELDS (type) = 0;
6891 TYPE_FIELDS (type) = NULL;
6892 TYPE_NAME (type) = "<empty>";
6893 TYPE_TAG_NAME (type) = NULL;
6894 TYPE_LENGTH (type) = 0;
6898 /* An ordinary record type (with fixed-length fields) that describes
6899 the value of type TYPE at VALADDR or ADDRESS (see comments at
6900 the beginning of this section) VAL according to GNAT conventions.
6901 DVAL0 should describe the (portion of a) record that contains any
6902 necessary discriminants. It should be NULL if value_type (VAL) is
6903 an outer-level type (i.e., as opposed to a branch of a variant.) A
6904 variant field (unless unchecked) is replaced by a particular branch
6907 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6908 length are not statically known are discarded. As a consequence,
6909 VALADDR, ADDRESS and DVAL0 are ignored.
6911 NOTE: Limitations: For now, we assume that dynamic fields and
6912 variants occupy whole numbers of bytes. However, they need not be
6916 ada_template_to_fixed_record_type_1 (struct type *type,
6917 const gdb_byte *valaddr,
6918 CORE_ADDR address, struct value *dval0,
6919 int keep_dynamic_fields)
6921 struct value *mark = value_mark ();
6924 int nfields, bit_len;
6927 int fld_bit_len, bit_incr;
6930 /* Compute the number of fields in this record type that are going
6931 to be processed: unless keep_dynamic_fields, this includes only
6932 fields whose position and length are static will be processed. */
6933 if (keep_dynamic_fields)
6934 nfields = TYPE_NFIELDS (type);
6938 while (nfields < TYPE_NFIELDS (type)
6939 && !ada_is_variant_part (type, nfields)
6940 && !is_dynamic_field (type, nfields))
6944 rtype = alloc_type (TYPE_OBJFILE (type));
6945 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6946 INIT_CPLUS_SPECIFIC (rtype);
6947 TYPE_NFIELDS (rtype) = nfields;
6948 TYPE_FIELDS (rtype) = (struct field *)
6949 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6950 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
6951 TYPE_NAME (rtype) = ada_type_name (type);
6952 TYPE_TAG_NAME (rtype) = NULL;
6953 TYPE_FIXED_INSTANCE (rtype) = 1;
6959 for (f = 0; f < nfields; f += 1)
6961 off = align_value (off, field_alignment (type, f))
6962 + TYPE_FIELD_BITPOS (type, f);
6963 TYPE_FIELD_BITPOS (rtype, f) = off;
6964 TYPE_FIELD_BITSIZE (rtype, f) = 0;
6966 if (ada_is_variant_part (type, f))
6969 fld_bit_len = bit_incr = 0;
6971 else if (is_dynamic_field (type, f))
6974 dval = value_from_contents_and_address (rtype, valaddr, address);
6978 /* Get the fixed type of the field. Note that, in this case, we
6979 do not want to get the real type out of the tag: if the current
6980 field is the parent part of a tagged record, we will get the
6981 tag of the object. Clearly wrong: the real type of the parent
6982 is not the real type of the child. We would end up in an infinite
6984 TYPE_FIELD_TYPE (rtype, f) =
6987 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
6988 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6989 cond_offset_target (address, off / TARGET_CHAR_BIT), dval, 0);
6990 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6991 bit_incr = fld_bit_len =
6992 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6996 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
6997 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6998 if (TYPE_FIELD_BITSIZE (type, f) > 0)
6999 bit_incr = fld_bit_len =
7000 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7002 bit_incr = fld_bit_len =
7003 TYPE_LENGTH (TYPE_FIELD_TYPE (type, f)) * TARGET_CHAR_BIT;
7005 if (off + fld_bit_len > bit_len)
7006 bit_len = off + fld_bit_len;
7008 TYPE_LENGTH (rtype) =
7009 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7012 /* We handle the variant part, if any, at the end because of certain
7013 odd cases in which it is re-ordered so as NOT the last field of
7014 the record. This can happen in the presence of representation
7016 if (variant_field >= 0)
7018 struct type *branch_type;
7020 off = TYPE_FIELD_BITPOS (rtype, variant_field);
7023 dval = value_from_contents_and_address (rtype, valaddr, address);
7028 to_fixed_variant_branch_type
7029 (TYPE_FIELD_TYPE (type, variant_field),
7030 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7031 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7032 if (branch_type == NULL)
7034 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
7035 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7036 TYPE_NFIELDS (rtype) -= 1;
7040 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7041 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7043 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
7045 if (off + fld_bit_len > bit_len)
7046 bit_len = off + fld_bit_len;
7047 TYPE_LENGTH (rtype) =
7048 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7052 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7053 should contain the alignment of that record, which should be a strictly
7054 positive value. If null or negative, then something is wrong, most
7055 probably in the debug info. In that case, we don't round up the size
7056 of the resulting type. If this record is not part of another structure,
7057 the current RTYPE length might be good enough for our purposes. */
7058 if (TYPE_LENGTH (type) <= 0)
7060 if (TYPE_NAME (rtype))
7061 warning (_("Invalid type size for `%s' detected: %d."),
7062 TYPE_NAME (rtype), TYPE_LENGTH (type));
7064 warning (_("Invalid type size for <unnamed> detected: %d."),
7065 TYPE_LENGTH (type));
7069 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
7070 TYPE_LENGTH (type));
7073 value_free_to_mark (mark);
7074 if (TYPE_LENGTH (rtype) > varsize_limit)
7075 error (_("record type with dynamic size is larger than varsize-limit"));
7079 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7082 static struct type *
7083 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
7084 CORE_ADDR address, struct value *dval0)
7086 return ada_template_to_fixed_record_type_1 (type, valaddr,
7090 /* An ordinary record type in which ___XVL-convention fields and
7091 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7092 static approximations, containing all possible fields. Uses
7093 no runtime values. Useless for use in values, but that's OK,
7094 since the results are used only for type determinations. Works on both
7095 structs and unions. Representation note: to save space, we memorize
7096 the result of this function in the TYPE_TARGET_TYPE of the
7099 static struct type *
7100 template_to_static_fixed_type (struct type *type0)
7106 if (TYPE_TARGET_TYPE (type0) != NULL)
7107 return TYPE_TARGET_TYPE (type0);
7109 nfields = TYPE_NFIELDS (type0);
7112 for (f = 0; f < nfields; f += 1)
7114 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
7115 struct type *new_type;
7117 if (is_dynamic_field (type0, f))
7118 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
7120 new_type = static_unwrap_type (field_type);
7121 if (type == type0 && new_type != field_type)
7123 TYPE_TARGET_TYPE (type0) = type = alloc_type (TYPE_OBJFILE (type0));
7124 TYPE_CODE (type) = TYPE_CODE (type0);
7125 INIT_CPLUS_SPECIFIC (type);
7126 TYPE_NFIELDS (type) = nfields;
7127 TYPE_FIELDS (type) = (struct field *)
7128 TYPE_ALLOC (type, nfields * sizeof (struct field));
7129 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7130 sizeof (struct field) * nfields);
7131 TYPE_NAME (type) = ada_type_name (type0);
7132 TYPE_TAG_NAME (type) = NULL;
7133 TYPE_FIXED_INSTANCE (type) = 1;
7134 TYPE_LENGTH (type) = 0;
7136 TYPE_FIELD_TYPE (type, f) = new_type;
7137 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
7142 /* Given an object of type TYPE whose contents are at VALADDR and
7143 whose address in memory is ADDRESS, returns a revision of TYPE --
7144 a non-dynamic-sized record with a variant part -- in which
7145 the variant part is replaced with the appropriate branch. Looks
7146 for discriminant values in DVAL0, which can be NULL if the record
7147 contains the necessary discriminant values. */
7149 static struct type *
7150 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
7151 CORE_ADDR address, struct value *dval0)
7153 struct value *mark = value_mark ();
7156 struct type *branch_type;
7157 int nfields = TYPE_NFIELDS (type);
7158 int variant_field = variant_field_index (type);
7160 if (variant_field == -1)
7164 dval = value_from_contents_and_address (type, valaddr, address);
7168 rtype = alloc_type (TYPE_OBJFILE (type));
7169 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7170 INIT_CPLUS_SPECIFIC (rtype);
7171 TYPE_NFIELDS (rtype) = nfields;
7172 TYPE_FIELDS (rtype) =
7173 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7174 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
7175 sizeof (struct field) * nfields);
7176 TYPE_NAME (rtype) = ada_type_name (type);
7177 TYPE_TAG_NAME (rtype) = NULL;
7178 TYPE_FIXED_INSTANCE (rtype) = 1;
7179 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7181 branch_type = to_fixed_variant_branch_type
7182 (TYPE_FIELD_TYPE (type, variant_field),
7183 cond_offset_host (valaddr,
7184 TYPE_FIELD_BITPOS (type, variant_field)
7186 cond_offset_target (address,
7187 TYPE_FIELD_BITPOS (type, variant_field)
7188 / TARGET_CHAR_BIT), dval);
7189 if (branch_type == NULL)
7192 for (f = variant_field + 1; f < nfields; f += 1)
7193 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7194 TYPE_NFIELDS (rtype) -= 1;
7198 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7199 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7200 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
7201 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
7203 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
7205 value_free_to_mark (mark);
7209 /* An ordinary record type (with fixed-length fields) that describes
7210 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7211 beginning of this section]. Any necessary discriminants' values
7212 should be in DVAL, a record value; it may be NULL if the object
7213 at ADDR itself contains any necessary discriminant values.
7214 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7215 values from the record are needed. Except in the case that DVAL,
7216 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7217 unchecked) is replaced by a particular branch of the variant.
7219 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7220 is questionable and may be removed. It can arise during the
7221 processing of an unconstrained-array-of-record type where all the
7222 variant branches have exactly the same size. This is because in
7223 such cases, the compiler does not bother to use the XVS convention
7224 when encoding the record. I am currently dubious of this
7225 shortcut and suspect the compiler should be altered. FIXME. */
7227 static struct type *
7228 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
7229 CORE_ADDR address, struct value *dval)
7231 struct type *templ_type;
7233 if (TYPE_FIXED_INSTANCE (type0))
7236 templ_type = dynamic_template_type (type0);
7238 if (templ_type != NULL)
7239 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
7240 else if (variant_field_index (type0) >= 0)
7242 if (dval == NULL && valaddr == NULL && address == 0)
7244 return to_record_with_fixed_variant_part (type0, valaddr, address,
7249 TYPE_FIXED_INSTANCE (type0) = 1;
7255 /* An ordinary record type (with fixed-length fields) that describes
7256 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7257 union type. Any necessary discriminants' values should be in DVAL,
7258 a record value. That is, this routine selects the appropriate
7259 branch of the union at ADDR according to the discriminant value
7260 indicated in the union's type name. */
7262 static struct type *
7263 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
7264 CORE_ADDR address, struct value *dval)
7267 struct type *templ_type;
7268 struct type *var_type;
7270 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
7271 var_type = TYPE_TARGET_TYPE (var_type0);
7273 var_type = var_type0;
7275 templ_type = ada_find_parallel_type (var_type, "___XVU");
7277 if (templ_type != NULL)
7278 var_type = templ_type;
7281 ada_which_variant_applies (var_type,
7282 value_type (dval), value_contents (dval));
7285 return empty_record (TYPE_OBJFILE (var_type));
7286 else if (is_dynamic_field (var_type, which))
7287 return to_fixed_record_type
7288 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
7289 valaddr, address, dval);
7290 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
7292 to_fixed_record_type
7293 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
7295 return TYPE_FIELD_TYPE (var_type, which);
7298 /* Assuming that TYPE0 is an array type describing the type of a value
7299 at ADDR, and that DVAL describes a record containing any
7300 discriminants used in TYPE0, returns a type for the value that
7301 contains no dynamic components (that is, no components whose sizes
7302 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7303 true, gives an error message if the resulting type's size is over
7306 static struct type *
7307 to_fixed_array_type (struct type *type0, struct value *dval,
7310 struct type *index_type_desc;
7311 struct type *result;
7313 if (ada_is_packed_array_type (type0) /* revisit? */
7314 || TYPE_FIXED_INSTANCE (type0))
7317 index_type_desc = ada_find_parallel_type (type0, "___XA");
7318 if (index_type_desc == NULL)
7320 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
7321 /* NOTE: elt_type---the fixed version of elt_type0---should never
7322 depend on the contents of the array in properly constructed
7324 /* Create a fixed version of the array element type.
7325 We're not providing the address of an element here,
7326 and thus the actual object value cannot be inspected to do
7327 the conversion. This should not be a problem, since arrays of
7328 unconstrained objects are not allowed. In particular, all
7329 the elements of an array of a tagged type should all be of
7330 the same type specified in the debugging info. No need to
7331 consult the object tag. */
7332 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
7334 if (elt_type0 == elt_type)
7337 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
7338 elt_type, TYPE_INDEX_TYPE (type0));
7343 struct type *elt_type0;
7346 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
7347 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
7349 /* NOTE: result---the fixed version of elt_type0---should never
7350 depend on the contents of the array in properly constructed
7352 /* Create a fixed version of the array element type.
7353 We're not providing the address of an element here,
7354 and thus the actual object value cannot be inspected to do
7355 the conversion. This should not be a problem, since arrays of
7356 unconstrained objects are not allowed. In particular, all
7357 the elements of an array of a tagged type should all be of
7358 the same type specified in the debugging info. No need to
7359 consult the object tag. */
7361 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
7362 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
7364 struct type *range_type =
7365 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i),
7366 dval, TYPE_OBJFILE (type0));
7367 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
7368 result, range_type);
7370 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
7371 error (_("array type with dynamic size is larger than varsize-limit"));
7374 TYPE_FIXED_INSTANCE (result) = 1;
7379 /* A standard type (containing no dynamically sized components)
7380 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7381 DVAL describes a record containing any discriminants used in TYPE0,
7382 and may be NULL if there are none, or if the object of type TYPE at
7383 ADDRESS or in VALADDR contains these discriminants.
7385 If CHECK_TAG is not null, in the case of tagged types, this function
7386 attempts to locate the object's tag and use it to compute the actual
7387 type. However, when ADDRESS is null, we cannot use it to determine the
7388 location of the tag, and therefore compute the tagged type's actual type.
7389 So we return the tagged type without consulting the tag. */
7391 static struct type *
7392 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
7393 CORE_ADDR address, struct value *dval, int check_tag)
7395 type = ada_check_typedef (type);
7396 switch (TYPE_CODE (type))
7400 case TYPE_CODE_STRUCT:
7402 struct type *static_type = to_static_fixed_type (type);
7403 struct type *fixed_record_type =
7404 to_fixed_record_type (type, valaddr, address, NULL);
7405 /* If STATIC_TYPE is a tagged type and we know the object's address,
7406 then we can determine its tag, and compute the object's actual
7407 type from there. Note that we have to use the fixed record
7408 type (the parent part of the record may have dynamic fields
7409 and the way the location of _tag is expressed may depend on
7412 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
7414 struct type *real_type =
7415 type_from_tag (value_tag_from_contents_and_address
7419 if (real_type != NULL)
7420 return to_fixed_record_type (real_type, valaddr, address, NULL);
7422 return fixed_record_type;
7424 case TYPE_CODE_ARRAY:
7425 return to_fixed_array_type (type, dval, 1);
7426 case TYPE_CODE_UNION:
7430 return to_fixed_variant_branch_type (type, valaddr, address, dval);
7434 /* The same as ada_to_fixed_type_1, except that it preserves the type
7435 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7436 ada_to_fixed_type_1 would return the type referenced by TYPE. */
7439 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
7440 CORE_ADDR address, struct value *dval, int check_tag)
7443 struct type *fixed_type =
7444 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
7446 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
7447 && TYPE_TARGET_TYPE (type) == fixed_type)
7453 /* A standard (static-sized) type corresponding as well as possible to
7454 TYPE0, but based on no runtime data. */
7456 static struct type *
7457 to_static_fixed_type (struct type *type0)
7464 if (TYPE_FIXED_INSTANCE (type0))
7467 type0 = ada_check_typedef (type0);
7469 switch (TYPE_CODE (type0))
7473 case TYPE_CODE_STRUCT:
7474 type = dynamic_template_type (type0);
7476 return template_to_static_fixed_type (type);
7478 return template_to_static_fixed_type (type0);
7479 case TYPE_CODE_UNION:
7480 type = ada_find_parallel_type (type0, "___XVU");
7482 return template_to_static_fixed_type (type);
7484 return template_to_static_fixed_type (type0);
7488 /* A static approximation of TYPE with all type wrappers removed. */
7490 static struct type *
7491 static_unwrap_type (struct type *type)
7493 if (ada_is_aligner_type (type))
7495 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
7496 if (ada_type_name (type1) == NULL)
7497 TYPE_NAME (type1) = ada_type_name (type);
7499 return static_unwrap_type (type1);
7503 struct type *raw_real_type = ada_get_base_type (type);
7504 if (raw_real_type == type)
7507 return to_static_fixed_type (raw_real_type);
7511 /* In some cases, incomplete and private types require
7512 cross-references that are not resolved as records (for example,
7514 type FooP is access Foo;
7516 type Foo is array ...;
7517 ). In these cases, since there is no mechanism for producing
7518 cross-references to such types, we instead substitute for FooP a
7519 stub enumeration type that is nowhere resolved, and whose tag is
7520 the name of the actual type. Call these types "non-record stubs". */
7522 /* A type equivalent to TYPE that is not a non-record stub, if one
7523 exists, otherwise TYPE. */
7526 ada_check_typedef (struct type *type)
7531 CHECK_TYPEDEF (type);
7532 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
7533 || !TYPE_STUB (type)
7534 || TYPE_TAG_NAME (type) == NULL)
7538 char *name = TYPE_TAG_NAME (type);
7539 struct type *type1 = ada_find_any_type (name);
7540 return (type1 == NULL) ? type : type1;
7544 /* A value representing the data at VALADDR/ADDRESS as described by
7545 type TYPE0, but with a standard (static-sized) type that correctly
7546 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7547 type, then return VAL0 [this feature is simply to avoid redundant
7548 creation of struct values]. */
7550 static struct value *
7551 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
7554 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
7555 if (type == type0 && val0 != NULL)
7558 return value_from_contents_and_address (type, 0, address);
7561 /* A value representing VAL, but with a standard (static-sized) type
7562 that correctly describes it. Does not necessarily create a new
7565 static struct value *
7566 ada_to_fixed_value (struct value *val)
7568 return ada_to_fixed_value_create (value_type (val),
7569 VALUE_ADDRESS (val) + value_offset (val),
7573 /* A value representing VAL, but with a standard (static-sized) type
7574 chosen to approximate the real type of VAL as well as possible, but
7575 without consulting any runtime values. For Ada dynamic-sized
7576 types, therefore, the type of the result is likely to be inaccurate. */
7579 ada_to_static_fixed_value (struct value *val)
7582 to_static_fixed_type (static_unwrap_type (value_type (val)));
7583 if (type == value_type (val))
7586 return coerce_unspec_val_to_type (val, type);
7592 /* Table mapping attribute numbers to names.
7593 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7595 static const char *attribute_names[] = {
7613 ada_attribute_name (enum exp_opcode n)
7615 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
7616 return attribute_names[n - OP_ATR_FIRST + 1];
7618 return attribute_names[0];
7621 /* Evaluate the 'POS attribute applied to ARG. */
7624 pos_atr (struct value *arg)
7626 struct value *val = coerce_ref (arg);
7627 struct type *type = value_type (val);
7629 if (!discrete_type_p (type))
7630 error (_("'POS only defined on discrete types"));
7632 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7635 LONGEST v = value_as_long (val);
7637 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7639 if (v == TYPE_FIELD_BITPOS (type, i))
7642 error (_("enumeration value is invalid: can't find 'POS"));
7645 return value_as_long (val);
7648 static struct value *
7649 value_pos_atr (struct value *arg)
7651 return value_from_longest (builtin_type_int, pos_atr (arg));
7654 /* Evaluate the TYPE'VAL attribute applied to ARG. */
7656 static struct value *
7657 value_val_atr (struct type *type, struct value *arg)
7659 if (!discrete_type_p (type))
7660 error (_("'VAL only defined on discrete types"));
7661 if (!integer_type_p (value_type (arg)))
7662 error (_("'VAL requires integral argument"));
7664 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7666 long pos = value_as_long (arg);
7667 if (pos < 0 || pos >= TYPE_NFIELDS (type))
7668 error (_("argument to 'VAL out of range"));
7669 return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
7672 return value_from_longest (type, value_as_long (arg));
7678 /* True if TYPE appears to be an Ada character type.
7679 [At the moment, this is true only for Character and Wide_Character;
7680 It is a heuristic test that could stand improvement]. */
7683 ada_is_character_type (struct type *type)
7687 /* If the type code says it's a character, then assume it really is,
7688 and don't check any further. */
7689 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
7692 /* Otherwise, assume it's a character type iff it is a discrete type
7693 with a known character type name. */
7694 name = ada_type_name (type);
7695 return (name != NULL
7696 && (TYPE_CODE (type) == TYPE_CODE_INT
7697 || TYPE_CODE (type) == TYPE_CODE_RANGE)
7698 && (strcmp (name, "character") == 0
7699 || strcmp (name, "wide_character") == 0
7700 || strcmp (name, "wide_wide_character") == 0
7701 || strcmp (name, "unsigned char") == 0));
7704 /* True if TYPE appears to be an Ada string type. */
7707 ada_is_string_type (struct type *type)
7709 type = ada_check_typedef (type);
7711 && TYPE_CODE (type) != TYPE_CODE_PTR
7712 && (ada_is_simple_array_type (type)
7713 || ada_is_array_descriptor_type (type))
7714 && ada_array_arity (type) == 1)
7716 struct type *elttype = ada_array_element_type (type, 1);
7718 return ada_is_character_type (elttype);
7725 /* True if TYPE is a struct type introduced by the compiler to force the
7726 alignment of a value. Such types have a single field with a
7727 distinctive name. */
7730 ada_is_aligner_type (struct type *type)
7732 type = ada_check_typedef (type);
7734 /* If we can find a parallel XVS type, then the XVS type should
7735 be used instead of this type. And hence, this is not an aligner
7737 if (ada_find_parallel_type (type, "___XVS") != NULL)
7740 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
7741 && TYPE_NFIELDS (type) == 1
7742 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
7745 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7746 the parallel type. */
7749 ada_get_base_type (struct type *raw_type)
7751 struct type *real_type_namer;
7752 struct type *raw_real_type;
7754 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
7757 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
7758 if (real_type_namer == NULL
7759 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
7760 || TYPE_NFIELDS (real_type_namer) != 1)
7763 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
7764 if (raw_real_type == NULL)
7767 return raw_real_type;
7770 /* The type of value designated by TYPE, with all aligners removed. */
7773 ada_aligned_type (struct type *type)
7775 if (ada_is_aligner_type (type))
7776 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
7778 return ada_get_base_type (type);
7782 /* The address of the aligned value in an object at address VALADDR
7783 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7786 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
7788 if (ada_is_aligner_type (type))
7789 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
7791 TYPE_FIELD_BITPOS (type,
7792 0) / TARGET_CHAR_BIT);
7799 /* The printed representation of an enumeration literal with encoded
7800 name NAME. The value is good to the next call of ada_enum_name. */
7802 ada_enum_name (const char *name)
7804 static char *result;
7805 static size_t result_len = 0;
7808 /* First, unqualify the enumeration name:
7809 1. Search for the last '.' character. If we find one, then skip
7810 all the preceeding characters, the unqualified name starts
7811 right after that dot.
7812 2. Otherwise, we may be debugging on a target where the compiler
7813 translates dots into "__". Search forward for double underscores,
7814 but stop searching when we hit an overloading suffix, which is
7815 of the form "__" followed by digits. */
7817 tmp = strrchr (name, '.');
7822 while ((tmp = strstr (name, "__")) != NULL)
7824 if (isdigit (tmp[2]))
7834 if (name[1] == 'U' || name[1] == 'W')
7836 if (sscanf (name + 2, "%x", &v) != 1)
7842 GROW_VECT (result, result_len, 16);
7843 if (isascii (v) && isprint (v))
7844 sprintf (result, "'%c'", v);
7845 else if (name[1] == 'U')
7846 sprintf (result, "[\"%02x\"]", v);
7848 sprintf (result, "[\"%04x\"]", v);
7854 tmp = strstr (name, "__");
7856 tmp = strstr (name, "$");
7859 GROW_VECT (result, result_len, tmp - name + 1);
7860 strncpy (result, name, tmp - name);
7861 result[tmp - name] = '\0';
7869 static struct value *
7870 evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos,
7873 return (*exp->language_defn->la_exp_desc->evaluate_exp)
7874 (expect_type, exp, pos, noside);
7877 /* Evaluate the subexpression of EXP starting at *POS as for
7878 evaluate_type, updating *POS to point just past the evaluated
7881 static struct value *
7882 evaluate_subexp_type (struct expression *exp, int *pos)
7884 return (*exp->language_defn->la_exp_desc->evaluate_exp)
7885 (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
7888 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7891 static struct value *
7892 unwrap_value (struct value *val)
7894 struct type *type = ada_check_typedef (value_type (val));
7895 if (ada_is_aligner_type (type))
7897 struct value *v = ada_value_struct_elt (val, "F", 0);
7898 struct type *val_type = ada_check_typedef (value_type (v));
7899 if (ada_type_name (val_type) == NULL)
7900 TYPE_NAME (val_type) = ada_type_name (type);
7902 return unwrap_value (v);
7906 struct type *raw_real_type =
7907 ada_check_typedef (ada_get_base_type (type));
7909 if (type == raw_real_type)
7913 coerce_unspec_val_to_type
7914 (val, ada_to_fixed_type (raw_real_type, 0,
7915 VALUE_ADDRESS (val) + value_offset (val),
7920 static struct value *
7921 cast_to_fixed (struct type *type, struct value *arg)
7925 if (type == value_type (arg))
7927 else if (ada_is_fixed_point_type (value_type (arg)))
7928 val = ada_float_to_fixed (type,
7929 ada_fixed_to_float (value_type (arg),
7930 value_as_long (arg)));
7934 value_as_double (value_cast (builtin_type_double, value_copy (arg)));
7935 val = ada_float_to_fixed (type, argd);
7938 return value_from_longest (type, val);
7941 static struct value *
7942 cast_from_fixed_to_double (struct value *arg)
7944 DOUBLEST val = ada_fixed_to_float (value_type (arg),
7945 value_as_long (arg));
7946 return value_from_double (builtin_type_double, val);
7949 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7950 return the converted value. */
7952 static struct value *
7953 coerce_for_assign (struct type *type, struct value *val)
7955 struct type *type2 = value_type (val);
7959 type2 = ada_check_typedef (type2);
7960 type = ada_check_typedef (type);
7962 if (TYPE_CODE (type2) == TYPE_CODE_PTR
7963 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7965 val = ada_value_ind (val);
7966 type2 = value_type (val);
7969 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
7970 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7972 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
7973 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
7974 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
7975 error (_("Incompatible types in assignment"));
7976 deprecated_set_value_type (val, type);
7981 static struct value *
7982 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
7985 struct type *type1, *type2;
7988 arg1 = coerce_ref (arg1);
7989 arg2 = coerce_ref (arg2);
7990 type1 = base_type (ada_check_typedef (value_type (arg1)));
7991 type2 = base_type (ada_check_typedef (value_type (arg2)));
7993 if (TYPE_CODE (type1) != TYPE_CODE_INT
7994 || TYPE_CODE (type2) != TYPE_CODE_INT)
7995 return value_binop (arg1, arg2, op);
8004 return value_binop (arg1, arg2, op);
8007 v2 = value_as_long (arg2);
8009 error (_("second operand of %s must not be zero."), op_string (op));
8011 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
8012 return value_binop (arg1, arg2, op);
8014 v1 = value_as_long (arg1);
8019 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8020 v += v > 0 ? -1 : 1;
8028 /* Should not reach this point. */
8032 val = allocate_value (type1);
8033 store_unsigned_integer (value_contents_raw (val),
8034 TYPE_LENGTH (value_type (val)), v);
8039 ada_value_equal (struct value *arg1, struct value *arg2)
8041 if (ada_is_direct_array_type (value_type (arg1))
8042 || ada_is_direct_array_type (value_type (arg2)))
8044 /* Automatically dereference any array reference before
8045 we attempt to perform the comparison. */
8046 arg1 = ada_coerce_ref (arg1);
8047 arg2 = ada_coerce_ref (arg2);
8049 arg1 = ada_coerce_to_simple_array (arg1);
8050 arg2 = ada_coerce_to_simple_array (arg2);
8051 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
8052 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
8053 error (_("Attempt to compare array with non-array"));
8054 /* FIXME: The following works only for types whose
8055 representations use all bits (no padding or undefined bits)
8056 and do not have user-defined equality. */
8058 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
8059 && memcmp (value_contents (arg1), value_contents (arg2),
8060 TYPE_LENGTH (value_type (arg1))) == 0;
8062 return value_equal (arg1, arg2);
8065 /* Total number of component associations in the aggregate starting at
8066 index PC in EXP. Assumes that index PC is the start of an
8070 num_component_specs (struct expression *exp, int pc)
8073 m = exp->elts[pc + 1].longconst;
8076 for (i = 0; i < m; i += 1)
8078 switch (exp->elts[pc].opcode)
8084 n += exp->elts[pc + 1].longconst;
8087 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
8092 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
8093 component of LHS (a simple array or a record), updating *POS past
8094 the expression, assuming that LHS is contained in CONTAINER. Does
8095 not modify the inferior's memory, nor does it modify LHS (unless
8096 LHS == CONTAINER). */
8099 assign_component (struct value *container, struct value *lhs, LONGEST index,
8100 struct expression *exp, int *pos)
8102 struct value *mark = value_mark ();
8104 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
8106 struct value *index_val = value_from_longest (builtin_type_int, index);
8107 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
8111 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
8112 elt = ada_to_fixed_value (unwrap_value (elt));
8115 if (exp->elts[*pos].opcode == OP_AGGREGATE)
8116 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
8118 value_assign_to_component (container, elt,
8119 ada_evaluate_subexp (NULL, exp, pos,
8122 value_free_to_mark (mark);
8125 /* Assuming that LHS represents an lvalue having a record or array
8126 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8127 of that aggregate's value to LHS, advancing *POS past the
8128 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8129 lvalue containing LHS (possibly LHS itself). Does not modify
8130 the inferior's memory, nor does it modify the contents of
8131 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
8133 static struct value *
8134 assign_aggregate (struct value *container,
8135 struct value *lhs, struct expression *exp,
8136 int *pos, enum noside noside)
8138 struct type *lhs_type;
8139 int n = exp->elts[*pos+1].longconst;
8140 LONGEST low_index, high_index;
8143 int max_indices, num_indices;
8144 int is_array_aggregate;
8146 struct value *mark = value_mark ();
8149 if (noside != EVAL_NORMAL)
8152 for (i = 0; i < n; i += 1)
8153 ada_evaluate_subexp (NULL, exp, pos, noside);
8157 container = ada_coerce_ref (container);
8158 if (ada_is_direct_array_type (value_type (container)))
8159 container = ada_coerce_to_simple_array (container);
8160 lhs = ada_coerce_ref (lhs);
8161 if (!deprecated_value_modifiable (lhs))
8162 error (_("Left operand of assignment is not a modifiable lvalue."));
8164 lhs_type = value_type (lhs);
8165 if (ada_is_direct_array_type (lhs_type))
8167 lhs = ada_coerce_to_simple_array (lhs);
8168 lhs_type = value_type (lhs);
8169 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
8170 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
8171 is_array_aggregate = 1;
8173 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
8176 high_index = num_visible_fields (lhs_type) - 1;
8177 is_array_aggregate = 0;
8180 error (_("Left-hand side must be array or record."));
8182 num_specs = num_component_specs (exp, *pos - 3);
8183 max_indices = 4 * num_specs + 4;
8184 indices = alloca (max_indices * sizeof (indices[0]));
8185 indices[0] = indices[1] = low_index - 1;
8186 indices[2] = indices[3] = high_index + 1;
8189 for (i = 0; i < n; i += 1)
8191 switch (exp->elts[*pos].opcode)
8194 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
8195 &num_indices, max_indices,
8196 low_index, high_index);
8199 aggregate_assign_positional (container, lhs, exp, pos, indices,
8200 &num_indices, max_indices,
8201 low_index, high_index);
8205 error (_("Misplaced 'others' clause"));
8206 aggregate_assign_others (container, lhs, exp, pos, indices,
8207 num_indices, low_index, high_index);
8210 error (_("Internal error: bad aggregate clause"));
8217 /* Assign into the component of LHS indexed by the OP_POSITIONAL
8218 construct at *POS, updating *POS past the construct, given that
8219 the positions are relative to lower bound LOW, where HIGH is the
8220 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8221 updating *NUM_INDICES as needed. CONTAINER is as for
8222 assign_aggregate. */
8224 aggregate_assign_positional (struct value *container,
8225 struct value *lhs, struct expression *exp,
8226 int *pos, LONGEST *indices, int *num_indices,
8227 int max_indices, LONGEST low, LONGEST high)
8229 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
8231 if (ind - 1 == high)
8232 warning (_("Extra components in aggregate ignored."));
8235 add_component_interval (ind, ind, indices, num_indices, max_indices);
8237 assign_component (container, lhs, ind, exp, pos);
8240 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8243 /* Assign into the components of LHS indexed by the OP_CHOICES
8244 construct at *POS, updating *POS past the construct, given that
8245 the allowable indices are LOW..HIGH. Record the indices assigned
8246 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8247 needed. CONTAINER is as for assign_aggregate. */
8249 aggregate_assign_from_choices (struct value *container,
8250 struct value *lhs, struct expression *exp,
8251 int *pos, LONGEST *indices, int *num_indices,
8252 int max_indices, LONGEST low, LONGEST high)
8255 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
8256 int choice_pos, expr_pc;
8257 int is_array = ada_is_direct_array_type (value_type (lhs));
8259 choice_pos = *pos += 3;
8261 for (j = 0; j < n_choices; j += 1)
8262 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8264 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8266 for (j = 0; j < n_choices; j += 1)
8268 LONGEST lower, upper;
8269 enum exp_opcode op = exp->elts[choice_pos].opcode;
8270 if (op == OP_DISCRETE_RANGE)
8273 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8275 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8280 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
8291 name = &exp->elts[choice_pos + 2].string;
8294 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
8297 error (_("Invalid record component association."));
8299 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
8301 if (! find_struct_field (name, value_type (lhs), 0,
8302 NULL, NULL, NULL, NULL, &ind))
8303 error (_("Unknown component name: %s."), name);
8304 lower = upper = ind;
8307 if (lower <= upper && (lower < low || upper > high))
8308 error (_("Index in component association out of bounds."));
8310 add_component_interval (lower, upper, indices, num_indices,
8312 while (lower <= upper)
8316 assign_component (container, lhs, lower, exp, &pos1);
8322 /* Assign the value of the expression in the OP_OTHERS construct in
8323 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8324 have not been previously assigned. The index intervals already assigned
8325 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8326 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
8328 aggregate_assign_others (struct value *container,
8329 struct value *lhs, struct expression *exp,
8330 int *pos, LONGEST *indices, int num_indices,
8331 LONGEST low, LONGEST high)
8334 int expr_pc = *pos+1;
8336 for (i = 0; i < num_indices - 2; i += 2)
8339 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
8343 assign_component (container, lhs, ind, exp, &pos);
8346 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8349 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
8350 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8351 modifying *SIZE as needed. It is an error if *SIZE exceeds
8352 MAX_SIZE. The resulting intervals do not overlap. */
8354 add_component_interval (LONGEST low, LONGEST high,
8355 LONGEST* indices, int *size, int max_size)
8358 for (i = 0; i < *size; i += 2) {
8359 if (high >= indices[i] && low <= indices[i + 1])
8362 for (kh = i + 2; kh < *size; kh += 2)
8363 if (high < indices[kh])
8365 if (low < indices[i])
8367 indices[i + 1] = indices[kh - 1];
8368 if (high > indices[i + 1])
8369 indices[i + 1] = high;
8370 memcpy (indices + i + 2, indices + kh, *size - kh);
8371 *size -= kh - i - 2;
8374 else if (high < indices[i])
8378 if (*size == max_size)
8379 error (_("Internal error: miscounted aggregate components."));
8381 for (j = *size-1; j >= i+2; j -= 1)
8382 indices[j] = indices[j - 2];
8384 indices[i + 1] = high;
8387 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8390 static struct value *
8391 ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
8393 if (type == ada_check_typedef (value_type (arg2)))
8396 if (ada_is_fixed_point_type (type))
8397 return (cast_to_fixed (type, arg2));
8399 if (ada_is_fixed_point_type (value_type (arg2)))
8400 return value_cast (type, cast_from_fixed_to_double (arg2));
8402 return value_cast (type, arg2);
8405 static struct value *
8406 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
8407 int *pos, enum noside noside)
8410 int tem, tem2, tem3;
8412 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
8415 struct value **argvec;
8419 op = exp->elts[pc].opcode;
8425 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
8426 arg1 = unwrap_value (arg1);
8428 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8429 then we need to perform the conversion manually, because
8430 evaluate_subexp_standard doesn't do it. This conversion is
8431 necessary in Ada because the different kinds of float/fixed
8432 types in Ada have different representations.
8434 Similarly, we need to perform the conversion from OP_LONG
8436 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
8437 arg1 = ada_value_cast (expect_type, arg1, noside);
8443 struct value *result;
8445 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
8446 /* The result type will have code OP_STRING, bashed there from
8447 OP_ARRAY. Bash it back. */
8448 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
8449 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
8455 type = exp->elts[pc + 1].type;
8456 arg1 = evaluate_subexp (type, exp, pos, noside);
8457 if (noside == EVAL_SKIP)
8459 arg1 = ada_value_cast (type, arg1, noside);
8464 type = exp->elts[pc + 1].type;
8465 return ada_evaluate_subexp (type, exp, pos, noside);
8468 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8469 if (exp->elts[*pos].opcode == OP_AGGREGATE)
8471 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
8472 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
8474 return ada_value_assign (arg1, arg1);
8476 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8477 except if the lhs of our assignment is a convenience variable.
8478 In the case of assigning to a convenience variable, the lhs
8479 should be exactly the result of the evaluation of the rhs. */
8480 type = value_type (arg1);
8481 if (VALUE_LVAL (arg1) == lval_internalvar)
8483 arg2 = evaluate_subexp (type, exp, pos, noside);
8484 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
8486 if (ada_is_fixed_point_type (value_type (arg1)))
8487 arg2 = cast_to_fixed (value_type (arg1), arg2);
8488 else if (ada_is_fixed_point_type (value_type (arg2)))
8490 (_("Fixed-point values must be assigned to fixed-point variables"));
8492 arg2 = coerce_for_assign (value_type (arg1), arg2);
8493 return ada_value_assign (arg1, arg2);
8496 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8497 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8498 if (noside == EVAL_SKIP)
8500 if ((ada_is_fixed_point_type (value_type (arg1))
8501 || ada_is_fixed_point_type (value_type (arg2)))
8502 && value_type (arg1) != value_type (arg2))
8503 error (_("Operands of fixed-point addition must have the same type"));
8504 /* Do the addition, and cast the result to the type of the first
8505 argument. We cannot cast the result to a reference type, so if
8506 ARG1 is a reference type, find its underlying type. */
8507 type = value_type (arg1);
8508 while (TYPE_CODE (type) == TYPE_CODE_REF)
8509 type = TYPE_TARGET_TYPE (type);
8510 return value_cast (type, value_add (arg1, arg2));
8513 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8514 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8515 if (noside == EVAL_SKIP)
8517 if ((ada_is_fixed_point_type (value_type (arg1))
8518 || ada_is_fixed_point_type (value_type (arg2)))
8519 && value_type (arg1) != value_type (arg2))
8520 error (_("Operands of fixed-point subtraction must have the same type"));
8521 /* Do the substraction, and cast the result to the type of the first
8522 argument. We cannot cast the result to a reference type, so if
8523 ARG1 is a reference type, find its underlying type. */
8524 type = value_type (arg1);
8525 while (TYPE_CODE (type) == TYPE_CODE_REF)
8526 type = TYPE_TARGET_TYPE (type);
8527 return value_cast (type, value_sub (arg1, arg2));
8531 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8532 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8533 if (noside == EVAL_SKIP)
8535 else if (noside == EVAL_AVOID_SIDE_EFFECTS
8536 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
8537 return value_zero (value_type (arg1), not_lval);
8540 if (ada_is_fixed_point_type (value_type (arg1)))
8541 arg1 = cast_from_fixed_to_double (arg1);
8542 if (ada_is_fixed_point_type (value_type (arg2)))
8543 arg2 = cast_from_fixed_to_double (arg2);
8544 return ada_value_binop (arg1, arg2, op);
8549 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8550 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8551 if (noside == EVAL_SKIP)
8553 else if (noside == EVAL_AVOID_SIDE_EFFECTS
8554 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
8555 return value_zero (value_type (arg1), not_lval);
8557 return ada_value_binop (arg1, arg2, op);
8560 case BINOP_NOTEQUAL:
8561 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8562 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
8563 if (noside == EVAL_SKIP)
8565 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8568 tem = ada_value_equal (arg1, arg2);
8569 if (op == BINOP_NOTEQUAL)
8571 return value_from_longest (LA_BOOL_TYPE, (LONGEST) tem);
8574 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8575 if (noside == EVAL_SKIP)
8577 else if (ada_is_fixed_point_type (value_type (arg1)))
8578 return value_cast (value_type (arg1), value_neg (arg1));
8580 return value_neg (arg1);
8582 case BINOP_LOGICAL_AND:
8583 case BINOP_LOGICAL_OR:
8584 case UNOP_LOGICAL_NOT:
8589 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8590 return value_cast (LA_BOOL_TYPE, val);
8593 case BINOP_BITWISE_AND:
8594 case BINOP_BITWISE_IOR:
8595 case BINOP_BITWISE_XOR:
8599 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
8601 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8603 return value_cast (value_type (arg1), val);
8609 /* Tagged types are a little special in the fact that the real type
8610 is dynamic and can only be determined by inspecting the object
8611 value. So even if we're support to do an EVAL_AVOID_SIDE_EFFECTS
8612 evaluation, we force an EVAL_NORMAL evaluation for tagged types. */
8613 if (noside == EVAL_AVOID_SIDE_EFFECTS
8614 && ada_is_tagged_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol), 1))
8615 noside = EVAL_NORMAL;
8617 if (noside == EVAL_SKIP)
8622 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
8623 /* Only encountered when an unresolved symbol occurs in a
8624 context other than a function call, in which case, it is
8626 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8627 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
8628 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8632 (to_static_fixed_type
8633 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
8639 unwrap_value (evaluate_subexp_standard
8640 (expect_type, exp, pos, noside));
8641 return ada_to_fixed_value (arg1);
8647 /* Allocate arg vector, including space for the function to be
8648 called in argvec[0] and a terminating NULL. */
8649 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8651 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
8653 if (exp->elts[*pos].opcode == OP_VAR_VALUE
8654 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
8655 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8656 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
8659 for (tem = 0; tem <= nargs; tem += 1)
8660 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8663 if (noside == EVAL_SKIP)
8667 if (ada_is_packed_array_type (desc_base_type (value_type (argvec[0]))))
8668 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
8669 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
8670 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
8671 && VALUE_LVAL (argvec[0]) == lval_memory))
8672 argvec[0] = value_addr (argvec[0]);
8674 type = ada_check_typedef (value_type (argvec[0]));
8675 if (TYPE_CODE (type) == TYPE_CODE_PTR)
8677 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
8679 case TYPE_CODE_FUNC:
8680 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8682 case TYPE_CODE_ARRAY:
8684 case TYPE_CODE_STRUCT:
8685 if (noside != EVAL_AVOID_SIDE_EFFECTS)
8686 argvec[0] = ada_value_ind (argvec[0]);
8687 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8690 error (_("cannot subscript or call something of type `%s'"),
8691 ada_type_name (value_type (argvec[0])));
8696 switch (TYPE_CODE (type))
8698 case TYPE_CODE_FUNC:
8699 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8700 return allocate_value (TYPE_TARGET_TYPE (type));
8701 return call_function_by_hand (argvec[0], nargs, argvec + 1);
8702 case TYPE_CODE_STRUCT:
8706 arity = ada_array_arity (type);
8707 type = ada_array_element_type (type, nargs);
8709 error (_("cannot subscript or call a record"));
8711 error (_("wrong number of subscripts; expecting %d"), arity);
8712 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8713 return value_zero (ada_aligned_type (type), lval_memory);
8715 unwrap_value (ada_value_subscript
8716 (argvec[0], nargs, argvec + 1));
8718 case TYPE_CODE_ARRAY:
8719 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8721 type = ada_array_element_type (type, nargs);
8723 error (_("element type of array unknown"));
8725 return value_zero (ada_aligned_type (type), lval_memory);
8728 unwrap_value (ada_value_subscript
8729 (ada_coerce_to_simple_array (argvec[0]),
8730 nargs, argvec + 1));
8731 case TYPE_CODE_PTR: /* Pointer to array */
8732 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
8733 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8735 type = ada_array_element_type (type, nargs);
8737 error (_("element type of array unknown"));
8739 return value_zero (ada_aligned_type (type), lval_memory);
8742 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
8743 nargs, argvec + 1));
8746 error (_("Attempt to index or call something other than an "
8747 "array or function"));
8752 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8753 struct value *low_bound_val =
8754 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8755 struct value *high_bound_val =
8756 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8759 low_bound_val = coerce_ref (low_bound_val);
8760 high_bound_val = coerce_ref (high_bound_val);
8761 low_bound = pos_atr (low_bound_val);
8762 high_bound = pos_atr (high_bound_val);
8764 if (noside == EVAL_SKIP)
8767 /* If this is a reference to an aligner type, then remove all
8769 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8770 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
8771 TYPE_TARGET_TYPE (value_type (array)) =
8772 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
8774 if (ada_is_packed_array_type (value_type (array)))
8775 error (_("cannot slice a packed array"));
8777 /* If this is a reference to an array or an array lvalue,
8778 convert to a pointer. */
8779 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8780 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
8781 && VALUE_LVAL (array) == lval_memory))
8782 array = value_addr (array);
8784 if (noside == EVAL_AVOID_SIDE_EFFECTS
8785 && ada_is_array_descriptor_type (ada_check_typedef
8786 (value_type (array))))
8787 return empty_array (ada_type_of_array (array, 0), low_bound);
8789 array = ada_coerce_to_simple_array_ptr (array);
8791 /* If we have more than one level of pointer indirection,
8792 dereference the value until we get only one level. */
8793 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
8794 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
8796 array = value_ind (array);
8798 /* Make sure we really do have an array type before going further,
8799 to avoid a SEGV when trying to get the index type or the target
8800 type later down the road if the debug info generated by
8801 the compiler is incorrect or incomplete. */
8802 if (!ada_is_simple_array_type (value_type (array)))
8803 error (_("cannot take slice of non-array"));
8805 if (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR)
8807 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
8808 return empty_array (TYPE_TARGET_TYPE (value_type (array)),
8812 struct type *arr_type0 =
8813 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array)),
8815 return ada_value_slice_ptr (array, arr_type0,
8816 longest_to_int (low_bound),
8817 longest_to_int (high_bound));
8820 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8822 else if (high_bound < low_bound)
8823 return empty_array (value_type (array), low_bound);
8825 return ada_value_slice (array, longest_to_int (low_bound),
8826 longest_to_int (high_bound));
8831 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8832 type = exp->elts[pc + 1].type;
8834 if (noside == EVAL_SKIP)
8837 switch (TYPE_CODE (type))
8840 lim_warning (_("Membership test incompletely implemented; "
8841 "always returns true"));
8842 return value_from_longest (builtin_type_int, (LONGEST) 1);
8844 case TYPE_CODE_RANGE:
8845 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
8846 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
8848 value_from_longest (builtin_type_int,
8849 (value_less (arg1, arg3)
8850 || value_equal (arg1, arg3))
8851 && (value_less (arg2, arg1)
8852 || value_equal (arg2, arg1)));
8855 case BINOP_IN_BOUNDS:
8857 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8858 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8860 if (noside == EVAL_SKIP)
8863 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8864 return value_zero (builtin_type_int, not_lval);
8866 tem = longest_to_int (exp->elts[pc + 1].longconst);
8868 if (tem < 1 || tem > ada_array_arity (value_type (arg2)))
8869 error (_("invalid dimension number to 'range"));
8871 arg3 = ada_array_bound (arg2, tem, 1);
8872 arg2 = ada_array_bound (arg2, tem, 0);
8875 value_from_longest (builtin_type_int,
8876 (value_less (arg1, arg3)
8877 || value_equal (arg1, arg3))
8878 && (value_less (arg2, arg1)
8879 || value_equal (arg2, arg1)));
8881 case TERNOP_IN_RANGE:
8882 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8883 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8884 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8886 if (noside == EVAL_SKIP)
8890 value_from_longest (builtin_type_int,
8891 (value_less (arg1, arg3)
8892 || value_equal (arg1, arg3))
8893 && (value_less (arg2, arg1)
8894 || value_equal (arg2, arg1)));
8900 struct type *type_arg;
8901 if (exp->elts[*pos].opcode == OP_TYPE)
8903 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
8905 type_arg = exp->elts[pc + 2].type;
8909 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8913 if (exp->elts[*pos].opcode != OP_LONG)
8914 error (_("Invalid operand to '%s"), ada_attribute_name (op));
8915 tem = longest_to_int (exp->elts[*pos + 2].longconst);
8918 if (noside == EVAL_SKIP)
8921 if (type_arg == NULL)
8923 arg1 = ada_coerce_ref (arg1);
8925 if (ada_is_packed_array_type (value_type (arg1)))
8926 arg1 = ada_coerce_to_simple_array (arg1);
8928 if (tem < 1 || tem > ada_array_arity (value_type (arg1)))
8929 error (_("invalid dimension number to '%s"),
8930 ada_attribute_name (op));
8932 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8934 type = ada_index_type (value_type (arg1), tem);
8937 (_("attempt to take bound of something that is not an array"));
8938 return allocate_value (type);
8943 default: /* Should never happen. */
8944 error (_("unexpected attribute encountered"));
8946 return ada_array_bound (arg1, tem, 0);
8948 return ada_array_bound (arg1, tem, 1);
8950 return ada_array_length (arg1, tem);
8953 else if (discrete_type_p (type_arg))
8955 struct type *range_type;
8956 char *name = ada_type_name (type_arg);
8958 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
8960 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
8961 if (range_type == NULL)
8962 range_type = type_arg;
8966 error (_("unexpected attribute encountered"));
8968 return value_from_longest
8969 (range_type, discrete_type_low_bound (range_type));
8971 return value_from_longest
8972 (range_type, discrete_type_high_bound (range_type));
8974 error (_("the 'length attribute applies only to array types"));
8977 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
8978 error (_("unimplemented type attribute"));
8983 if (ada_is_packed_array_type (type_arg))
8984 type_arg = decode_packed_array_type (type_arg);
8986 if (tem < 1 || tem > ada_array_arity (type_arg))
8987 error (_("invalid dimension number to '%s"),
8988 ada_attribute_name (op));
8990 type = ada_index_type (type_arg, tem);
8993 (_("attempt to take bound of something that is not an array"));
8994 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8995 return allocate_value (type);
9000 error (_("unexpected attribute encountered"));
9002 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
9003 return value_from_longest (type, low);
9005 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
9006 return value_from_longest (type, high);
9008 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
9009 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
9010 return value_from_longest (type, high - low + 1);
9016 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9017 if (noside == EVAL_SKIP)
9020 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9021 return value_zero (ada_tag_type (arg1), not_lval);
9023 return ada_value_tag (arg1);
9027 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9028 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9029 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9030 if (noside == EVAL_SKIP)
9032 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9033 return value_zero (value_type (arg1), not_lval);
9035 return value_binop (arg1, arg2,
9036 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
9038 case OP_ATR_MODULUS:
9040 struct type *type_arg = exp->elts[pc + 2].type;
9041 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9043 if (noside == EVAL_SKIP)
9046 if (!ada_is_modular_type (type_arg))
9047 error (_("'modulus must be applied to modular type"));
9049 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
9050 ada_modulus (type_arg));
9055 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9056 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9057 if (noside == EVAL_SKIP)
9059 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9060 return value_zero (builtin_type_int, not_lval);
9062 return value_pos_atr (arg1);
9065 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9066 if (noside == EVAL_SKIP)
9068 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9069 return value_zero (builtin_type_int, not_lval);
9071 return value_from_longest (builtin_type_int,
9073 * TYPE_LENGTH (value_type (arg1)));
9076 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9077 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9078 type = exp->elts[pc + 2].type;
9079 if (noside == EVAL_SKIP)
9081 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9082 return value_zero (type, not_lval);
9084 return value_val_atr (type, arg1);
9087 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9088 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9089 if (noside == EVAL_SKIP)
9091 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9092 return value_zero (value_type (arg1), not_lval);
9094 return value_binop (arg1, arg2, op);
9097 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9098 if (noside == EVAL_SKIP)
9104 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9105 if (noside == EVAL_SKIP)
9107 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
9108 return value_neg (arg1);
9113 if (expect_type && TYPE_CODE (expect_type) == TYPE_CODE_PTR)
9114 expect_type = TYPE_TARGET_TYPE (ada_check_typedef (expect_type));
9115 arg1 = evaluate_subexp (expect_type, exp, pos, noside);
9116 if (noside == EVAL_SKIP)
9118 type = ada_check_typedef (value_type (arg1));
9119 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9121 if (ada_is_array_descriptor_type (type))
9122 /* GDB allows dereferencing GNAT array descriptors. */
9124 struct type *arrType = ada_type_of_array (arg1, 0);
9125 if (arrType == NULL)
9126 error (_("Attempt to dereference null array pointer."));
9127 return value_at_lazy (arrType, 0);
9129 else if (TYPE_CODE (type) == TYPE_CODE_PTR
9130 || TYPE_CODE (type) == TYPE_CODE_REF
9131 /* In C you can dereference an array to get the 1st elt. */
9132 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
9134 type = to_static_fixed_type
9136 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
9138 return value_zero (type, lval_memory);
9140 else if (TYPE_CODE (type) == TYPE_CODE_INT)
9141 /* GDB allows dereferencing an int. */
9142 return value_zero (builtin_type_int, lval_memory);
9144 error (_("Attempt to take contents of a non-pointer value."));
9146 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
9147 type = ada_check_typedef (value_type (arg1));
9149 if (ada_is_array_descriptor_type (type))
9150 /* GDB allows dereferencing GNAT array descriptors. */
9151 return ada_coerce_to_simple_array (arg1);
9153 return ada_value_ind (arg1);
9155 case STRUCTOP_STRUCT:
9156 tem = longest_to_int (exp->elts[pc + 1].longconst);
9157 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
9158 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9159 if (noside == EVAL_SKIP)
9161 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9163 struct type *type1 = value_type (arg1);
9164 if (ada_is_tagged_type (type1, 1))
9166 type = ada_lookup_struct_elt_type (type1,
9167 &exp->elts[pc + 2].string,
9170 /* In this case, we assume that the field COULD exist
9171 in some extension of the type. Return an object of
9172 "type" void, which will match any formal
9173 (see ada_type_match). */
9174 return value_zero (builtin_type_void, lval_memory);
9178 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
9181 return value_zero (ada_aligned_type (type), lval_memory);
9185 ada_to_fixed_value (unwrap_value
9186 (ada_value_struct_elt
9187 (arg1, &exp->elts[pc + 2].string, 0)));
9189 /* The value is not supposed to be used. This is here to make it
9190 easier to accommodate expressions that contain types. */
9192 if (noside == EVAL_SKIP)
9194 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9195 return allocate_value (exp->elts[pc + 1].type);
9197 error (_("Attempt to use a type name as an expression"));
9202 case OP_DISCRETE_RANGE:
9205 if (noside == EVAL_NORMAL)
9209 error (_("Undefined name, ambiguous name, or renaming used in "
9210 "component association: %s."), &exp->elts[pc+2].string);
9212 error (_("Aggregates only allowed on the right of an assignment"));
9214 internal_error (__FILE__, __LINE__, _("aggregate apparently mangled"));
9217 ada_forward_operator_length (exp, pc, &oplen, &nargs);
9219 for (tem = 0; tem < nargs; tem += 1)
9220 ada_evaluate_subexp (NULL, exp, pos, noside);
9225 return value_from_longest (builtin_type_long, (LONGEST) 1);
9231 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9232 type name that encodes the 'small and 'delta information.
9233 Otherwise, return NULL. */
9236 fixed_type_info (struct type *type)
9238 const char *name = ada_type_name (type);
9239 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
9241 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
9243 const char *tail = strstr (name, "___XF_");
9249 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
9250 return fixed_type_info (TYPE_TARGET_TYPE (type));
9255 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9258 ada_is_fixed_point_type (struct type *type)
9260 return fixed_type_info (type) != NULL;
9263 /* Return non-zero iff TYPE represents a System.Address type. */
9266 ada_is_system_address_type (struct type *type)
9268 return (TYPE_NAME (type)
9269 && strcmp (TYPE_NAME (type), "system__address") == 0);
9272 /* Assuming that TYPE is the representation of an Ada fixed-point
9273 type, return its delta, or -1 if the type is malformed and the
9274 delta cannot be determined. */
9277 ada_delta (struct type *type)
9279 const char *encoding = fixed_type_info (type);
9282 if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
9285 return (DOUBLEST) num / (DOUBLEST) den;
9288 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9289 factor ('SMALL value) associated with the type. */
9292 scaling_factor (struct type *type)
9294 const char *encoding = fixed_type_info (type);
9295 unsigned long num0, den0, num1, den1;
9298 n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);
9303 return (DOUBLEST) num1 / (DOUBLEST) den1;
9305 return (DOUBLEST) num0 / (DOUBLEST) den0;
9309 /* Assuming that X is the representation of a value of fixed-point
9310 type TYPE, return its floating-point equivalent. */
9313 ada_fixed_to_float (struct type *type, LONGEST x)
9315 return (DOUBLEST) x *scaling_factor (type);
9318 /* The representation of a fixed-point value of type TYPE
9319 corresponding to the value X. */
9322 ada_float_to_fixed (struct type *type, DOUBLEST x)
9324 return (LONGEST) (x / scaling_factor (type) + 0.5);
9328 /* VAX floating formats */
9330 /* Non-zero iff TYPE represents one of the special VAX floating-point
9334 ada_is_vax_floating_type (struct type *type)
9337 (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
9340 && (TYPE_CODE (type) == TYPE_CODE_INT
9341 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9342 && strncmp (ada_type_name (type) + name_len - 6, "___XF", 5) == 0;
9345 /* The type of special VAX floating-point type this is, assuming
9346 ada_is_vax_floating_point. */
9349 ada_vax_float_type_suffix (struct type *type)
9351 return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
9354 /* A value representing the special debugging function that outputs
9355 VAX floating-point values of the type represented by TYPE. Assumes
9356 ada_is_vax_floating_type (TYPE). */
9359 ada_vax_float_print_function (struct type *type)
9361 switch (ada_vax_float_type_suffix (type))
9364 return get_var_value ("DEBUG_STRING_F", 0);
9366 return get_var_value ("DEBUG_STRING_D", 0);
9368 return get_var_value ("DEBUG_STRING_G", 0);
9370 error (_("invalid VAX floating-point type"));
9377 /* Scan STR beginning at position K for a discriminant name, and
9378 return the value of that discriminant field of DVAL in *PX. If
9379 PNEW_K is not null, put the position of the character beyond the
9380 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9381 not alter *PX and *PNEW_K if unsuccessful. */
9384 scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
9387 static char *bound_buffer = NULL;
9388 static size_t bound_buffer_len = 0;
9391 struct value *bound_val;
9393 if (dval == NULL || str == NULL || str[k] == '\0')
9396 pend = strstr (str + k, "__");
9400 k += strlen (bound);
9404 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
9405 bound = bound_buffer;
9406 strncpy (bound_buffer, str + k, pend - (str + k));
9407 bound[pend - (str + k)] = '\0';
9411 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
9412 if (bound_val == NULL)
9415 *px = value_as_long (bound_val);
9421 /* Value of variable named NAME in the current environment. If
9422 no such variable found, then if ERR_MSG is null, returns 0, and
9423 otherwise causes an error with message ERR_MSG. */
9425 static struct value *
9426 get_var_value (char *name, char *err_msg)
9428 struct ada_symbol_info *syms;
9431 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
9436 if (err_msg == NULL)
9439 error (("%s"), err_msg);
9442 return value_of_variable (syms[0].sym, syms[0].block);
9445 /* Value of integer variable named NAME in the current environment. If
9446 no such variable found, returns 0, and sets *FLAG to 0. If
9447 successful, sets *FLAG to 1. */
9450 get_int_var_value (char *name, int *flag)
9452 struct value *var_val = get_var_value (name, 0);
9464 return value_as_long (var_val);
9469 /* Return a range type whose base type is that of the range type named
9470 NAME in the current environment, and whose bounds are calculated
9471 from NAME according to the GNAT range encoding conventions.
9472 Extract discriminant values, if needed, from DVAL. If a new type
9473 must be created, allocate in OBJFILE's space. The bounds
9474 information, in general, is encoded in NAME, the base type given in
9475 the named range type. */
9477 static struct type *
9478 to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
9480 struct type *raw_type = ada_find_any_type (name);
9481 struct type *base_type;
9484 if (raw_type == NULL)
9485 base_type = builtin_type_int;
9486 else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
9487 base_type = TYPE_TARGET_TYPE (raw_type);
9489 base_type = raw_type;
9491 subtype_info = strstr (name, "___XD");
9492 if (subtype_info == NULL)
9494 LONGEST L = discrete_type_low_bound (raw_type);
9495 LONGEST U = discrete_type_high_bound (raw_type);
9496 if (L < INT_MIN || U > INT_MAX)
9499 return create_range_type (alloc_type (objfile), raw_type,
9500 discrete_type_low_bound (raw_type),
9501 discrete_type_high_bound (raw_type));
9505 static char *name_buf = NULL;
9506 static size_t name_len = 0;
9507 int prefix_len = subtype_info - name;
9513 GROW_VECT (name_buf, name_len, prefix_len + 5);
9514 strncpy (name_buf, name, prefix_len);
9515 name_buf[prefix_len] = '\0';
9518 bounds_str = strchr (subtype_info, '_');
9521 if (*subtype_info == 'L')
9523 if (!ada_scan_number (bounds_str, n, &L, &n)
9524 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
9526 if (bounds_str[n] == '_')
9528 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
9535 strcpy (name_buf + prefix_len, "___L");
9536 L = get_int_var_value (name_buf, &ok);
9539 lim_warning (_("Unknown lower bound, using 1."));
9544 if (*subtype_info == 'U')
9546 if (!ada_scan_number (bounds_str, n, &U, &n)
9547 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
9553 strcpy (name_buf + prefix_len, "___U");
9554 U = get_int_var_value (name_buf, &ok);
9557 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
9562 if (objfile == NULL)
9563 objfile = TYPE_OBJFILE (base_type);
9564 type = create_range_type (alloc_type (objfile), base_type, L, U);
9565 TYPE_NAME (type) = name;
9570 /* True iff NAME is the name of a range type. */
9573 ada_is_range_type_name (const char *name)
9575 return (name != NULL && strstr (name, "___XD"));
9581 /* True iff TYPE is an Ada modular type. */
9584 ada_is_modular_type (struct type *type)
9586 struct type *subranged_type = base_type (type);
9588 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
9589 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
9590 && TYPE_UNSIGNED (subranged_type));
9593 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9596 ada_modulus (struct type * type)
9598 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
9602 /* Ada exception catchpoint support:
9603 ---------------------------------
9605 We support 3 kinds of exception catchpoints:
9606 . catchpoints on Ada exceptions
9607 . catchpoints on unhandled Ada exceptions
9608 . catchpoints on failed assertions
9610 Exceptions raised during failed assertions, or unhandled exceptions
9611 could perfectly be caught with the general catchpoint on Ada exceptions.
9612 However, we can easily differentiate these two special cases, and having
9613 the option to distinguish these two cases from the rest can be useful
9614 to zero-in on certain situations.
9616 Exception catchpoints are a specialized form of breakpoint,
9617 since they rely on inserting breakpoints inside known routines
9618 of the GNAT runtime. The implementation therefore uses a standard
9619 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9622 Support in the runtime for exception catchpoints have been changed
9623 a few times already, and these changes affect the implementation
9624 of these catchpoints. In order to be able to support several
9625 variants of the runtime, we use a sniffer that will determine
9626 the runtime variant used by the program being debugged.
9628 At this time, we do not support the use of conditions on Ada exception
9629 catchpoints. The COND and COND_STRING fields are therefore set
9630 to NULL (most of the time, see below).
9632 Conditions where EXP_STRING, COND, and COND_STRING are used:
9634 When a user specifies the name of a specific exception in the case
9635 of catchpoints on Ada exceptions, we store the name of that exception
9636 in the EXP_STRING. We then translate this request into an actual
9637 condition stored in COND_STRING, and then parse it into an expression
9640 /* The different types of catchpoints that we introduced for catching
9643 enum exception_catchpoint_kind
9646 ex_catch_exception_unhandled,
9650 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
9652 /* A structure that describes how to support exception catchpoints
9653 for a given executable. */
9655 struct exception_support_info
9657 /* The name of the symbol to break on in order to insert
9658 a catchpoint on exceptions. */
9659 const char *catch_exception_sym;
9661 /* The name of the symbol to break on in order to insert
9662 a catchpoint on unhandled exceptions. */
9663 const char *catch_exception_unhandled_sym;
9665 /* The name of the symbol to break on in order to insert
9666 a catchpoint on failed assertions. */
9667 const char *catch_assert_sym;
9669 /* Assuming that the inferior just triggered an unhandled exception
9670 catchpoint, this function is responsible for returning the address
9671 in inferior memory where the name of that exception is stored.
9672 Return zero if the address could not be computed. */
9673 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
9676 static CORE_ADDR ada_unhandled_exception_name_addr (void);
9677 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
9679 /* The following exception support info structure describes how to
9680 implement exception catchpoints with the latest version of the
9681 Ada runtime (as of 2007-03-06). */
9683 static const struct exception_support_info default_exception_support_info =
9685 "__gnat_debug_raise_exception", /* catch_exception_sym */
9686 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9687 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9688 ada_unhandled_exception_name_addr
9691 /* The following exception support info structure describes how to
9692 implement exception catchpoints with a slightly older version
9693 of the Ada runtime. */
9695 static const struct exception_support_info exception_support_info_fallback =
9697 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9698 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9699 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9700 ada_unhandled_exception_name_addr_from_raise
9703 /* For each executable, we sniff which exception info structure to use
9704 and cache it in the following global variable. */
9706 static const struct exception_support_info *exception_info = NULL;
9708 /* Inspect the Ada runtime and determine which exception info structure
9709 should be used to provide support for exception catchpoints.
9711 This function will always set exception_info, or raise an error. */
9714 ada_exception_support_info_sniffer (void)
9718 /* If the exception info is already known, then no need to recompute it. */
9719 if (exception_info != NULL)
9722 /* Check the latest (default) exception support info. */
9723 sym = standard_lookup (default_exception_support_info.catch_exception_sym,
9727 exception_info = &default_exception_support_info;
9731 /* Try our fallback exception suport info. */
9732 sym = standard_lookup (exception_support_info_fallback.catch_exception_sym,
9736 exception_info = &exception_support_info_fallback;
9740 /* Sometimes, it is normal for us to not be able to find the routine
9741 we are looking for. This happens when the program is linked with
9742 the shared version of the GNAT runtime, and the program has not been
9743 started yet. Inform the user of these two possible causes if
9746 if (ada_update_initial_language (language_unknown, NULL) != language_ada)
9747 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9749 /* If the symbol does not exist, then check that the program is
9750 already started, to make sure that shared libraries have been
9751 loaded. If it is not started, this may mean that the symbol is
9752 in a shared library. */
9754 if (ptid_get_pid (inferior_ptid) == 0)
9755 error (_("Unable to insert catchpoint. Try to start the program first."));
9757 /* At this point, we know that we are debugging an Ada program and
9758 that the inferior has been started, but we still are not able to
9759 find the run-time symbols. That can mean that we are in
9760 configurable run time mode, or that a-except as been optimized
9761 out by the linker... In any case, at this point it is not worth
9762 supporting this feature. */
9764 error (_("Cannot insert catchpoints in this configuration."));
9767 /* An observer of "executable_changed" events.
9768 Its role is to clear certain cached values that need to be recomputed
9769 each time a new executable is loaded by GDB. */
9772 ada_executable_changed_observer (void)
9774 /* If the executable changed, then it is possible that the Ada runtime
9775 is different. So we need to invalidate the exception support info
9777 exception_info = NULL;
9780 /* Return the name of the function at PC, NULL if could not find it.
9781 This function only checks the debugging information, not the symbol
9785 function_name_from_pc (CORE_ADDR pc)
9789 if (!find_pc_partial_function (pc, &func_name, NULL, NULL))
9795 /* True iff FRAME is very likely to be that of a function that is
9796 part of the runtime system. This is all very heuristic, but is
9797 intended to be used as advice as to what frames are uninteresting
9801 is_known_support_routine (struct frame_info *frame)
9803 struct symtab_and_line sal;
9807 /* If this code does not have any debugging information (no symtab),
9808 This cannot be any user code. */
9810 find_frame_sal (frame, &sal);
9811 if (sal.symtab == NULL)
9814 /* If there is a symtab, but the associated source file cannot be
9815 located, then assume this is not user code: Selecting a frame
9816 for which we cannot display the code would not be very helpful
9817 for the user. This should also take care of case such as VxWorks
9818 where the kernel has some debugging info provided for a few units. */
9820 if (symtab_to_fullname (sal.symtab) == NULL)
9823 /* Check the unit filename againt the Ada runtime file naming.
9824 We also check the name of the objfile against the name of some
9825 known system libraries that sometimes come with debugging info
9828 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
9830 re_comp (known_runtime_file_name_patterns[i]);
9831 if (re_exec (sal.symtab->filename))
9833 if (sal.symtab->objfile != NULL
9834 && re_exec (sal.symtab->objfile->name))
9838 /* Check whether the function is a GNAT-generated entity. */
9840 func_name = function_name_from_pc (get_frame_address_in_block (frame));
9841 if (func_name == NULL)
9844 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
9846 re_comp (known_auxiliary_function_name_patterns[i]);
9847 if (re_exec (func_name))
9854 /* Find the first frame that contains debugging information and that is not
9855 part of the Ada run-time, starting from FI and moving upward. */
9858 ada_find_printable_frame (struct frame_info *fi)
9860 for (; fi != NULL; fi = get_prev_frame (fi))
9862 if (!is_known_support_routine (fi))
9871 /* Assuming that the inferior just triggered an unhandled exception
9872 catchpoint, return the address in inferior memory where the name
9873 of the exception is stored.
9875 Return zero if the address could not be computed. */
9878 ada_unhandled_exception_name_addr (void)
9880 return parse_and_eval_address ("e.full_name");
9883 /* Same as ada_unhandled_exception_name_addr, except that this function
9884 should be used when the inferior uses an older version of the runtime,
9885 where the exception name needs to be extracted from a specific frame
9886 several frames up in the callstack. */
9889 ada_unhandled_exception_name_addr_from_raise (void)
9892 struct frame_info *fi;
9894 /* To determine the name of this exception, we need to select
9895 the frame corresponding to RAISE_SYM_NAME. This frame is
9896 at least 3 levels up, so we simply skip the first 3 frames
9897 without checking the name of their associated function. */
9898 fi = get_current_frame ();
9899 for (frame_level = 0; frame_level < 3; frame_level += 1)
9901 fi = get_prev_frame (fi);
9905 const char *func_name =
9906 function_name_from_pc (get_frame_address_in_block (fi));
9907 if (func_name != NULL
9908 && strcmp (func_name, exception_info->catch_exception_sym) == 0)
9909 break; /* We found the frame we were looking for... */
9910 fi = get_prev_frame (fi);
9917 return parse_and_eval_address ("id.full_name");
9920 /* Assuming the inferior just triggered an Ada exception catchpoint
9921 (of any type), return the address in inferior memory where the name
9922 of the exception is stored, if applicable.
9924 Return zero if the address could not be computed, or if not relevant. */
9927 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex,
9928 struct breakpoint *b)
9932 case ex_catch_exception:
9933 return (parse_and_eval_address ("e.full_name"));
9936 case ex_catch_exception_unhandled:
9937 return exception_info->unhandled_exception_name_addr ();
9940 case ex_catch_assert:
9941 return 0; /* Exception name is not relevant in this case. */
9945 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
9949 return 0; /* Should never be reached. */
9952 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
9953 any error that ada_exception_name_addr_1 might cause to be thrown.
9954 When an error is intercepted, a warning with the error message is printed,
9955 and zero is returned. */
9958 ada_exception_name_addr (enum exception_catchpoint_kind ex,
9959 struct breakpoint *b)
9961 struct gdb_exception e;
9962 CORE_ADDR result = 0;
9964 TRY_CATCH (e, RETURN_MASK_ERROR)
9966 result = ada_exception_name_addr_1 (ex, b);
9971 warning (_("failed to get exception name: %s"), e.message);
9978 /* Implement the PRINT_IT method in the breakpoint_ops structure
9979 for all exception catchpoint kinds. */
9981 static enum print_stop_action
9982 print_it_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
9984 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
9985 char exception_name[256];
9989 read_memory (addr, exception_name, sizeof (exception_name) - 1);
9990 exception_name [sizeof (exception_name) - 1] = '\0';
9993 ada_find_printable_frame (get_current_frame ());
9995 annotate_catchpoint (b->number);
9998 case ex_catch_exception:
10000 printf_filtered (_("\nCatchpoint %d, %s at "),
10001 b->number, exception_name);
10003 printf_filtered (_("\nCatchpoint %d, exception at "), b->number);
10005 case ex_catch_exception_unhandled:
10007 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10008 b->number, exception_name);
10010 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10013 case ex_catch_assert:
10014 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10019 return PRINT_SRC_AND_LOC;
10022 /* Implement the PRINT_ONE method in the breakpoint_ops structure
10023 for all exception catchpoint kinds. */
10026 print_one_exception (enum exception_catchpoint_kind ex,
10027 struct breakpoint *b, CORE_ADDR *last_addr)
10031 annotate_field (4);
10032 ui_out_field_core_addr (uiout, "addr", b->loc->address);
10035 annotate_field (5);
10036 *last_addr = b->loc->address;
10039 case ex_catch_exception:
10040 if (b->exp_string != NULL)
10042 char *msg = xstrprintf (_("`%s' Ada exception"), b->exp_string);
10044 ui_out_field_string (uiout, "what", msg);
10048 ui_out_field_string (uiout, "what", "all Ada exceptions");
10052 case ex_catch_exception_unhandled:
10053 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
10056 case ex_catch_assert:
10057 ui_out_field_string (uiout, "what", "failed Ada assertions");
10061 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10066 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
10067 for all exception catchpoint kinds. */
10070 print_mention_exception (enum exception_catchpoint_kind ex,
10071 struct breakpoint *b)
10075 case ex_catch_exception:
10076 if (b->exp_string != NULL)
10077 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10078 b->number, b->exp_string);
10080 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b->number);
10084 case ex_catch_exception_unhandled:
10085 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10089 case ex_catch_assert:
10090 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b->number);
10094 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10099 /* Virtual table for "catch exception" breakpoints. */
10101 static enum print_stop_action
10102 print_it_catch_exception (struct breakpoint *b)
10104 return print_it_exception (ex_catch_exception, b);
10108 print_one_catch_exception (struct breakpoint *b, CORE_ADDR *last_addr)
10110 print_one_exception (ex_catch_exception, b, last_addr);
10114 print_mention_catch_exception (struct breakpoint *b)
10116 print_mention_exception (ex_catch_exception, b);
10119 static struct breakpoint_ops catch_exception_breakpoint_ops =
10121 print_it_catch_exception,
10122 print_one_catch_exception,
10123 print_mention_catch_exception
10126 /* Virtual table for "catch exception unhandled" breakpoints. */
10128 static enum print_stop_action
10129 print_it_catch_exception_unhandled (struct breakpoint *b)
10131 return print_it_exception (ex_catch_exception_unhandled, b);
10135 print_one_catch_exception_unhandled (struct breakpoint *b, CORE_ADDR *last_addr)
10137 print_one_exception (ex_catch_exception_unhandled, b, last_addr);
10141 print_mention_catch_exception_unhandled (struct breakpoint *b)
10143 print_mention_exception (ex_catch_exception_unhandled, b);
10146 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops = {
10147 print_it_catch_exception_unhandled,
10148 print_one_catch_exception_unhandled,
10149 print_mention_catch_exception_unhandled
10152 /* Virtual table for "catch assert" breakpoints. */
10154 static enum print_stop_action
10155 print_it_catch_assert (struct breakpoint *b)
10157 return print_it_exception (ex_catch_assert, b);
10161 print_one_catch_assert (struct breakpoint *b, CORE_ADDR *last_addr)
10163 print_one_exception (ex_catch_assert, b, last_addr);
10167 print_mention_catch_assert (struct breakpoint *b)
10169 print_mention_exception (ex_catch_assert, b);
10172 static struct breakpoint_ops catch_assert_breakpoint_ops = {
10173 print_it_catch_assert,
10174 print_one_catch_assert,
10175 print_mention_catch_assert
10178 /* Return non-zero if B is an Ada exception catchpoint. */
10181 ada_exception_catchpoint_p (struct breakpoint *b)
10183 return (b->ops == &catch_exception_breakpoint_ops
10184 || b->ops == &catch_exception_unhandled_breakpoint_ops
10185 || b->ops == &catch_assert_breakpoint_ops);
10188 /* Return a newly allocated copy of the first space-separated token
10189 in ARGSP, and then adjust ARGSP to point immediately after that
10192 Return NULL if ARGPS does not contain any more tokens. */
10195 ada_get_next_arg (char **argsp)
10197 char *args = *argsp;
10201 /* Skip any leading white space. */
10203 while (isspace (*args))
10206 if (args[0] == '\0')
10207 return NULL; /* No more arguments. */
10209 /* Find the end of the current argument. */
10212 while (*end != '\0' && !isspace (*end))
10215 /* Adjust ARGSP to point to the start of the next argument. */
10219 /* Make a copy of the current argument and return it. */
10221 result = xmalloc (end - args + 1);
10222 strncpy (result, args, end - args);
10223 result[end - args] = '\0';
10228 /* Split the arguments specified in a "catch exception" command.
10229 Set EX to the appropriate catchpoint type.
10230 Set EXP_STRING to the name of the specific exception if
10231 specified by the user. */
10234 catch_ada_exception_command_split (char *args,
10235 enum exception_catchpoint_kind *ex,
10238 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
10239 char *exception_name;
10241 exception_name = ada_get_next_arg (&args);
10242 make_cleanup (xfree, exception_name);
10244 /* Check that we do not have any more arguments. Anything else
10247 while (isspace (*args))
10250 if (args[0] != '\0')
10251 error (_("Junk at end of expression"));
10253 discard_cleanups (old_chain);
10255 if (exception_name == NULL)
10257 /* Catch all exceptions. */
10258 *ex = ex_catch_exception;
10259 *exp_string = NULL;
10261 else if (strcmp (exception_name, "unhandled") == 0)
10263 /* Catch unhandled exceptions. */
10264 *ex = ex_catch_exception_unhandled;
10265 *exp_string = NULL;
10269 /* Catch a specific exception. */
10270 *ex = ex_catch_exception;
10271 *exp_string = exception_name;
10275 /* Return the name of the symbol on which we should break in order to
10276 implement a catchpoint of the EX kind. */
10278 static const char *
10279 ada_exception_sym_name (enum exception_catchpoint_kind ex)
10281 gdb_assert (exception_info != NULL);
10285 case ex_catch_exception:
10286 return (exception_info->catch_exception_sym);
10288 case ex_catch_exception_unhandled:
10289 return (exception_info->catch_exception_unhandled_sym);
10291 case ex_catch_assert:
10292 return (exception_info->catch_assert_sym);
10295 internal_error (__FILE__, __LINE__,
10296 _("unexpected catchpoint kind (%d)"), ex);
10300 /* Return the breakpoint ops "virtual table" used for catchpoints
10303 static struct breakpoint_ops *
10304 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex)
10308 case ex_catch_exception:
10309 return (&catch_exception_breakpoint_ops);
10311 case ex_catch_exception_unhandled:
10312 return (&catch_exception_unhandled_breakpoint_ops);
10314 case ex_catch_assert:
10315 return (&catch_assert_breakpoint_ops);
10318 internal_error (__FILE__, __LINE__,
10319 _("unexpected catchpoint kind (%d)"), ex);
10323 /* Return the condition that will be used to match the current exception
10324 being raised with the exception that the user wants to catch. This
10325 assumes that this condition is used when the inferior just triggered
10326 an exception catchpoint.
10328 The string returned is a newly allocated string that needs to be
10329 deallocated later. */
10332 ada_exception_catchpoint_cond_string (const char *exp_string)
10334 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string);
10337 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
10339 static struct expression *
10340 ada_parse_catchpoint_condition (char *cond_string,
10341 struct symtab_and_line sal)
10343 return (parse_exp_1 (&cond_string, block_for_pc (sal.pc), 0));
10346 /* Return the symtab_and_line that should be used to insert an exception
10347 catchpoint of the TYPE kind.
10349 EX_STRING should contain the name of a specific exception
10350 that the catchpoint should catch, or NULL otherwise.
10352 The idea behind all the remaining parameters is that their names match
10353 the name of certain fields in the breakpoint structure that are used to
10354 handle exception catchpoints. This function returns the value to which
10355 these fields should be set, depending on the type of catchpoint we need
10358 If COND and COND_STRING are both non-NULL, any value they might
10359 hold will be free'ed, and then replaced by newly allocated ones.
10360 These parameters are left untouched otherwise. */
10362 static struct symtab_and_line
10363 ada_exception_sal (enum exception_catchpoint_kind ex, char *exp_string,
10364 char **addr_string, char **cond_string,
10365 struct expression **cond, struct breakpoint_ops **ops)
10367 const char *sym_name;
10368 struct symbol *sym;
10369 struct symtab_and_line sal;
10371 /* First, find out which exception support info to use. */
10372 ada_exception_support_info_sniffer ();
10374 /* Then lookup the function on which we will break in order to catch
10375 the Ada exceptions requested by the user. */
10377 sym_name = ada_exception_sym_name (ex);
10378 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
10380 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10381 that should be compiled with debugging information. As a result, we
10382 expect to find that symbol in the symtabs. If we don't find it, then
10383 the target most likely does not support Ada exceptions, or we cannot
10384 insert exception breakpoints yet, because the GNAT runtime hasn't been
10387 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10388 in such a way that no debugging information is produced for the symbol
10389 we are looking for. In this case, we could search the minimal symbols
10390 as a fall-back mechanism. This would still be operating in degraded
10391 mode, however, as we would still be missing the debugging information
10392 that is needed in order to extract the name of the exception being
10393 raised (this name is printed in the catchpoint message, and is also
10394 used when trying to catch a specific exception). We do not handle
10395 this case for now. */
10398 error (_("Unable to break on '%s' in this configuration."), sym_name);
10400 /* Make sure that the symbol we found corresponds to a function. */
10401 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
10402 error (_("Symbol \"%s\" is not a function (class = %d)"),
10403 sym_name, SYMBOL_CLASS (sym));
10405 sal = find_function_start_sal (sym, 1);
10407 /* Set ADDR_STRING. */
10409 *addr_string = xstrdup (sym_name);
10411 /* Set the COND and COND_STRING (if not NULL). */
10413 if (cond_string != NULL && cond != NULL)
10415 if (*cond_string != NULL)
10417 xfree (*cond_string);
10418 *cond_string = NULL;
10425 if (exp_string != NULL)
10427 *cond_string = ada_exception_catchpoint_cond_string (exp_string);
10428 *cond = ada_parse_catchpoint_condition (*cond_string, sal);
10433 *ops = ada_exception_breakpoint_ops (ex);
10438 /* Parse the arguments (ARGS) of the "catch exception" command.
10440 Set TYPE to the appropriate exception catchpoint type.
10441 If the user asked the catchpoint to catch only a specific
10442 exception, then save the exception name in ADDR_STRING.
10444 See ada_exception_sal for a description of all the remaining
10445 function arguments of this function. */
10447 struct symtab_and_line
10448 ada_decode_exception_location (char *args, char **addr_string,
10449 char **exp_string, char **cond_string,
10450 struct expression **cond,
10451 struct breakpoint_ops **ops)
10453 enum exception_catchpoint_kind ex;
10455 catch_ada_exception_command_split (args, &ex, exp_string);
10456 return ada_exception_sal (ex, *exp_string, addr_string, cond_string,
10460 struct symtab_and_line
10461 ada_decode_assert_location (char *args, char **addr_string,
10462 struct breakpoint_ops **ops)
10464 /* Check that no argument where provided at the end of the command. */
10468 while (isspace (*args))
10471 error (_("Junk at end of arguments."));
10474 return ada_exception_sal (ex_catch_assert, NULL, addr_string, NULL, NULL,
10479 /* Information about operators given special treatment in functions
10481 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10483 #define ADA_OPERATORS \
10484 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10485 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10486 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10487 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10488 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10489 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10490 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10491 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10492 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10493 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10494 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10495 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10496 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10497 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10498 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
10499 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10500 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10501 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10502 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
10505 ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp)
10507 switch (exp->elts[pc - 1].opcode)
10510 operator_length_standard (exp, pc, oplenp, argsp);
10513 #define OP_DEFN(op, len, args, binop) \
10514 case op: *oplenp = len; *argsp = args; break;
10520 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
10525 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
10531 ada_op_name (enum exp_opcode opcode)
10536 return op_name_standard (opcode);
10538 #define OP_DEFN(op, len, args, binop) case op: return #op;
10543 return "OP_AGGREGATE";
10545 return "OP_CHOICES";
10551 /* As for operator_length, but assumes PC is pointing at the first
10552 element of the operator, and gives meaningful results only for the
10553 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
10556 ada_forward_operator_length (struct expression *exp, int pc,
10557 int *oplenp, int *argsp)
10559 switch (exp->elts[pc].opcode)
10562 *oplenp = *argsp = 0;
10565 #define OP_DEFN(op, len, args, binop) \
10566 case op: *oplenp = len; *argsp = args; break;
10572 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
10577 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
10583 int len = longest_to_int (exp->elts[pc + 1].longconst);
10584 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
10592 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
10594 enum exp_opcode op = exp->elts[elt].opcode;
10599 ada_forward_operator_length (exp, elt, &oplen, &nargs);
10603 /* Ada attributes ('Foo). */
10606 case OP_ATR_LENGTH:
10610 case OP_ATR_MODULUS:
10617 case UNOP_IN_RANGE:
10619 /* XXX: gdb_sprint_host_address, type_sprint */
10620 fprintf_filtered (stream, _("Type @"));
10621 gdb_print_host_address (exp->elts[pc + 1].type, stream);
10622 fprintf_filtered (stream, " (");
10623 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
10624 fprintf_filtered (stream, ")");
10626 case BINOP_IN_BOUNDS:
10627 fprintf_filtered (stream, " (%d)",
10628 longest_to_int (exp->elts[pc + 2].longconst));
10630 case TERNOP_IN_RANGE:
10635 case OP_DISCRETE_RANGE:
10636 case OP_POSITIONAL:
10643 char *name = &exp->elts[elt + 2].string;
10644 int len = longest_to_int (exp->elts[elt + 1].longconst);
10645 fprintf_filtered (stream, "Text: `%.*s'", len, name);
10650 return dump_subexp_body_standard (exp, stream, elt);
10654 for (i = 0; i < nargs; i += 1)
10655 elt = dump_subexp (exp, stream, elt);
10660 /* The Ada extension of print_subexp (q.v.). */
10663 ada_print_subexp (struct expression *exp, int *pos,
10664 struct ui_file *stream, enum precedence prec)
10666 int oplen, nargs, i;
10668 enum exp_opcode op = exp->elts[pc].opcode;
10670 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10677 print_subexp_standard (exp, pos, stream, prec);
10681 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
10684 case BINOP_IN_BOUNDS:
10685 /* XXX: sprint_subexp */
10686 print_subexp (exp, pos, stream, PREC_SUFFIX);
10687 fputs_filtered (" in ", stream);
10688 print_subexp (exp, pos, stream, PREC_SUFFIX);
10689 fputs_filtered ("'range", stream);
10690 if (exp->elts[pc + 1].longconst > 1)
10691 fprintf_filtered (stream, "(%ld)",
10692 (long) exp->elts[pc + 1].longconst);
10695 case TERNOP_IN_RANGE:
10696 if (prec >= PREC_EQUAL)
10697 fputs_filtered ("(", stream);
10698 /* XXX: sprint_subexp */
10699 print_subexp (exp, pos, stream, PREC_SUFFIX);
10700 fputs_filtered (" in ", stream);
10701 print_subexp (exp, pos, stream, PREC_EQUAL);
10702 fputs_filtered (" .. ", stream);
10703 print_subexp (exp, pos, stream, PREC_EQUAL);
10704 if (prec >= PREC_EQUAL)
10705 fputs_filtered (")", stream);
10710 case OP_ATR_LENGTH:
10714 case OP_ATR_MODULUS:
10719 if (exp->elts[*pos].opcode == OP_TYPE)
10721 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
10722 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
10726 print_subexp (exp, pos, stream, PREC_SUFFIX);
10727 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
10731 for (tem = 1; tem < nargs; tem += 1)
10733 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
10734 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
10736 fputs_filtered (")", stream);
10741 type_print (exp->elts[pc + 1].type, "", stream, 0);
10742 fputs_filtered ("'(", stream);
10743 print_subexp (exp, pos, stream, PREC_PREFIX);
10744 fputs_filtered (")", stream);
10747 case UNOP_IN_RANGE:
10748 /* XXX: sprint_subexp */
10749 print_subexp (exp, pos, stream, PREC_SUFFIX);
10750 fputs_filtered (" in ", stream);
10751 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
10754 case OP_DISCRETE_RANGE:
10755 print_subexp (exp, pos, stream, PREC_SUFFIX);
10756 fputs_filtered ("..", stream);
10757 print_subexp (exp, pos, stream, PREC_SUFFIX);
10761 fputs_filtered ("others => ", stream);
10762 print_subexp (exp, pos, stream, PREC_SUFFIX);
10766 for (i = 0; i < nargs-1; i += 1)
10769 fputs_filtered ("|", stream);
10770 print_subexp (exp, pos, stream, PREC_SUFFIX);
10772 fputs_filtered (" => ", stream);
10773 print_subexp (exp, pos, stream, PREC_SUFFIX);
10776 case OP_POSITIONAL:
10777 print_subexp (exp, pos, stream, PREC_SUFFIX);
10781 fputs_filtered ("(", stream);
10782 for (i = 0; i < nargs; i += 1)
10785 fputs_filtered (", ", stream);
10786 print_subexp (exp, pos, stream, PREC_SUFFIX);
10788 fputs_filtered (")", stream);
10793 /* Table mapping opcodes into strings for printing operators
10794 and precedences of the operators. */
10796 static const struct op_print ada_op_print_tab[] = {
10797 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
10798 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
10799 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
10800 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
10801 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
10802 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
10803 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
10804 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
10805 {"<=", BINOP_LEQ, PREC_ORDER, 0},
10806 {">=", BINOP_GEQ, PREC_ORDER, 0},
10807 {">", BINOP_GTR, PREC_ORDER, 0},
10808 {"<", BINOP_LESS, PREC_ORDER, 0},
10809 {">>", BINOP_RSH, PREC_SHIFT, 0},
10810 {"<<", BINOP_LSH, PREC_SHIFT, 0},
10811 {"+", BINOP_ADD, PREC_ADD, 0},
10812 {"-", BINOP_SUB, PREC_ADD, 0},
10813 {"&", BINOP_CONCAT, PREC_ADD, 0},
10814 {"*", BINOP_MUL, PREC_MUL, 0},
10815 {"/", BINOP_DIV, PREC_MUL, 0},
10816 {"rem", BINOP_REM, PREC_MUL, 0},
10817 {"mod", BINOP_MOD, PREC_MUL, 0},
10818 {"**", BINOP_EXP, PREC_REPEAT, 0},
10819 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
10820 {"-", UNOP_NEG, PREC_PREFIX, 0},
10821 {"+", UNOP_PLUS, PREC_PREFIX, 0},
10822 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
10823 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
10824 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
10825 {".all", UNOP_IND, PREC_SUFFIX, 1},
10826 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
10827 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
10831 enum ada_primitive_types {
10832 ada_primitive_type_int,
10833 ada_primitive_type_long,
10834 ada_primitive_type_short,
10835 ada_primitive_type_char,
10836 ada_primitive_type_float,
10837 ada_primitive_type_double,
10838 ada_primitive_type_void,
10839 ada_primitive_type_long_long,
10840 ada_primitive_type_long_double,
10841 ada_primitive_type_natural,
10842 ada_primitive_type_positive,
10843 ada_primitive_type_system_address,
10844 nr_ada_primitive_types
10848 ada_language_arch_info (struct gdbarch *gdbarch,
10849 struct language_arch_info *lai)
10851 const struct builtin_type *builtin = builtin_type (gdbarch);
10852 lai->primitive_type_vector
10853 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
10855 lai->primitive_type_vector [ada_primitive_type_int] =
10856 init_type (TYPE_CODE_INT,
10857 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
10858 0, "integer", (struct objfile *) NULL);
10859 lai->primitive_type_vector [ada_primitive_type_long] =
10860 init_type (TYPE_CODE_INT,
10861 gdbarch_long_bit (gdbarch) / TARGET_CHAR_BIT,
10862 0, "long_integer", (struct objfile *) NULL);
10863 lai->primitive_type_vector [ada_primitive_type_short] =
10864 init_type (TYPE_CODE_INT,
10865 gdbarch_short_bit (gdbarch) / TARGET_CHAR_BIT,
10866 0, "short_integer", (struct objfile *) NULL);
10867 lai->string_char_type =
10868 lai->primitive_type_vector [ada_primitive_type_char] =
10869 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
10870 0, "character", (struct objfile *) NULL);
10871 lai->primitive_type_vector [ada_primitive_type_float] =
10872 init_type (TYPE_CODE_FLT,
10873 gdbarch_float_bit (gdbarch)/ TARGET_CHAR_BIT,
10874 0, "float", (struct objfile *) NULL);
10875 lai->primitive_type_vector [ada_primitive_type_double] =
10876 init_type (TYPE_CODE_FLT,
10877 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
10878 0, "long_float", (struct objfile *) NULL);
10879 lai->primitive_type_vector [ada_primitive_type_long_long] =
10880 init_type (TYPE_CODE_INT,
10881 gdbarch_long_long_bit (gdbarch) / TARGET_CHAR_BIT,
10882 0, "long_long_integer", (struct objfile *) NULL);
10883 lai->primitive_type_vector [ada_primitive_type_long_double] =
10884 init_type (TYPE_CODE_FLT,
10885 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
10886 0, "long_long_float", (struct objfile *) NULL);
10887 lai->primitive_type_vector [ada_primitive_type_natural] =
10888 init_type (TYPE_CODE_INT,
10889 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
10890 0, "natural", (struct objfile *) NULL);
10891 lai->primitive_type_vector [ada_primitive_type_positive] =
10892 init_type (TYPE_CODE_INT,
10893 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
10894 0, "positive", (struct objfile *) NULL);
10895 lai->primitive_type_vector [ada_primitive_type_void] = builtin->builtin_void;
10897 lai->primitive_type_vector [ada_primitive_type_system_address] =
10898 lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
10899 (struct objfile *) NULL));
10900 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
10901 = "system__address";
10904 /* Language vector */
10906 /* Not really used, but needed in the ada_language_defn. */
10909 emit_char (int c, struct ui_file *stream, int quoter)
10911 ada_emit_char (c, stream, quoter, 1);
10917 warnings_issued = 0;
10918 return ada_parse ();
10921 static const struct exp_descriptor ada_exp_descriptor = {
10923 ada_operator_length,
10925 ada_dump_subexp_body,
10926 ada_evaluate_subexp
10929 const struct language_defn ada_language_defn = {
10930 "ada", /* Language name */
10934 case_sensitive_on, /* Yes, Ada is case-insensitive, but
10935 that's not quite what this means. */
10937 &ada_exp_descriptor,
10941 ada_printchar, /* Print a character constant */
10942 ada_printstr, /* Function to print string constant */
10943 emit_char, /* Function to print single char (not used) */
10944 ada_print_type, /* Print a type using appropriate syntax */
10945 ada_val_print, /* Print a value using appropriate syntax */
10946 ada_value_print, /* Print a top-level value */
10947 NULL, /* Language specific skip_trampoline */
10948 NULL, /* name_of_this */
10949 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
10950 basic_lookup_transparent_type, /* lookup_transparent_type */
10951 ada_la_decode, /* Language specific symbol demangler */
10952 NULL, /* Language specific class_name_from_physname */
10953 ada_op_print_tab, /* expression operators for printing */
10954 0, /* c-style arrays */
10955 1, /* String lower bound */
10956 ada_get_gdb_completer_word_break_characters,
10957 ada_make_symbol_completion_list,
10958 ada_language_arch_info,
10959 ada_print_array_index,
10960 default_pass_by_reference,
10965 _initialize_ada_language (void)
10967 add_language (&ada_language_defn);
10969 varsize_limit = 65536;
10971 obstack_init (&symbol_list_obstack);
10973 decoded_names_store = htab_create_alloc
10974 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
10975 NULL, xcalloc, xfree);
10977 observer_attach_executable_changed (ada_executable_changed_observer);