1 /* Ada language support routines for GDB, the GNU debugger. Copyright (C)
3 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005, 2007, 2008,
4 2009 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 /* Define whether or not the C operator '/' truncates towards zero for
61 differently signed operands (truncation direction is undefined in C).
62 Copied from valarith.c. */
64 #ifndef TRUNCATION_TOWARDS_ZERO
65 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
68 static void extract_string (CORE_ADDR addr, char *buf);
70 static void modify_general_field (char *, LONGEST, int, int);
72 static struct type *desc_base_type (struct type *);
74 static struct type *desc_bounds_type (struct type *);
76 static struct value *desc_bounds (struct value *);
78 static int fat_pntr_bounds_bitpos (struct type *);
80 static int fat_pntr_bounds_bitsize (struct type *);
82 static struct type *desc_data_type (struct type *);
84 static struct value *desc_data (struct value *);
86 static int fat_pntr_data_bitpos (struct type *);
88 static int fat_pntr_data_bitsize (struct type *);
90 static struct value *desc_one_bound (struct value *, int, int);
92 static int desc_bound_bitpos (struct type *, int, int);
94 static int desc_bound_bitsize (struct type *, int, int);
96 static struct type *desc_index_type (struct type *, int);
98 static int desc_arity (struct type *);
100 static int ada_type_match (struct type *, struct type *, int);
102 static int ada_args_match (struct symbol *, struct value **, int);
104 static struct value *ensure_lval (struct value *, CORE_ADDR *);
106 static struct value *convert_actual (struct value *, struct type *,
109 static struct value *make_array_descriptor (struct type *, struct value *,
112 static void ada_add_block_symbols (struct obstack *,
113 struct block *, const char *,
114 domain_enum, struct objfile *, int);
116 static int is_nonfunction (struct ada_symbol_info *, int);
118 static void add_defn_to_vec (struct obstack *, struct symbol *,
121 static int num_defns_collected (struct obstack *);
123 static struct ada_symbol_info *defns_collected (struct obstack *, int);
125 static struct partial_symbol *ada_lookup_partial_symbol (struct partial_symtab
126 *, const char *, int,
129 static struct symtab *symtab_for_sym (struct symbol *);
131 static struct value *resolve_subexp (struct expression **, int *, int,
134 static void replace_operator_with_call (struct expression **, int, int, int,
135 struct symbol *, struct block *);
137 static int possible_user_operator_p (enum exp_opcode, struct value **);
139 static char *ada_op_name (enum exp_opcode);
141 static const char *ada_decoded_op_name (enum exp_opcode);
143 static int numeric_type_p (struct type *);
145 static int integer_type_p (struct type *);
147 static int scalar_type_p (struct type *);
149 static int discrete_type_p (struct type *);
151 static enum ada_renaming_category parse_old_style_renaming (struct type *,
156 static struct symbol *find_old_style_renaming_symbol (const char *,
159 static struct type *ada_lookup_struct_elt_type (struct type *, char *,
162 static struct value *evaluate_subexp (struct type *, struct expression *,
165 static struct value *evaluate_subexp_type (struct expression *, int *);
167 static int is_dynamic_field (struct type *, int);
169 static struct type *to_fixed_variant_branch_type (struct type *,
171 CORE_ADDR, struct value *);
173 static struct type *to_fixed_array_type (struct type *, struct value *, int);
175 static struct type *to_fixed_range_type (char *, struct value *,
178 static struct type *to_static_fixed_type (struct type *);
179 static struct type *static_unwrap_type (struct type *type);
181 static struct value *unwrap_value (struct value *);
183 static struct type *packed_array_type (struct type *, long *);
185 static struct type *decode_packed_array_type (struct type *);
187 static struct value *decode_packed_array (struct value *);
189 static struct value *value_subscript_packed (struct value *, int,
192 static void move_bits (gdb_byte *, int, const gdb_byte *, int, int);
194 static struct value *coerce_unspec_val_to_type (struct value *,
197 static struct value *get_var_value (char *, char *);
199 static int lesseq_defined_than (struct symbol *, struct symbol *);
201 static int equiv_types (struct type *, struct type *);
203 static int is_name_suffix (const char *);
205 static int wild_match (const char *, int, const char *);
207 static struct value *ada_coerce_ref (struct value *);
209 static LONGEST pos_atr (struct value *);
211 static struct value *value_pos_atr (struct type *, struct value *);
213 static struct value *value_val_atr (struct type *, struct value *);
215 static struct symbol *standard_lookup (const char *, const struct block *,
218 static struct value *ada_search_struct_field (char *, struct value *, int,
221 static struct value *ada_value_primitive_field (struct value *, int, int,
224 static int find_struct_field (char *, struct type *, int,
225 struct type **, int *, int *, int *, int *);
227 static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
230 static struct value *ada_to_fixed_value (struct value *);
232 static int ada_resolve_function (struct ada_symbol_info *, int,
233 struct value **, int, const char *,
236 static struct value *ada_coerce_to_simple_array (struct value *);
238 static int ada_is_direct_array_type (struct type *);
240 static void ada_language_arch_info (struct gdbarch *,
241 struct language_arch_info *);
243 static void check_size (const struct type *);
245 static struct value *ada_index_struct_field (int, struct value *, int,
248 static struct value *assign_aggregate (struct value *, struct value *,
249 struct expression *, int *, enum noside);
251 static void aggregate_assign_from_choices (struct value *, struct value *,
253 int *, LONGEST *, int *,
254 int, LONGEST, LONGEST);
256 static void aggregate_assign_positional (struct value *, struct value *,
258 int *, LONGEST *, int *, int,
262 static void aggregate_assign_others (struct value *, struct value *,
264 int *, LONGEST *, int, LONGEST, LONGEST);
267 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
270 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
273 static void ada_forward_operator_length (struct expression *, int, int *,
278 /* Maximum-sized dynamic type. */
279 static unsigned int varsize_limit;
281 /* FIXME: brobecker/2003-09-17: No longer a const because it is
282 returned by a function that does not return a const char *. */
283 static char *ada_completer_word_break_characters =
285 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
287 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
290 /* The name of the symbol to use to get the name of the main subprogram. */
291 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
292 = "__gnat_ada_main_program_name";
294 /* Limit on the number of warnings to raise per expression evaluation. */
295 static int warning_limit = 2;
297 /* Number of warning messages issued; reset to 0 by cleanups after
298 expression evaluation. */
299 static int warnings_issued = 0;
301 static const char *known_runtime_file_name_patterns[] = {
302 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
305 static const char *known_auxiliary_function_name_patterns[] = {
306 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
309 /* Space for allocating results of ada_lookup_symbol_list. */
310 static struct obstack symbol_list_obstack;
314 /* Given DECODED_NAME a string holding a symbol name in its
315 decoded form (ie using the Ada dotted notation), returns
316 its unqualified name. */
319 ada_unqualified_name (const char *decoded_name)
321 const char *result = strrchr (decoded_name, '.');
324 result++; /* Skip the dot... */
326 result = decoded_name;
331 /* Return a string starting with '<', followed by STR, and '>'.
332 The result is good until the next call. */
335 add_angle_brackets (const char *str)
337 static char *result = NULL;
340 result = (char *) xmalloc ((strlen (str) + 3) * sizeof (char));
342 sprintf (result, "<%s>", str);
347 ada_get_gdb_completer_word_break_characters (void)
349 return ada_completer_word_break_characters;
352 /* Print an array element index using the Ada syntax. */
355 ada_print_array_index (struct value *index_value, struct ui_file *stream,
356 const struct value_print_options *options)
358 LA_VALUE_PRINT (index_value, stream, options);
359 fprintf_filtered (stream, " => ");
362 /* Read the string located at ADDR from the inferior and store the
366 extract_string (CORE_ADDR addr, char *buf)
370 /* Loop, reading one byte at a time, until we reach the '\000'
371 end-of-string marker. */
374 target_read_memory (addr + char_index * sizeof (char),
375 buf + char_index * sizeof (char), sizeof (char));
378 while (buf[char_index - 1] != '\000');
381 /* Assuming VECT points to an array of *SIZE objects of size
382 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
383 updating *SIZE as necessary and returning the (new) array. */
386 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
388 if (*size < min_size)
391 if (*size < min_size)
393 vect = xrealloc (vect, *size * element_size);
398 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
399 suffix of FIELD_NAME beginning "___". */
402 field_name_match (const char *field_name, const char *target)
404 int len = strlen (target);
406 (strncmp (field_name, target, len) == 0
407 && (field_name[len] == '\0'
408 || (strncmp (field_name + len, "___", 3) == 0
409 && strcmp (field_name + strlen (field_name) - 6,
414 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
415 FIELD_NAME, and return its index. This function also handles fields
416 whose name have ___ suffixes because the compiler sometimes alters
417 their name by adding such a suffix to represent fields with certain
418 constraints. If the field could not be found, return a negative
419 number if MAYBE_MISSING is set. Otherwise raise an error. */
422 ada_get_field_index (const struct type *type, const char *field_name,
426 for (fieldno = 0; fieldno < TYPE_NFIELDS (type); fieldno++)
427 if (field_name_match (TYPE_FIELD_NAME (type, fieldno), field_name))
431 error (_("Unable to find field %s in struct %s. Aborting"),
432 field_name, TYPE_NAME (type));
437 /* The length of the prefix of NAME prior to any "___" suffix. */
440 ada_name_prefix_len (const char *name)
446 const char *p = strstr (name, "___");
448 return strlen (name);
454 /* Return non-zero if SUFFIX is a suffix of STR.
455 Return zero if STR is null. */
458 is_suffix (const char *str, const char *suffix)
464 len2 = strlen (suffix);
465 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
468 /* The contents of value VAL, treated as a value of type TYPE. The
469 result is an lval in memory if VAL is. */
471 static struct value *
472 coerce_unspec_val_to_type (struct value *val, struct type *type)
474 type = ada_check_typedef (type);
475 if (value_type (val) == type)
479 struct value *result;
481 /* Make sure that the object size is not unreasonable before
482 trying to allocate some memory for it. */
485 result = allocate_value (type);
486 set_value_component_location (result, val);
487 set_value_bitsize (result, value_bitsize (val));
488 set_value_bitpos (result, value_bitpos (val));
489 VALUE_ADDRESS (result) += value_offset (val);
491 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
492 set_value_lazy (result, 1);
494 memcpy (value_contents_raw (result), value_contents (val),
500 static const gdb_byte *
501 cond_offset_host (const gdb_byte *valaddr, long offset)
506 return valaddr + offset;
510 cond_offset_target (CORE_ADDR address, long offset)
515 return address + offset;
518 /* Issue a warning (as for the definition of warning in utils.c, but
519 with exactly one argument rather than ...), unless the limit on the
520 number of warnings has passed during the evaluation of the current
523 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
524 provided by "complaint". */
525 static void lim_warning (const char *format, ...) ATTR_FORMAT (printf, 1, 2);
528 lim_warning (const char *format, ...)
531 va_start (args, format);
533 warnings_issued += 1;
534 if (warnings_issued <= warning_limit)
535 vwarning (format, args);
540 /* Issue an error if the size of an object of type T is unreasonable,
541 i.e. if it would be a bad idea to allocate a value of this type in
545 check_size (const struct type *type)
547 if (TYPE_LENGTH (type) > varsize_limit)
548 error (_("object size is larger than varsize-limit"));
552 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
553 gdbtypes.h, but some of the necessary definitions in that file
554 seem to have gone missing. */
556 /* Maximum value of a SIZE-byte signed integer type. */
558 max_of_size (int size)
560 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
561 return top_bit | (top_bit - 1);
564 /* Minimum value of a SIZE-byte signed integer type. */
566 min_of_size (int size)
568 return -max_of_size (size) - 1;
571 /* Maximum value of a SIZE-byte unsigned integer type. */
573 umax_of_size (int size)
575 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
576 return top_bit | (top_bit - 1);
579 /* Maximum value of integral type T, as a signed quantity. */
581 max_of_type (struct type *t)
583 if (TYPE_UNSIGNED (t))
584 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
586 return max_of_size (TYPE_LENGTH (t));
589 /* Minimum value of integral type T, as a signed quantity. */
591 min_of_type (struct type *t)
593 if (TYPE_UNSIGNED (t))
596 return min_of_size (TYPE_LENGTH (t));
599 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
601 discrete_type_high_bound (struct type *type)
603 switch (TYPE_CODE (type))
605 case TYPE_CODE_RANGE:
606 return TYPE_HIGH_BOUND (type);
608 return TYPE_FIELD_BITPOS (type, TYPE_NFIELDS (type) - 1);
613 return max_of_type (type);
615 error (_("Unexpected type in discrete_type_high_bound."));
619 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
621 discrete_type_low_bound (struct type *type)
623 switch (TYPE_CODE (type))
625 case TYPE_CODE_RANGE:
626 return TYPE_LOW_BOUND (type);
628 return TYPE_FIELD_BITPOS (type, 0);
633 return min_of_type (type);
635 error (_("Unexpected type in discrete_type_low_bound."));
639 /* The identity on non-range types. For range types, the underlying
640 non-range scalar type. */
643 base_type (struct type *type)
645 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
647 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
649 type = TYPE_TARGET_TYPE (type);
655 /* Language Selection */
657 /* If the main program is in Ada, return language_ada, otherwise return LANG
658 (the main program is in Ada iif the adainit symbol is found).
660 MAIN_PST is not used. */
663 ada_update_initial_language (enum language lang,
664 struct partial_symtab *main_pst)
666 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
667 (struct objfile *) NULL) != NULL)
673 /* If the main procedure is written in Ada, then return its name.
674 The result is good until the next call. Return NULL if the main
675 procedure doesn't appear to be in Ada. */
680 struct minimal_symbol *msym;
681 CORE_ADDR main_program_name_addr;
682 static char main_program_name[1024];
684 /* For Ada, the name of the main procedure is stored in a specific
685 string constant, generated by the binder. Look for that symbol,
686 extract its address, and then read that string. If we didn't find
687 that string, then most probably the main procedure is not written
689 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
693 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
694 if (main_program_name_addr == 0)
695 error (_("Invalid address for Ada main program name."));
697 extract_string (main_program_name_addr, main_program_name);
698 return main_program_name;
701 /* The main procedure doesn't seem to be in Ada. */
707 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
710 const struct ada_opname_map ada_opname_table[] = {
711 {"Oadd", "\"+\"", BINOP_ADD},
712 {"Osubtract", "\"-\"", BINOP_SUB},
713 {"Omultiply", "\"*\"", BINOP_MUL},
714 {"Odivide", "\"/\"", BINOP_DIV},
715 {"Omod", "\"mod\"", BINOP_MOD},
716 {"Orem", "\"rem\"", BINOP_REM},
717 {"Oexpon", "\"**\"", BINOP_EXP},
718 {"Olt", "\"<\"", BINOP_LESS},
719 {"Ole", "\"<=\"", BINOP_LEQ},
720 {"Ogt", "\">\"", BINOP_GTR},
721 {"Oge", "\">=\"", BINOP_GEQ},
722 {"Oeq", "\"=\"", BINOP_EQUAL},
723 {"One", "\"/=\"", BINOP_NOTEQUAL},
724 {"Oand", "\"and\"", BINOP_BITWISE_AND},
725 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
726 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
727 {"Oconcat", "\"&\"", BINOP_CONCAT},
728 {"Oabs", "\"abs\"", UNOP_ABS},
729 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
730 {"Oadd", "\"+\"", UNOP_PLUS},
731 {"Osubtract", "\"-\"", UNOP_NEG},
735 /* The "encoded" form of DECODED, according to GNAT conventions.
736 The result is valid until the next call to ada_encode. */
739 ada_encode (const char *decoded)
741 static char *encoding_buffer = NULL;
742 static size_t encoding_buffer_size = 0;
749 GROW_VECT (encoding_buffer, encoding_buffer_size,
750 2 * strlen (decoded) + 10);
753 for (p = decoded; *p != '\0'; p += 1)
757 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
762 const struct ada_opname_map *mapping;
764 for (mapping = ada_opname_table;
765 mapping->encoded != NULL
766 && strncmp (mapping->decoded, p,
767 strlen (mapping->decoded)) != 0; mapping += 1)
769 if (mapping->encoded == NULL)
770 error (_("invalid Ada operator name: %s"), p);
771 strcpy (encoding_buffer + k, mapping->encoded);
772 k += strlen (mapping->encoded);
777 encoding_buffer[k] = *p;
782 encoding_buffer[k] = '\0';
783 return encoding_buffer;
786 /* Return NAME folded to lower case, or, if surrounded by single
787 quotes, unfolded, but with the quotes stripped away. Result good
791 ada_fold_name (const char *name)
793 static char *fold_buffer = NULL;
794 static size_t fold_buffer_size = 0;
796 int len = strlen (name);
797 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
801 strncpy (fold_buffer, name + 1, len - 2);
802 fold_buffer[len - 2] = '\000';
807 for (i = 0; i <= len; i += 1)
808 fold_buffer[i] = tolower (name[i]);
814 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
817 is_lower_alphanum (const char c)
819 return (isdigit (c) || (isalpha (c) && islower (c)));
822 /* Remove either of these suffixes:
827 These are suffixes introduced by the compiler for entities such as
828 nested subprogram for instance, in order to avoid name clashes.
829 They do not serve any purpose for the debugger. */
832 ada_remove_trailing_digits (const char *encoded, int *len)
834 if (*len > 1 && isdigit (encoded[*len - 1]))
837 while (i > 0 && isdigit (encoded[i]))
839 if (i >= 0 && encoded[i] == '.')
841 else if (i >= 0 && encoded[i] == '$')
843 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
845 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
850 /* Remove the suffix introduced by the compiler for protected object
854 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
856 /* Remove trailing N. */
858 /* Protected entry subprograms are broken into two
859 separate subprograms: The first one is unprotected, and has
860 a 'N' suffix; the second is the protected version, and has
861 the 'P' suffix. The second calls the first one after handling
862 the protection. Since the P subprograms are internally generated,
863 we leave these names undecoded, giving the user a clue that this
864 entity is internal. */
867 && encoded[*len - 1] == 'N'
868 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
872 /* If ENCODED follows the GNAT entity encoding conventions, then return
873 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
876 The resulting string is valid until the next call of ada_decode.
877 If the string is unchanged by decoding, the original string pointer
881 ada_decode (const char *encoded)
888 static char *decoding_buffer = NULL;
889 static size_t decoding_buffer_size = 0;
891 /* The name of the Ada main procedure starts with "_ada_".
892 This prefix is not part of the decoded name, so skip this part
893 if we see this prefix. */
894 if (strncmp (encoded, "_ada_", 5) == 0)
897 /* If the name starts with '_', then it is not a properly encoded
898 name, so do not attempt to decode it. Similarly, if the name
899 starts with '<', the name should not be decoded. */
900 if (encoded[0] == '_' || encoded[0] == '<')
903 len0 = strlen (encoded);
905 ada_remove_trailing_digits (encoded, &len0);
906 ada_remove_po_subprogram_suffix (encoded, &len0);
908 /* Remove the ___X.* suffix if present. Do not forget to verify that
909 the suffix is located before the current "end" of ENCODED. We want
910 to avoid re-matching parts of ENCODED that have previously been
911 marked as discarded (by decrementing LEN0). */
912 p = strstr (encoded, "___");
913 if (p != NULL && p - encoded < len0 - 3)
921 /* Remove any trailing TKB suffix. It tells us that this symbol
922 is for the body of a task, but that information does not actually
923 appear in the decoded name. */
925 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
928 /* Remove trailing "B" suffixes. */
929 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
931 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
934 /* Make decoded big enough for possible expansion by operator name. */
936 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
937 decoded = decoding_buffer;
939 /* Remove trailing __{digit}+ or trailing ${digit}+. */
941 if (len0 > 1 && isdigit (encoded[len0 - 1]))
944 while ((i >= 0 && isdigit (encoded[i]))
945 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
947 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
949 else if (encoded[i] == '$')
953 /* The first few characters that are not alphabetic are not part
954 of any encoding we use, so we can copy them over verbatim. */
956 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
957 decoded[j] = encoded[i];
962 /* Is this a symbol function? */
963 if (at_start_name && encoded[i] == 'O')
966 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
968 int op_len = strlen (ada_opname_table[k].encoded);
969 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
971 && !isalnum (encoded[i + op_len]))
973 strcpy (decoded + j, ada_opname_table[k].decoded);
976 j += strlen (ada_opname_table[k].decoded);
980 if (ada_opname_table[k].encoded != NULL)
985 /* Replace "TK__" with "__", which will eventually be translated
986 into "." (just below). */
988 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
991 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
992 be translated into "." (just below). These are internal names
993 generated for anonymous blocks inside which our symbol is nested. */
995 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
996 && encoded [i+2] == 'B' && encoded [i+3] == '_'
997 && isdigit (encoded [i+4]))
1001 while (k < len0 && isdigit (encoded[k]))
1002 k++; /* Skip any extra digit. */
1004 /* Double-check that the "__B_{DIGITS}+" sequence we found
1005 is indeed followed by "__". */
1006 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1010 /* Remove _E{DIGITS}+[sb] */
1012 /* Just as for protected object subprograms, there are 2 categories
1013 of subprograms created by the compiler for each entry. The first
1014 one implements the actual entry code, and has a suffix following
1015 the convention above; the second one implements the barrier and
1016 uses the same convention as above, except that the 'E' is replaced
1019 Just as above, we do not decode the name of barrier functions
1020 to give the user a clue that the code he is debugging has been
1021 internally generated. */
1023 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1024 && isdigit (encoded[i+2]))
1028 while (k < len0 && isdigit (encoded[k]))
1032 && (encoded[k] == 'b' || encoded[k] == 's'))
1035 /* Just as an extra precaution, make sure that if this
1036 suffix is followed by anything else, it is a '_'.
1037 Otherwise, we matched this sequence by accident. */
1039 || (k < len0 && encoded[k] == '_'))
1044 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1045 the GNAT front-end in protected object subprograms. */
1048 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1050 /* Backtrack a bit up until we reach either the begining of
1051 the encoded name, or "__". Make sure that we only find
1052 digits or lowercase characters. */
1053 const char *ptr = encoded + i - 1;
1055 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1058 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1062 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1064 /* This is a X[bn]* sequence not separated from the previous
1065 part of the name with a non-alpha-numeric character (in other
1066 words, immediately following an alpha-numeric character), then
1067 verify that it is placed at the end of the encoded name. If
1068 not, then the encoding is not valid and we should abort the
1069 decoding. Otherwise, just skip it, it is used in body-nested
1073 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1077 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1079 /* Replace '__' by '.'. */
1087 /* It's a character part of the decoded name, so just copy it
1089 decoded[j] = encoded[i];
1094 decoded[j] = '\000';
1096 /* Decoded names should never contain any uppercase character.
1097 Double-check this, and abort the decoding if we find one. */
1099 for (i = 0; decoded[i] != '\0'; i += 1)
1100 if (isupper (decoded[i]) || decoded[i] == ' ')
1103 if (strcmp (decoded, encoded) == 0)
1109 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1110 decoded = decoding_buffer;
1111 if (encoded[0] == '<')
1112 strcpy (decoded, encoded);
1114 sprintf (decoded, "<%s>", encoded);
1119 /* Table for keeping permanent unique copies of decoded names. Once
1120 allocated, names in this table are never released. While this is a
1121 storage leak, it should not be significant unless there are massive
1122 changes in the set of decoded names in successive versions of a
1123 symbol table loaded during a single session. */
1124 static struct htab *decoded_names_store;
1126 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1127 in the language-specific part of GSYMBOL, if it has not been
1128 previously computed. Tries to save the decoded name in the same
1129 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1130 in any case, the decoded symbol has a lifetime at least that of
1132 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1133 const, but nevertheless modified to a semantically equivalent form
1134 when a decoded name is cached in it.
1138 ada_decode_symbol (const struct general_symbol_info *gsymbol)
1141 (char **) &gsymbol->language_specific.cplus_specific.demangled_name;
1142 if (*resultp == NULL)
1144 const char *decoded = ada_decode (gsymbol->name);
1145 if (gsymbol->obj_section != NULL)
1147 struct objfile *objf = gsymbol->obj_section->objfile;
1148 *resultp = obsavestring (decoded, strlen (decoded),
1149 &objf->objfile_obstack);
1151 /* Sometimes, we can't find a corresponding objfile, in which
1152 case, we put the result on the heap. Since we only decode
1153 when needed, we hope this usually does not cause a
1154 significant memory leak (FIXME). */
1155 if (*resultp == NULL)
1157 char **slot = (char **) htab_find_slot (decoded_names_store,
1160 *slot = xstrdup (decoded);
1169 ada_la_decode (const char *encoded, int options)
1171 return xstrdup (ada_decode (encoded));
1174 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1175 suffixes that encode debugging information or leading _ada_ on
1176 SYM_NAME (see is_name_suffix commentary for the debugging
1177 information that is ignored). If WILD, then NAME need only match a
1178 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1179 either argument is NULL. */
1182 ada_match_name (const char *sym_name, const char *name, int wild)
1184 if (sym_name == NULL || name == NULL)
1187 return wild_match (name, strlen (name), sym_name);
1190 int len_name = strlen (name);
1191 return (strncmp (sym_name, name, len_name) == 0
1192 && is_name_suffix (sym_name + len_name))
1193 || (strncmp (sym_name, "_ada_", 5) == 0
1194 && strncmp (sym_name + 5, name, len_name) == 0
1195 && is_name_suffix (sym_name + len_name + 5));
1202 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1204 static char *bound_name[] = {
1205 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1206 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1209 /* Maximum number of array dimensions we are prepared to handle. */
1211 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1213 /* Like modify_field, but allows bitpos > wordlength. */
1216 modify_general_field (char *addr, LONGEST fieldval, int bitpos, int bitsize)
1218 modify_field (addr + bitpos / 8, fieldval, bitpos % 8, bitsize);
1222 /* The desc_* routines return primitive portions of array descriptors
1225 /* The descriptor or array type, if any, indicated by TYPE; removes
1226 level of indirection, if needed. */
1228 static struct type *
1229 desc_base_type (struct type *type)
1233 type = ada_check_typedef (type);
1235 && (TYPE_CODE (type) == TYPE_CODE_PTR
1236 || TYPE_CODE (type) == TYPE_CODE_REF))
1237 return ada_check_typedef (TYPE_TARGET_TYPE (type));
1242 /* True iff TYPE indicates a "thin" array pointer type. */
1245 is_thin_pntr (struct type *type)
1248 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1249 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1252 /* The descriptor type for thin pointer type TYPE. */
1254 static struct type *
1255 thin_descriptor_type (struct type *type)
1257 struct type *base_type = desc_base_type (type);
1258 if (base_type == NULL)
1260 if (is_suffix (ada_type_name (base_type), "___XVE"))
1264 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1265 if (alt_type == NULL)
1272 /* A pointer to the array data for thin-pointer value VAL. */
1274 static struct value *
1275 thin_data_pntr (struct value *val)
1277 struct type *type = value_type (val);
1278 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1279 return value_cast (desc_data_type (thin_descriptor_type (type)),
1282 return value_from_longest (desc_data_type (thin_descriptor_type (type)),
1283 VALUE_ADDRESS (val) + value_offset (val));
1286 /* True iff TYPE indicates a "thick" array pointer type. */
1289 is_thick_pntr (struct type *type)
1291 type = desc_base_type (type);
1292 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1293 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1296 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1297 pointer to one, the type of its bounds data; otherwise, NULL. */
1299 static struct type *
1300 desc_bounds_type (struct type *type)
1304 type = desc_base_type (type);
1308 else if (is_thin_pntr (type))
1310 type = thin_descriptor_type (type);
1313 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1315 return ada_check_typedef (r);
1317 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1319 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1321 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1326 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1327 one, a pointer to its bounds data. Otherwise NULL. */
1329 static struct value *
1330 desc_bounds (struct value *arr)
1332 struct type *type = ada_check_typedef (value_type (arr));
1333 if (is_thin_pntr (type))
1335 struct type *bounds_type =
1336 desc_bounds_type (thin_descriptor_type (type));
1339 if (bounds_type == NULL)
1340 error (_("Bad GNAT array descriptor"));
1342 /* NOTE: The following calculation is not really kosher, but
1343 since desc_type is an XVE-encoded type (and shouldn't be),
1344 the correct calculation is a real pain. FIXME (and fix GCC). */
1345 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1346 addr = value_as_long (arr);
1348 addr = VALUE_ADDRESS (arr) + value_offset (arr);
1351 value_from_longest (lookup_pointer_type (bounds_type),
1352 addr - TYPE_LENGTH (bounds_type));
1355 else if (is_thick_pntr (type))
1356 return value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1357 _("Bad GNAT array descriptor"));
1362 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1363 position of the field containing the address of the bounds data. */
1366 fat_pntr_bounds_bitpos (struct type *type)
1368 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1371 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1372 size of the field containing the address of the bounds data. */
1375 fat_pntr_bounds_bitsize (struct type *type)
1377 type = desc_base_type (type);
1379 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1380 return TYPE_FIELD_BITSIZE (type, 1);
1382 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1385 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1386 pointer to one, the type of its array data (a
1387 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1388 ada_type_of_array to get an array type with bounds data. */
1390 static struct type *
1391 desc_data_type (struct type *type)
1393 type = desc_base_type (type);
1395 /* NOTE: The following is bogus; see comment in desc_bounds. */
1396 if (is_thin_pntr (type))
1397 return lookup_pointer_type
1398 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)));
1399 else if (is_thick_pntr (type))
1400 return lookup_struct_elt_type (type, "P_ARRAY", 1);
1405 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1408 static struct value *
1409 desc_data (struct value *arr)
1411 struct type *type = value_type (arr);
1412 if (is_thin_pntr (type))
1413 return thin_data_pntr (arr);
1414 else if (is_thick_pntr (type))
1415 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1416 _("Bad GNAT array descriptor"));
1422 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1423 position of the field containing the address of the data. */
1426 fat_pntr_data_bitpos (struct type *type)
1428 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1431 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1432 size of the field containing the address of the data. */
1435 fat_pntr_data_bitsize (struct type *type)
1437 type = desc_base_type (type);
1439 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1440 return TYPE_FIELD_BITSIZE (type, 0);
1442 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1445 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1446 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1447 bound, if WHICH is 1. The first bound is I=1. */
1449 static struct value *
1450 desc_one_bound (struct value *bounds, int i, int which)
1452 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1453 _("Bad GNAT array descriptor bounds"));
1456 /* If BOUNDS is an array-bounds structure type, return the bit position
1457 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1458 bound, if WHICH is 1. The first bound is I=1. */
1461 desc_bound_bitpos (struct type *type, int i, int which)
1463 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1466 /* If BOUNDS is an array-bounds structure type, return the bit field size
1467 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1468 bound, if WHICH is 1. The first bound is I=1. */
1471 desc_bound_bitsize (struct type *type, int i, int which)
1473 type = desc_base_type (type);
1475 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1476 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1478 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1481 /* If TYPE is the type of an array-bounds structure, the type of its
1482 Ith bound (numbering from 1). Otherwise, NULL. */
1484 static struct type *
1485 desc_index_type (struct type *type, int i)
1487 type = desc_base_type (type);
1489 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1490 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1495 /* The number of index positions in the array-bounds type TYPE.
1496 Return 0 if TYPE is NULL. */
1499 desc_arity (struct type *type)
1501 type = desc_base_type (type);
1504 return TYPE_NFIELDS (type) / 2;
1508 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1509 an array descriptor type (representing an unconstrained array
1513 ada_is_direct_array_type (struct type *type)
1517 type = ada_check_typedef (type);
1518 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1519 || ada_is_array_descriptor_type (type));
1522 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1526 ada_is_array_type (struct type *type)
1529 && (TYPE_CODE (type) == TYPE_CODE_PTR
1530 || TYPE_CODE (type) == TYPE_CODE_REF))
1531 type = TYPE_TARGET_TYPE (type);
1532 return ada_is_direct_array_type (type);
1535 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1538 ada_is_simple_array_type (struct type *type)
1542 type = ada_check_typedef (type);
1543 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1544 || (TYPE_CODE (type) == TYPE_CODE_PTR
1545 && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY));
1548 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1551 ada_is_array_descriptor_type (struct type *type)
1553 struct type *data_type = desc_data_type (type);
1557 type = ada_check_typedef (type);
1560 && ((TYPE_CODE (data_type) == TYPE_CODE_PTR
1561 && TYPE_TARGET_TYPE (data_type) != NULL
1562 && TYPE_CODE (TYPE_TARGET_TYPE (data_type)) == TYPE_CODE_ARRAY)
1563 || TYPE_CODE (data_type) == TYPE_CODE_ARRAY)
1564 && desc_arity (desc_bounds_type (type)) > 0;
1567 /* Non-zero iff type is a partially mal-formed GNAT array
1568 descriptor. FIXME: This is to compensate for some problems with
1569 debugging output from GNAT. Re-examine periodically to see if it
1573 ada_is_bogus_array_descriptor (struct type *type)
1577 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1578 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1579 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1580 && !ada_is_array_descriptor_type (type);
1584 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1585 (fat pointer) returns the type of the array data described---specifically,
1586 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1587 in from the descriptor; otherwise, they are left unspecified. If
1588 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1589 returns NULL. The result is simply the type of ARR if ARR is not
1592 ada_type_of_array (struct value *arr, int bounds)
1594 if (ada_is_packed_array_type (value_type (arr)))
1595 return decode_packed_array_type (value_type (arr));
1597 if (!ada_is_array_descriptor_type (value_type (arr)))
1598 return value_type (arr);
1602 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr))));
1605 struct type *elt_type;
1607 struct value *descriptor;
1608 struct objfile *objf = TYPE_OBJFILE (value_type (arr));
1610 elt_type = ada_array_element_type (value_type (arr), -1);
1611 arity = ada_array_arity (value_type (arr));
1613 if (elt_type == NULL || arity == 0)
1614 return ada_check_typedef (value_type (arr));
1616 descriptor = desc_bounds (arr);
1617 if (value_as_long (descriptor) == 0)
1621 struct type *range_type = alloc_type (objf);
1622 struct type *array_type = alloc_type (objf);
1623 struct value *low = desc_one_bound (descriptor, arity, 0);
1624 struct value *high = desc_one_bound (descriptor, arity, 1);
1627 create_range_type (range_type, value_type (low),
1628 longest_to_int (value_as_long (low)),
1629 longest_to_int (value_as_long (high)));
1630 elt_type = create_array_type (array_type, elt_type, range_type);
1633 return lookup_pointer_type (elt_type);
1637 /* If ARR does not represent an array, returns ARR unchanged.
1638 Otherwise, returns either a standard GDB array with bounds set
1639 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1640 GDB array. Returns NULL if ARR is a null fat pointer. */
1643 ada_coerce_to_simple_array_ptr (struct value *arr)
1645 if (ada_is_array_descriptor_type (value_type (arr)))
1647 struct type *arrType = ada_type_of_array (arr, 1);
1648 if (arrType == NULL)
1650 return value_cast (arrType, value_copy (desc_data (arr)));
1652 else if (ada_is_packed_array_type (value_type (arr)))
1653 return decode_packed_array (arr);
1658 /* If ARR does not represent an array, returns ARR unchanged.
1659 Otherwise, returns a standard GDB array describing ARR (which may
1660 be ARR itself if it already is in the proper form). */
1662 static struct value *
1663 ada_coerce_to_simple_array (struct value *arr)
1665 if (ada_is_array_descriptor_type (value_type (arr)))
1667 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1669 error (_("Bounds unavailable for null array pointer."));
1670 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
1671 return value_ind (arrVal);
1673 else if (ada_is_packed_array_type (value_type (arr)))
1674 return decode_packed_array (arr);
1679 /* If TYPE represents a GNAT array type, return it translated to an
1680 ordinary GDB array type (possibly with BITSIZE fields indicating
1681 packing). For other types, is the identity. */
1684 ada_coerce_to_simple_array_type (struct type *type)
1686 struct value *mark = value_mark ();
1687 struct value *dummy = value_from_longest (builtin_type_int32, 0);
1688 struct type *result;
1689 deprecated_set_value_type (dummy, type);
1690 result = ada_type_of_array (dummy, 0);
1691 value_free_to_mark (mark);
1695 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1698 ada_is_packed_array_type (struct type *type)
1702 type = desc_base_type (type);
1703 type = ada_check_typedef (type);
1705 ada_type_name (type) != NULL
1706 && strstr (ada_type_name (type), "___XP") != NULL;
1709 /* Given that TYPE is a standard GDB array type with all bounds filled
1710 in, and that the element size of its ultimate scalar constituents
1711 (that is, either its elements, or, if it is an array of arrays, its
1712 elements' elements, etc.) is *ELT_BITS, return an identical type,
1713 but with the bit sizes of its elements (and those of any
1714 constituent arrays) recorded in the BITSIZE components of its
1715 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1718 static struct type *
1719 packed_array_type (struct type *type, long *elt_bits)
1721 struct type *new_elt_type;
1722 struct type *new_type;
1723 LONGEST low_bound, high_bound;
1725 type = ada_check_typedef (type);
1726 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1729 new_type = alloc_type (TYPE_OBJFILE (type));
1730 new_elt_type = packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
1732 create_array_type (new_type, new_elt_type, TYPE_INDEX_TYPE (type));
1733 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
1734 TYPE_NAME (new_type) = ada_type_name (type);
1736 if (get_discrete_bounds (TYPE_INDEX_TYPE (type),
1737 &low_bound, &high_bound) < 0)
1738 low_bound = high_bound = 0;
1739 if (high_bound < low_bound)
1740 *elt_bits = TYPE_LENGTH (new_type) = 0;
1743 *elt_bits *= (high_bound - low_bound + 1);
1744 TYPE_LENGTH (new_type) =
1745 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
1748 TYPE_FIXED_INSTANCE (new_type) = 1;
1752 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1754 static struct type *
1755 decode_packed_array_type (struct type *type)
1758 struct block **blocks;
1759 char *raw_name = ada_type_name (ada_check_typedef (type));
1762 struct type *shadow_type;
1767 raw_name = ada_type_name (desc_base_type (type));
1772 name = (char *) alloca (strlen (raw_name) + 1);
1773 tail = strstr (raw_name, "___XP");
1774 type = desc_base_type (type);
1776 memcpy (name, raw_name, tail - raw_name);
1777 name[tail - raw_name] = '\000';
1779 sym = standard_lookup (name, get_selected_block (0), VAR_DOMAIN);
1780 if (sym == NULL || SYMBOL_TYPE (sym) == NULL)
1782 lim_warning (_("could not find bounds information on packed array"));
1785 shadow_type = SYMBOL_TYPE (sym);
1787 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
1789 lim_warning (_("could not understand bounds information on packed array"));
1793 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1796 (_("could not understand bit size information on packed array"));
1800 return packed_array_type (shadow_type, &bits);
1803 /* Given that ARR is a struct value *indicating a GNAT packed array,
1804 returns a simple array that denotes that array. Its type is a
1805 standard GDB array type except that the BITSIZEs of the array
1806 target types are set to the number of bits in each element, and the
1807 type length is set appropriately. */
1809 static struct value *
1810 decode_packed_array (struct value *arr)
1814 arr = ada_coerce_ref (arr);
1815 if (TYPE_CODE (value_type (arr)) == TYPE_CODE_PTR)
1816 arr = ada_value_ind (arr);
1818 type = decode_packed_array_type (value_type (arr));
1821 error (_("can't unpack array"));
1825 if (gdbarch_bits_big_endian (current_gdbarch)
1826 && ada_is_modular_type (value_type (arr)))
1828 /* This is a (right-justified) modular type representing a packed
1829 array with no wrapper. In order to interpret the value through
1830 the (left-justified) packed array type we just built, we must
1831 first left-justify it. */
1832 int bit_size, bit_pos;
1835 mod = ada_modulus (value_type (arr)) - 1;
1842 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
1843 arr = ada_value_primitive_packed_val (arr, NULL,
1844 bit_pos / HOST_CHAR_BIT,
1845 bit_pos % HOST_CHAR_BIT,
1850 return coerce_unspec_val_to_type (arr, type);
1854 /* The value of the element of packed array ARR at the ARITY indices
1855 given in IND. ARR must be a simple array. */
1857 static struct value *
1858 value_subscript_packed (struct value *arr, int arity, struct value **ind)
1861 int bits, elt_off, bit_off;
1862 long elt_total_bit_offset;
1863 struct type *elt_type;
1867 elt_total_bit_offset = 0;
1868 elt_type = ada_check_typedef (value_type (arr));
1869 for (i = 0; i < arity; i += 1)
1871 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
1872 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
1874 (_("attempt to do packed indexing of something other than a packed array"));
1877 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
1878 LONGEST lowerbound, upperbound;
1881 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
1883 lim_warning (_("don't know bounds of array"));
1884 lowerbound = upperbound = 0;
1887 idx = pos_atr (ind[i]);
1888 if (idx < lowerbound || idx > upperbound)
1889 lim_warning (_("packed array index %ld out of bounds"), (long) idx);
1890 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
1891 elt_total_bit_offset += (idx - lowerbound) * bits;
1892 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
1895 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
1896 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
1898 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
1903 /* Non-zero iff TYPE includes negative integer values. */
1906 has_negatives (struct type *type)
1908 switch (TYPE_CODE (type))
1913 return !TYPE_UNSIGNED (type);
1914 case TYPE_CODE_RANGE:
1915 return TYPE_LOW_BOUND (type) < 0;
1920 /* Create a new value of type TYPE from the contents of OBJ starting
1921 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1922 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1923 assigning through the result will set the field fetched from.
1924 VALADDR is ignored unless OBJ is NULL, in which case,
1925 VALADDR+OFFSET must address the start of storage containing the
1926 packed value. The value returned in this case is never an lval.
1927 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1930 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
1931 long offset, int bit_offset, int bit_size,
1935 int src, /* Index into the source area */
1936 targ, /* Index into the target area */
1937 srcBitsLeft, /* Number of source bits left to move */
1938 nsrc, ntarg, /* Number of source and target bytes */
1939 unusedLS, /* Number of bits in next significant
1940 byte of source that are unused */
1941 accumSize; /* Number of meaningful bits in accum */
1942 unsigned char *bytes; /* First byte containing data to unpack */
1943 unsigned char *unpacked;
1944 unsigned long accum; /* Staging area for bits being transferred */
1946 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
1947 /* Transmit bytes from least to most significant; delta is the direction
1948 the indices move. */
1949 int delta = gdbarch_bits_big_endian (current_gdbarch) ? -1 : 1;
1951 type = ada_check_typedef (type);
1955 v = allocate_value (type);
1956 bytes = (unsigned char *) (valaddr + offset);
1958 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
1961 VALUE_ADDRESS (obj) + value_offset (obj) + offset);
1962 bytes = (unsigned char *) alloca (len);
1963 read_memory (VALUE_ADDRESS (v), bytes, len);
1967 v = allocate_value (type);
1968 bytes = (unsigned char *) value_contents (obj) + offset;
1973 set_value_component_location (v, obj);
1974 VALUE_ADDRESS (v) += value_offset (obj) + offset;
1975 set_value_bitpos (v, bit_offset + value_bitpos (obj));
1976 set_value_bitsize (v, bit_size);
1977 if (value_bitpos (v) >= HOST_CHAR_BIT)
1979 VALUE_ADDRESS (v) += 1;
1980 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
1984 set_value_bitsize (v, bit_size);
1985 unpacked = (unsigned char *) value_contents (v);
1987 srcBitsLeft = bit_size;
1989 ntarg = TYPE_LENGTH (type);
1993 memset (unpacked, 0, TYPE_LENGTH (type));
1996 else if (gdbarch_bits_big_endian (current_gdbarch))
1999 if (has_negatives (type)
2000 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2004 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2007 switch (TYPE_CODE (type))
2009 case TYPE_CODE_ARRAY:
2010 case TYPE_CODE_UNION:
2011 case TYPE_CODE_STRUCT:
2012 /* Non-scalar values must be aligned at a byte boundary... */
2014 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2015 /* ... And are placed at the beginning (most-significant) bytes
2017 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2022 targ = TYPE_LENGTH (type) - 1;
2028 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2031 unusedLS = bit_offset;
2034 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
2041 /* Mask for removing bits of the next source byte that are not
2042 part of the value. */
2043 unsigned int unusedMSMask =
2044 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2046 /* Sign-extend bits for this byte. */
2047 unsigned int signMask = sign & ~unusedMSMask;
2049 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2050 accumSize += HOST_CHAR_BIT - unusedLS;
2051 if (accumSize >= HOST_CHAR_BIT)
2053 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2054 accumSize -= HOST_CHAR_BIT;
2055 accum >>= HOST_CHAR_BIT;
2059 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2066 accum |= sign << accumSize;
2067 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2068 accumSize -= HOST_CHAR_BIT;
2069 accum >>= HOST_CHAR_BIT;
2077 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2078 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2081 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2082 int src_offset, int n)
2084 unsigned int accum, mask;
2085 int accum_bits, chunk_size;
2087 target += targ_offset / HOST_CHAR_BIT;
2088 targ_offset %= HOST_CHAR_BIT;
2089 source += src_offset / HOST_CHAR_BIT;
2090 src_offset %= HOST_CHAR_BIT;
2091 if (gdbarch_bits_big_endian (current_gdbarch))
2093 accum = (unsigned char) *source;
2095 accum_bits = HOST_CHAR_BIT - src_offset;
2100 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2101 accum_bits += HOST_CHAR_BIT;
2103 chunk_size = HOST_CHAR_BIT - targ_offset;
2106 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2107 mask = ((1 << chunk_size) - 1) << unused_right;
2110 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2112 accum_bits -= chunk_size;
2119 accum = (unsigned char) *source >> src_offset;
2121 accum_bits = HOST_CHAR_BIT - src_offset;
2125 accum = accum + ((unsigned char) *source << accum_bits);
2126 accum_bits += HOST_CHAR_BIT;
2128 chunk_size = HOST_CHAR_BIT - targ_offset;
2131 mask = ((1 << chunk_size) - 1) << targ_offset;
2132 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2134 accum_bits -= chunk_size;
2135 accum >>= chunk_size;
2142 /* Store the contents of FROMVAL into the location of TOVAL.
2143 Return a new value with the location of TOVAL and contents of
2144 FROMVAL. Handles assignment into packed fields that have
2145 floating-point or non-scalar types. */
2147 static struct value *
2148 ada_value_assign (struct value *toval, struct value *fromval)
2150 struct type *type = value_type (toval);
2151 int bits = value_bitsize (toval);
2153 toval = ada_coerce_ref (toval);
2154 fromval = ada_coerce_ref (fromval);
2156 if (ada_is_direct_array_type (value_type (toval)))
2157 toval = ada_coerce_to_simple_array (toval);
2158 if (ada_is_direct_array_type (value_type (fromval)))
2159 fromval = ada_coerce_to_simple_array (fromval);
2161 if (!deprecated_value_modifiable (toval))
2162 error (_("Left operand of assignment is not a modifiable lvalue."));
2164 if (VALUE_LVAL (toval) == lval_memory
2166 && (TYPE_CODE (type) == TYPE_CODE_FLT
2167 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2169 int len = (value_bitpos (toval)
2170 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2172 char *buffer = (char *) alloca (len);
2174 CORE_ADDR to_addr = VALUE_ADDRESS (toval) + value_offset (toval);
2176 if (TYPE_CODE (type) == TYPE_CODE_FLT)
2177 fromval = value_cast (type, fromval);
2179 read_memory (to_addr, buffer, len);
2180 from_size = value_bitsize (fromval);
2182 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2183 if (gdbarch_bits_big_endian (current_gdbarch))
2184 move_bits (buffer, value_bitpos (toval),
2185 value_contents (fromval), from_size - bits, bits);
2187 move_bits (buffer, value_bitpos (toval), value_contents (fromval),
2189 write_memory (to_addr, buffer, len);
2190 if (deprecated_memory_changed_hook)
2191 deprecated_memory_changed_hook (to_addr, len);
2193 val = value_copy (toval);
2194 memcpy (value_contents_raw (val), value_contents (fromval),
2195 TYPE_LENGTH (type));
2196 deprecated_set_value_type (val, type);
2201 return value_assign (toval, fromval);
2205 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2206 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2207 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2208 * COMPONENT, and not the inferior's memory. The current contents
2209 * of COMPONENT are ignored. */
2211 value_assign_to_component (struct value *container, struct value *component,
2214 LONGEST offset_in_container =
2215 (LONGEST) (VALUE_ADDRESS (component) + value_offset (component)
2216 - VALUE_ADDRESS (container) - value_offset (container));
2217 int bit_offset_in_container =
2218 value_bitpos (component) - value_bitpos (container);
2221 val = value_cast (value_type (component), val);
2223 if (value_bitsize (component) == 0)
2224 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2226 bits = value_bitsize (component);
2228 if (gdbarch_bits_big_endian (current_gdbarch))
2229 move_bits (value_contents_writeable (container) + offset_in_container,
2230 value_bitpos (container) + bit_offset_in_container,
2231 value_contents (val),
2232 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2235 move_bits (value_contents_writeable (container) + offset_in_container,
2236 value_bitpos (container) + bit_offset_in_container,
2237 value_contents (val), 0, bits);
2240 /* The value of the element of array ARR at the ARITY indices given in IND.
2241 ARR may be either a simple array, GNAT array descriptor, or pointer
2245 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2249 struct type *elt_type;
2251 elt = ada_coerce_to_simple_array (arr);
2253 elt_type = ada_check_typedef (value_type (elt));
2254 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2255 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2256 return value_subscript_packed (elt, arity, ind);
2258 for (k = 0; k < arity; k += 1)
2260 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2261 error (_("too many subscripts (%d expected)"), k);
2262 elt = value_subscript (elt, value_pos_atr (builtin_type_int32, ind[k]));
2267 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2268 value of the element of *ARR at the ARITY indices given in
2269 IND. Does not read the entire array into memory. */
2271 static struct value *
2272 ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
2277 for (k = 0; k < arity; k += 1)
2282 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2283 error (_("too many subscripts (%d expected)"), k);
2284 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2286 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2287 idx = value_pos_atr (builtin_type_int32, ind[k]);
2289 idx = value_binop (idx, value_from_longest (value_type (idx), lwb),
2292 arr = value_ptradd (arr, idx);
2293 type = TYPE_TARGET_TYPE (type);
2296 return value_ind (arr);
2299 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2300 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2301 elements starting at index LOW. The lower bound of this array is LOW, as
2303 static struct value *
2304 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2307 CORE_ADDR base = value_as_address (array_ptr)
2308 + ((low - TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type)))
2309 * TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
2310 struct type *index_type =
2311 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)),
2313 struct type *slice_type =
2314 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2315 return value_at_lazy (slice_type, base);
2319 static struct value *
2320 ada_value_slice (struct value *array, int low, int high)
2322 struct type *type = value_type (array);
2323 struct type *index_type =
2324 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2325 struct type *slice_type =
2326 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2327 return value_cast (slice_type, value_slice (array, low, high - low + 1));
2330 /* If type is a record type in the form of a standard GNAT array
2331 descriptor, returns the number of dimensions for type. If arr is a
2332 simple array, returns the number of "array of"s that prefix its
2333 type designation. Otherwise, returns 0. */
2336 ada_array_arity (struct type *type)
2343 type = desc_base_type (type);
2346 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2347 return desc_arity (desc_bounds_type (type));
2349 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2352 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2358 /* If TYPE is a record type in the form of a standard GNAT array
2359 descriptor or a simple array type, returns the element type for
2360 TYPE after indexing by NINDICES indices, or by all indices if
2361 NINDICES is -1. Otherwise, returns NULL. */
2364 ada_array_element_type (struct type *type, int nindices)
2366 type = desc_base_type (type);
2368 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2371 struct type *p_array_type;
2373 p_array_type = desc_data_type (type);
2375 k = ada_array_arity (type);
2379 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2380 if (nindices >= 0 && k > nindices)
2382 p_array_type = TYPE_TARGET_TYPE (p_array_type);
2383 while (k > 0 && p_array_type != NULL)
2385 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2388 return p_array_type;
2390 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2392 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
2394 type = TYPE_TARGET_TYPE (type);
2403 /* The type of nth index in arrays of given type (n numbering from 1).
2404 Does not examine memory. */
2407 ada_index_type (struct type *type, int n)
2409 struct type *result_type;
2411 type = desc_base_type (type);
2413 if (n > ada_array_arity (type))
2416 if (ada_is_simple_array_type (type))
2420 for (i = 1; i < n; i += 1)
2421 type = TYPE_TARGET_TYPE (type);
2422 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2423 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2424 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2425 perhaps stabsread.c would make more sense. */
2426 if (result_type == NULL || TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2427 result_type = builtin_type_int32;
2432 return desc_index_type (desc_bounds_type (type), n);
2435 /* Given that arr is an array type, returns the lower bound of the
2436 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2437 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2438 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2439 bounds type. It works for other arrays with bounds supplied by
2440 run-time quantities other than discriminants. */
2443 ada_array_bound_from_type (struct type * arr_type, int n, int which,
2444 struct type ** typep)
2446 struct type *type, *index_type_desc, *index_type;
2449 gdb_assert (which == 0 || which == 1);
2451 if (ada_is_packed_array_type (arr_type))
2452 arr_type = decode_packed_array_type (arr_type);
2454 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2457 *typep = builtin_type_int32;
2458 return (LONGEST) - which;
2461 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2462 type = TYPE_TARGET_TYPE (arr_type);
2466 index_type_desc = ada_find_parallel_type (type, "___XA");
2467 if (index_type_desc != NULL)
2468 index_type = to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n - 1),
2469 NULL, TYPE_OBJFILE (arr_type));
2474 type = TYPE_TARGET_TYPE (type);
2478 index_type = TYPE_INDEX_TYPE (type);
2481 switch (TYPE_CODE (index_type))
2483 case TYPE_CODE_RANGE:
2484 retval = which == 0 ? TYPE_LOW_BOUND (index_type)
2485 : TYPE_HIGH_BOUND (index_type);
2487 case TYPE_CODE_ENUM:
2488 retval = which == 0 ? TYPE_FIELD_BITPOS (index_type, 0)
2489 : TYPE_FIELD_BITPOS (index_type,
2490 TYPE_NFIELDS (index_type) - 1);
2493 internal_error (__FILE__, __LINE__, _("invalid type code of index type"));
2497 *typep = index_type;
2502 /* Given that arr is an array value, returns the lower bound of the
2503 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2504 WHICH is 1. This routine will also work for arrays with bounds
2505 supplied by run-time quantities other than discriminants. */
2508 ada_array_bound (struct value *arr, int n, int which)
2510 struct type *arr_type = value_type (arr);
2512 if (ada_is_packed_array_type (arr_type))
2513 return ada_array_bound (decode_packed_array (arr), n, which);
2514 else if (ada_is_simple_array_type (arr_type))
2517 LONGEST v = ada_array_bound_from_type (arr_type, n, which, &type);
2518 return value_from_longest (type, v);
2521 return desc_one_bound (desc_bounds (arr), n, which);
2524 /* Given that arr is an array value, returns the length of the
2525 nth index. This routine will also work for arrays with bounds
2526 supplied by run-time quantities other than discriminants.
2527 Does not work for arrays indexed by enumeration types with representation
2528 clauses at the moment. */
2530 static struct value *
2531 ada_array_length (struct value *arr, int n)
2533 struct type *arr_type = ada_check_typedef (value_type (arr));
2535 if (ada_is_packed_array_type (arr_type))
2536 return ada_array_length (decode_packed_array (arr), n);
2538 if (ada_is_simple_array_type (arr_type))
2542 ada_array_bound_from_type (arr_type, n, 1, &type) -
2543 ada_array_bound_from_type (arr_type, n, 0, NULL) + 1;
2544 return value_from_longest (type, v);
2548 value_from_longest (builtin_type_int32,
2549 value_as_long (desc_one_bound (desc_bounds (arr),
2551 - value_as_long (desc_one_bound (desc_bounds (arr),
2555 /* An empty array whose type is that of ARR_TYPE (an array type),
2556 with bounds LOW to LOW-1. */
2558 static struct value *
2559 empty_array (struct type *arr_type, int low)
2561 struct type *index_type =
2562 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type)),
2564 struct type *elt_type = ada_array_element_type (arr_type, 1);
2565 return allocate_value (create_array_type (NULL, elt_type, index_type));
2569 /* Name resolution */
2571 /* The "decoded" name for the user-definable Ada operator corresponding
2575 ada_decoded_op_name (enum exp_opcode op)
2579 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
2581 if (ada_opname_table[i].op == op)
2582 return ada_opname_table[i].decoded;
2584 error (_("Could not find operator name for opcode"));
2588 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2589 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2590 undefined namespace) and converts operators that are
2591 user-defined into appropriate function calls. If CONTEXT_TYPE is
2592 non-null, it provides a preferred result type [at the moment, only
2593 type void has any effect---causing procedures to be preferred over
2594 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2595 return type is preferred. May change (expand) *EXP. */
2598 resolve (struct expression **expp, int void_context_p)
2602 resolve_subexp (expp, &pc, 1, void_context_p ? builtin_type_void : NULL);
2605 /* Resolve the operator of the subexpression beginning at
2606 position *POS of *EXPP. "Resolving" consists of replacing
2607 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2608 with their resolutions, replacing built-in operators with
2609 function calls to user-defined operators, where appropriate, and,
2610 when DEPROCEDURE_P is non-zero, converting function-valued variables
2611 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2612 are as in ada_resolve, above. */
2614 static struct value *
2615 resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
2616 struct type *context_type)
2620 struct expression *exp; /* Convenience: == *expp. */
2621 enum exp_opcode op = (*expp)->elts[pc].opcode;
2622 struct value **argvec; /* Vector of operand types (alloca'ed). */
2623 int nargs; /* Number of operands. */
2630 /* Pass one: resolve operands, saving their types and updating *pos,
2635 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2636 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2641 resolve_subexp (expp, pos, 0, NULL);
2643 nargs = longest_to_int (exp->elts[pc + 1].longconst);
2648 resolve_subexp (expp, pos, 0, NULL);
2653 resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2656 case OP_ATR_MODULUS:
2666 case TERNOP_IN_RANGE:
2667 case BINOP_IN_BOUNDS:
2673 case OP_DISCRETE_RANGE:
2675 ada_forward_operator_length (exp, pc, &oplen, &nargs);
2684 arg1 = resolve_subexp (expp, pos, 0, NULL);
2686 resolve_subexp (expp, pos, 1, NULL);
2688 resolve_subexp (expp, pos, 1, value_type (arg1));
2705 case BINOP_LOGICAL_AND:
2706 case BINOP_LOGICAL_OR:
2707 case BINOP_BITWISE_AND:
2708 case BINOP_BITWISE_IOR:
2709 case BINOP_BITWISE_XOR:
2712 case BINOP_NOTEQUAL:
2719 case BINOP_SUBSCRIPT:
2727 case UNOP_LOGICAL_NOT:
2743 case OP_INTERNALVAR:
2753 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2756 case STRUCTOP_STRUCT:
2757 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2770 error (_("Unexpected operator during name resolution"));
2773 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
2774 for (i = 0; i < nargs; i += 1)
2775 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
2779 /* Pass two: perform any resolution on principal operator. */
2786 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
2788 struct ada_symbol_info *candidates;
2792 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2793 (exp->elts[pc + 2].symbol),
2794 exp->elts[pc + 1].block, VAR_DOMAIN,
2797 if (n_candidates > 1)
2799 /* Types tend to get re-introduced locally, so if there
2800 are any local symbols that are not types, first filter
2803 for (j = 0; j < n_candidates; j += 1)
2804 switch (SYMBOL_CLASS (candidates[j].sym))
2809 case LOC_REGPARM_ADDR:
2817 if (j < n_candidates)
2820 while (j < n_candidates)
2822 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
2824 candidates[j] = candidates[n_candidates - 1];
2833 if (n_candidates == 0)
2834 error (_("No definition found for %s"),
2835 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2836 else if (n_candidates == 1)
2838 else if (deprocedure_p
2839 && !is_nonfunction (candidates, n_candidates))
2841 i = ada_resolve_function
2842 (candidates, n_candidates, NULL, 0,
2843 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
2846 error (_("Could not find a match for %s"),
2847 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2851 printf_filtered (_("Multiple matches for %s\n"),
2852 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2853 user_select_syms (candidates, n_candidates, 1);
2857 exp->elts[pc + 1].block = candidates[i].block;
2858 exp->elts[pc + 2].symbol = candidates[i].sym;
2859 if (innermost_block == NULL
2860 || contained_in (candidates[i].block, innermost_block))
2861 innermost_block = candidates[i].block;
2865 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
2868 replace_operator_with_call (expp, pc, 0, 0,
2869 exp->elts[pc + 2].symbol,
2870 exp->elts[pc + 1].block);
2877 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2878 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2880 struct ada_symbol_info *candidates;
2884 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2885 (exp->elts[pc + 5].symbol),
2886 exp->elts[pc + 4].block, VAR_DOMAIN,
2888 if (n_candidates == 1)
2892 i = ada_resolve_function
2893 (candidates, n_candidates,
2895 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
2898 error (_("Could not find a match for %s"),
2899 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
2902 exp->elts[pc + 4].block = candidates[i].block;
2903 exp->elts[pc + 5].symbol = candidates[i].sym;
2904 if (innermost_block == NULL
2905 || contained_in (candidates[i].block, innermost_block))
2906 innermost_block = candidates[i].block;
2917 case BINOP_BITWISE_AND:
2918 case BINOP_BITWISE_IOR:
2919 case BINOP_BITWISE_XOR:
2921 case BINOP_NOTEQUAL:
2929 case UNOP_LOGICAL_NOT:
2931 if (possible_user_operator_p (op, argvec))
2933 struct ada_symbol_info *candidates;
2937 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
2938 (struct block *) NULL, VAR_DOMAIN,
2940 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
2941 ada_decoded_op_name (op), NULL);
2945 replace_operator_with_call (expp, pc, nargs, 1,
2946 candidates[i].sym, candidates[i].block);
2957 return evaluate_subexp_type (exp, pos);
2960 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2961 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2962 a non-pointer. A type of 'void' (which is never a valid expression type)
2963 by convention matches anything. */
2964 /* The term "match" here is rather loose. The match is heuristic and
2965 liberal. FIXME: TOO liberal, in fact. */
2968 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
2970 ftype = ada_check_typedef (ftype);
2971 atype = ada_check_typedef (atype);
2973 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
2974 ftype = TYPE_TARGET_TYPE (ftype);
2975 if (TYPE_CODE (atype) == TYPE_CODE_REF)
2976 atype = TYPE_TARGET_TYPE (atype);
2978 if (TYPE_CODE (ftype) == TYPE_CODE_VOID
2979 || TYPE_CODE (atype) == TYPE_CODE_VOID)
2982 switch (TYPE_CODE (ftype))
2987 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
2988 return ada_type_match (TYPE_TARGET_TYPE (ftype),
2989 TYPE_TARGET_TYPE (atype), 0);
2992 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
2994 case TYPE_CODE_ENUM:
2995 case TYPE_CODE_RANGE:
2996 switch (TYPE_CODE (atype))
2999 case TYPE_CODE_ENUM:
3000 case TYPE_CODE_RANGE:
3006 case TYPE_CODE_ARRAY:
3007 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3008 || ada_is_array_descriptor_type (atype));
3010 case TYPE_CODE_STRUCT:
3011 if (ada_is_array_descriptor_type (ftype))
3012 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3013 || ada_is_array_descriptor_type (atype));
3015 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3016 && !ada_is_array_descriptor_type (atype));
3018 case TYPE_CODE_UNION:
3020 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3024 /* Return non-zero if the formals of FUNC "sufficiently match" the
3025 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3026 may also be an enumeral, in which case it is treated as a 0-
3027 argument function. */
3030 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3033 struct type *func_type = SYMBOL_TYPE (func);
3035 if (SYMBOL_CLASS (func) == LOC_CONST
3036 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3037 return (n_actuals == 0);
3038 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3041 if (TYPE_NFIELDS (func_type) != n_actuals)
3044 for (i = 0; i < n_actuals; i += 1)
3046 if (actuals[i] == NULL)
3050 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type, i));
3051 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3053 if (!ada_type_match (ftype, atype, 1))
3060 /* False iff function type FUNC_TYPE definitely does not produce a value
3061 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3062 FUNC_TYPE is not a valid function type with a non-null return type
3063 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3066 return_match (struct type *func_type, struct type *context_type)
3068 struct type *return_type;
3070 if (func_type == NULL)
3073 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3074 return_type = base_type (TYPE_TARGET_TYPE (func_type));
3076 return_type = base_type (func_type);
3077 if (return_type == NULL)
3080 context_type = base_type (context_type);
3082 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3083 return context_type == NULL || return_type == context_type;
3084 else if (context_type == NULL)
3085 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3087 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3091 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3092 function (if any) that matches the types of the NARGS arguments in
3093 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3094 that returns that type, then eliminate matches that don't. If
3095 CONTEXT_TYPE is void and there is at least one match that does not
3096 return void, eliminate all matches that do.
3098 Asks the user if there is more than one match remaining. Returns -1
3099 if there is no such symbol or none is selected. NAME is used
3100 solely for messages. May re-arrange and modify SYMS in
3101 the process; the index returned is for the modified vector. */
3104 ada_resolve_function (struct ada_symbol_info syms[],
3105 int nsyms, struct value **args, int nargs,
3106 const char *name, struct type *context_type)
3109 int m; /* Number of hits */
3110 struct type *fallback;
3111 struct type *return_type;
3113 return_type = context_type;
3114 if (context_type == NULL)
3115 fallback = builtin_type_void;
3122 for (k = 0; k < nsyms; k += 1)
3124 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
3126 if (ada_args_match (syms[k].sym, args, nargs)
3127 && return_match (type, return_type))
3133 if (m > 0 || return_type == fallback)
3136 return_type = fallback;
3143 printf_filtered (_("Multiple matches for %s\n"), name);
3144 user_select_syms (syms, m, 1);
3150 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3151 in a listing of choices during disambiguation (see sort_choices, below).
3152 The idea is that overloadings of a subprogram name from the
3153 same package should sort in their source order. We settle for ordering
3154 such symbols by their trailing number (__N or $N). */
3157 encoded_ordered_before (char *N0, char *N1)
3161 else if (N0 == NULL)
3166 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3168 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3170 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3171 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3175 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3178 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3180 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3181 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3183 return (strcmp (N0, N1) < 0);
3187 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3191 sort_choices (struct ada_symbol_info syms[], int nsyms)
3194 for (i = 1; i < nsyms; i += 1)
3196 struct ada_symbol_info sym = syms[i];
3199 for (j = i - 1; j >= 0; j -= 1)
3201 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3202 SYMBOL_LINKAGE_NAME (sym.sym)))
3204 syms[j + 1] = syms[j];
3210 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3211 by asking the user (if necessary), returning the number selected,
3212 and setting the first elements of SYMS items. Error if no symbols
3215 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3216 to be re-integrated one of these days. */
3219 user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
3222 int *chosen = (int *) alloca (sizeof (int) * nsyms);
3224 int first_choice = (max_results == 1) ? 1 : 2;
3225 const char *select_mode = multiple_symbols_select_mode ();
3227 if (max_results < 1)
3228 error (_("Request to select 0 symbols!"));
3232 if (select_mode == multiple_symbols_cancel)
3234 canceled because the command is ambiguous\n\
3235 See set/show multiple-symbol."));
3237 /* If select_mode is "all", then return all possible symbols.
3238 Only do that if more than one symbol can be selected, of course.
3239 Otherwise, display the menu as usual. */
3240 if (select_mode == multiple_symbols_all && max_results > 1)
3243 printf_unfiltered (_("[0] cancel\n"));
3244 if (max_results > 1)
3245 printf_unfiltered (_("[1] all\n"));
3247 sort_choices (syms, nsyms);
3249 for (i = 0; i < nsyms; i += 1)
3251 if (syms[i].sym == NULL)
3254 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3256 struct symtab_and_line sal =
3257 find_function_start_sal (syms[i].sym, 1);
3258 if (sal.symtab == NULL)
3259 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3261 SYMBOL_PRINT_NAME (syms[i].sym),
3264 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3265 SYMBOL_PRINT_NAME (syms[i].sym),
3266 sal.symtab->filename, sal.line);
3272 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3273 && SYMBOL_TYPE (syms[i].sym) != NULL
3274 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
3275 struct symtab *symtab = symtab_for_sym (syms[i].sym);
3277 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
3278 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3280 SYMBOL_PRINT_NAME (syms[i].sym),
3281 symtab->filename, SYMBOL_LINE (syms[i].sym));
3282 else if (is_enumeral
3283 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
3285 printf_unfiltered (("[%d] "), i + first_choice);
3286 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
3288 printf_unfiltered (_("'(%s) (enumeral)\n"),
3289 SYMBOL_PRINT_NAME (syms[i].sym));
3291 else if (symtab != NULL)
3292 printf_unfiltered (is_enumeral
3293 ? _("[%d] %s in %s (enumeral)\n")
3294 : _("[%d] %s at %s:?\n"),
3296 SYMBOL_PRINT_NAME (syms[i].sym),
3299 printf_unfiltered (is_enumeral
3300 ? _("[%d] %s (enumeral)\n")
3301 : _("[%d] %s at ?\n"),
3303 SYMBOL_PRINT_NAME (syms[i].sym));
3307 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3310 for (i = 0; i < n_chosen; i += 1)
3311 syms[i] = syms[chosen[i]];
3316 /* Read and validate a set of numeric choices from the user in the
3317 range 0 .. N_CHOICES-1. Place the results in increasing
3318 order in CHOICES[0 .. N-1], and return N.
3320 The user types choices as a sequence of numbers on one line
3321 separated by blanks, encoding them as follows:
3323 + A choice of 0 means to cancel the selection, throwing an error.
3324 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3325 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3327 The user is not allowed to choose more than MAX_RESULTS values.
3329 ANNOTATION_SUFFIX, if present, is used to annotate the input
3330 prompts (for use with the -f switch). */
3333 get_selections (int *choices, int n_choices, int max_results,
3334 int is_all_choice, char *annotation_suffix)
3339 int first_choice = is_all_choice ? 2 : 1;
3341 prompt = getenv ("PS2");
3345 args = command_line_input (prompt, 0, annotation_suffix);
3348 error_no_arg (_("one or more choice numbers"));
3352 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3353 order, as given in args. Choices are validated. */
3359 while (isspace (*args))
3361 if (*args == '\0' && n_chosen == 0)
3362 error_no_arg (_("one or more choice numbers"));
3363 else if (*args == '\0')
3366 choice = strtol (args, &args2, 10);
3367 if (args == args2 || choice < 0
3368 || choice > n_choices + first_choice - 1)
3369 error (_("Argument must be choice number"));
3373 error (_("cancelled"));
3375 if (choice < first_choice)
3377 n_chosen = n_choices;
3378 for (j = 0; j < n_choices; j += 1)
3382 choice -= first_choice;
3384 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3388 if (j < 0 || choice != choices[j])
3391 for (k = n_chosen - 1; k > j; k -= 1)
3392 choices[k + 1] = choices[k];
3393 choices[j + 1] = choice;
3398 if (n_chosen > max_results)
3399 error (_("Select no more than %d of the above"), max_results);
3404 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3405 on the function identified by SYM and BLOCK, and taking NARGS
3406 arguments. Update *EXPP as needed to hold more space. */
3409 replace_operator_with_call (struct expression **expp, int pc, int nargs,
3410 int oplen, struct symbol *sym,
3411 struct block *block)
3413 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3414 symbol, -oplen for operator being replaced). */
3415 struct expression *newexp = (struct expression *)
3416 xmalloc (sizeof (struct expression)
3417 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
3418 struct expression *exp = *expp;
3420 newexp->nelts = exp->nelts + 7 - oplen;
3421 newexp->language_defn = exp->language_defn;
3422 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
3423 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
3424 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
3426 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3427 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3429 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3430 newexp->elts[pc + 4].block = block;
3431 newexp->elts[pc + 5].symbol = sym;
3437 /* Type-class predicates */
3439 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3443 numeric_type_p (struct type *type)
3449 switch (TYPE_CODE (type))
3454 case TYPE_CODE_RANGE:
3455 return (type == TYPE_TARGET_TYPE (type)
3456 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3463 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3466 integer_type_p (struct type *type)
3472 switch (TYPE_CODE (type))
3476 case TYPE_CODE_RANGE:
3477 return (type == TYPE_TARGET_TYPE (type)
3478 || integer_type_p (TYPE_TARGET_TYPE (type)));
3485 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3488 scalar_type_p (struct type *type)
3494 switch (TYPE_CODE (type))
3497 case TYPE_CODE_RANGE:
3498 case TYPE_CODE_ENUM:
3507 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3510 discrete_type_p (struct type *type)
3516 switch (TYPE_CODE (type))
3519 case TYPE_CODE_RANGE:
3520 case TYPE_CODE_ENUM:
3528 /* Returns non-zero if OP with operands in the vector ARGS could be
3529 a user-defined function. Errs on the side of pre-defined operators
3530 (i.e., result 0). */
3533 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3535 struct type *type0 =
3536 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3537 struct type *type1 =
3538 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3552 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3556 case BINOP_BITWISE_AND:
3557 case BINOP_BITWISE_IOR:
3558 case BINOP_BITWISE_XOR:
3559 return (!(integer_type_p (type0) && integer_type_p (type1)));
3562 case BINOP_NOTEQUAL:
3567 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3570 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
3573 return (!(numeric_type_p (type0) && integer_type_p (type1)));
3577 case UNOP_LOGICAL_NOT:
3579 return (!numeric_type_p (type0));
3588 1. In the following, we assume that a renaming type's name may
3589 have an ___XD suffix. It would be nice if this went away at some
3591 2. We handle both the (old) purely type-based representation of
3592 renamings and the (new) variable-based encoding. At some point,
3593 it is devoutly to be hoped that the former goes away
3594 (FIXME: hilfinger-2007-07-09).
3595 3. Subprogram renamings are not implemented, although the XRS
3596 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3598 /* If SYM encodes a renaming,
3600 <renaming> renames <renamed entity>,
3602 sets *LEN to the length of the renamed entity's name,
3603 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3604 the string describing the subcomponent selected from the renamed
3605 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3606 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3607 are undefined). Otherwise, returns a value indicating the category
3608 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3609 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3610 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3611 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3612 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3613 may be NULL, in which case they are not assigned.
3615 [Currently, however, GCC does not generate subprogram renamings.] */
3617 enum ada_renaming_category
3618 ada_parse_renaming (struct symbol *sym,
3619 const char **renamed_entity, int *len,
3620 const char **renaming_expr)
3622 enum ada_renaming_category kind;
3627 return ADA_NOT_RENAMING;
3628 switch (SYMBOL_CLASS (sym))
3631 return ADA_NOT_RENAMING;
3633 return parse_old_style_renaming (SYMBOL_TYPE (sym),
3634 renamed_entity, len, renaming_expr);
3638 case LOC_OPTIMIZED_OUT:
3639 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
3641 return ADA_NOT_RENAMING;
3645 kind = ADA_OBJECT_RENAMING;
3649 kind = ADA_EXCEPTION_RENAMING;
3653 kind = ADA_PACKAGE_RENAMING;
3657 kind = ADA_SUBPROGRAM_RENAMING;
3661 return ADA_NOT_RENAMING;
3665 if (renamed_entity != NULL)
3666 *renamed_entity = info;
3667 suffix = strstr (info, "___XE");
3668 if (suffix == NULL || suffix == info)
3669 return ADA_NOT_RENAMING;
3671 *len = strlen (info) - strlen (suffix);
3673 if (renaming_expr != NULL)
3674 *renaming_expr = suffix;
3678 /* Assuming TYPE encodes a renaming according to the old encoding in
3679 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3680 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3681 ADA_NOT_RENAMING otherwise. */
3682 static enum ada_renaming_category
3683 parse_old_style_renaming (struct type *type,
3684 const char **renamed_entity, int *len,
3685 const char **renaming_expr)
3687 enum ada_renaming_category kind;
3692 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
3693 || TYPE_NFIELDS (type) != 1)
3694 return ADA_NOT_RENAMING;
3696 name = type_name_no_tag (type);
3698 return ADA_NOT_RENAMING;
3700 name = strstr (name, "___XR");
3702 return ADA_NOT_RENAMING;
3707 kind = ADA_OBJECT_RENAMING;
3710 kind = ADA_EXCEPTION_RENAMING;
3713 kind = ADA_PACKAGE_RENAMING;
3716 kind = ADA_SUBPROGRAM_RENAMING;
3719 return ADA_NOT_RENAMING;
3722 info = TYPE_FIELD_NAME (type, 0);
3724 return ADA_NOT_RENAMING;
3725 if (renamed_entity != NULL)
3726 *renamed_entity = info;
3727 suffix = strstr (info, "___XE");
3728 if (renaming_expr != NULL)
3729 *renaming_expr = suffix + 5;
3730 if (suffix == NULL || suffix == info)
3731 return ADA_NOT_RENAMING;
3733 *len = suffix - info;
3739 /* Evaluation: Function Calls */
3741 /* Return an lvalue containing the value VAL. This is the identity on
3742 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3743 on the stack, using and updating *SP as the stack pointer, and
3744 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3746 static struct value *
3747 ensure_lval (struct value *val, CORE_ADDR *sp)
3749 if (! VALUE_LVAL (val))
3751 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
3753 /* The following is taken from the structure-return code in
3754 call_function_by_hand. FIXME: Therefore, some refactoring seems
3756 if (gdbarch_inner_than (current_gdbarch, 1, 2))
3758 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3759 reserving sufficient space. */
3761 if (gdbarch_frame_align_p (current_gdbarch))
3762 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3763 VALUE_ADDRESS (val) = *sp;
3767 /* Stack grows upward. Align the frame, allocate space, and
3768 then again, re-align the frame. */
3769 if (gdbarch_frame_align_p (current_gdbarch))
3770 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3771 VALUE_ADDRESS (val) = *sp;
3773 if (gdbarch_frame_align_p (current_gdbarch))
3774 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3776 VALUE_LVAL (val) = lval_memory;
3778 write_memory (VALUE_ADDRESS (val), value_contents_raw (val), len);
3784 /* Return the value ACTUAL, converted to be an appropriate value for a
3785 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3786 allocating any necessary descriptors (fat pointers), or copies of
3787 values not residing in memory, updating it as needed. */
3790 ada_convert_actual (struct value *actual, struct type *formal_type0,
3793 struct type *actual_type = ada_check_typedef (value_type (actual));
3794 struct type *formal_type = ada_check_typedef (formal_type0);
3795 struct type *formal_target =
3796 TYPE_CODE (formal_type) == TYPE_CODE_PTR
3797 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
3798 struct type *actual_target =
3799 TYPE_CODE (actual_type) == TYPE_CODE_PTR
3800 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
3802 if (ada_is_array_descriptor_type (formal_target)
3803 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
3804 return make_array_descriptor (formal_type, actual, sp);
3805 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
3806 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
3808 struct value *result;
3809 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
3810 && ada_is_array_descriptor_type (actual_target))
3811 result = desc_data (actual);
3812 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
3814 if (VALUE_LVAL (actual) != lval_memory)
3817 actual_type = ada_check_typedef (value_type (actual));
3818 val = allocate_value (actual_type);
3819 memcpy ((char *) value_contents_raw (val),
3820 (char *) value_contents (actual),
3821 TYPE_LENGTH (actual_type));
3822 actual = ensure_lval (val, sp);
3824 result = value_addr (actual);
3828 return value_cast_pointers (formal_type, result);
3830 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
3831 return ada_value_ind (actual);
3837 /* Push a descriptor of type TYPE for array value ARR on the stack at
3838 *SP, updating *SP to reflect the new descriptor. Return either
3839 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3840 to-descriptor type rather than a descriptor type), a struct value *
3841 representing a pointer to this descriptor. */
3843 static struct value *
3844 make_array_descriptor (struct type *type, struct value *arr, CORE_ADDR *sp)
3846 struct type *bounds_type = desc_bounds_type (type);
3847 struct type *desc_type = desc_base_type (type);
3848 struct value *descriptor = allocate_value (desc_type);
3849 struct value *bounds = allocate_value (bounds_type);
3852 for (i = ada_array_arity (ada_check_typedef (value_type (arr))); i > 0; i -= 1)
3854 modify_general_field (value_contents_writeable (bounds),
3855 value_as_long (ada_array_bound (arr, i, 0)),
3856 desc_bound_bitpos (bounds_type, i, 0),
3857 desc_bound_bitsize (bounds_type, i, 0));
3858 modify_general_field (value_contents_writeable (bounds),
3859 value_as_long (ada_array_bound (arr, i, 1)),
3860 desc_bound_bitpos (bounds_type, i, 1),
3861 desc_bound_bitsize (bounds_type, i, 1));
3864 bounds = ensure_lval (bounds, sp);
3866 modify_general_field (value_contents_writeable (descriptor),
3867 VALUE_ADDRESS (ensure_lval (arr, sp)),
3868 fat_pntr_data_bitpos (desc_type),
3869 fat_pntr_data_bitsize (desc_type));
3871 modify_general_field (value_contents_writeable (descriptor),
3872 VALUE_ADDRESS (bounds),
3873 fat_pntr_bounds_bitpos (desc_type),
3874 fat_pntr_bounds_bitsize (desc_type));
3876 descriptor = ensure_lval (descriptor, sp);
3878 if (TYPE_CODE (type) == TYPE_CODE_PTR)
3879 return value_addr (descriptor);
3884 /* Dummy definitions for an experimental caching module that is not
3885 * used in the public sources. */
3888 lookup_cached_symbol (const char *name, domain_enum namespace,
3889 struct symbol **sym, struct block **block)
3895 cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
3896 struct block *block)
3902 /* Return the result of a standard (literal, C-like) lookup of NAME in
3903 given DOMAIN, visible from lexical block BLOCK. */
3905 static struct symbol *
3906 standard_lookup (const char *name, const struct block *block,
3911 if (lookup_cached_symbol (name, domain, &sym, NULL))
3913 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
3914 cache_symbol (name, domain, sym, block_found);
3919 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3920 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3921 since they contend in overloading in the same way. */
3923 is_nonfunction (struct ada_symbol_info syms[], int n)
3927 for (i = 0; i < n; i += 1)
3928 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
3929 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
3930 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
3936 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3937 struct types. Otherwise, they may not. */
3940 equiv_types (struct type *type0, struct type *type1)
3944 if (type0 == NULL || type1 == NULL
3945 || TYPE_CODE (type0) != TYPE_CODE (type1))
3947 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
3948 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
3949 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
3950 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
3956 /* True iff SYM0 represents the same entity as SYM1, or one that is
3957 no more defined than that of SYM1. */
3960 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
3964 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
3965 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
3968 switch (SYMBOL_CLASS (sym0))
3974 struct type *type0 = SYMBOL_TYPE (sym0);
3975 struct type *type1 = SYMBOL_TYPE (sym1);
3976 char *name0 = SYMBOL_LINKAGE_NAME (sym0);
3977 char *name1 = SYMBOL_LINKAGE_NAME (sym1);
3978 int len0 = strlen (name0);
3980 TYPE_CODE (type0) == TYPE_CODE (type1)
3981 && (equiv_types (type0, type1)
3982 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
3983 && strncmp (name1 + len0, "___XV", 5) == 0));
3986 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
3987 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
3993 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3994 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3997 add_defn_to_vec (struct obstack *obstackp,
3999 struct block *block)
4003 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
4005 /* Do not try to complete stub types, as the debugger is probably
4006 already scanning all symbols matching a certain name at the
4007 time when this function is called. Trying to replace the stub
4008 type by its associated full type will cause us to restart a scan
4009 which may lead to an infinite recursion. Instead, the client
4010 collecting the matching symbols will end up collecting several
4011 matches, with at least one of them complete. It can then filter
4012 out the stub ones if needed. */
4014 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4016 if (lesseq_defined_than (sym, prevDefns[i].sym))
4018 else if (lesseq_defined_than (prevDefns[i].sym, sym))
4020 prevDefns[i].sym = sym;
4021 prevDefns[i].block = block;
4027 struct ada_symbol_info info;
4031 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4035 /* Number of ada_symbol_info structures currently collected in
4036 current vector in *OBSTACKP. */
4039 num_defns_collected (struct obstack *obstackp)
4041 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4044 /* Vector of ada_symbol_info structures currently collected in current
4045 vector in *OBSTACKP. If FINISH, close off the vector and return
4046 its final address. */
4048 static struct ada_symbol_info *
4049 defns_collected (struct obstack *obstackp, int finish)
4052 return obstack_finish (obstackp);
4054 return (struct ada_symbol_info *) obstack_base (obstackp);
4057 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
4058 Check the global symbols if GLOBAL, the static symbols if not.
4059 Do wild-card match if WILD. */
4061 static struct partial_symbol *
4062 ada_lookup_partial_symbol (struct partial_symtab *pst, const char *name,
4063 int global, domain_enum namespace, int wild)
4065 struct partial_symbol **start;
4066 int name_len = strlen (name);
4067 int length = (global ? pst->n_global_syms : pst->n_static_syms);
4076 pst->objfile->global_psymbols.list + pst->globals_offset :
4077 pst->objfile->static_psymbols.list + pst->statics_offset);
4081 for (i = 0; i < length; i += 1)
4083 struct partial_symbol *psym = start[i];
4085 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
4086 SYMBOL_DOMAIN (psym), namespace)
4087 && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (psym)))
4101 int M = (U + i) >> 1;
4102 struct partial_symbol *psym = start[M];
4103 if (SYMBOL_LINKAGE_NAME (psym)[0] < name[0])
4105 else if (SYMBOL_LINKAGE_NAME (psym)[0] > name[0])
4107 else if (strcmp (SYMBOL_LINKAGE_NAME (psym), name) < 0)
4118 struct partial_symbol *psym = start[i];
4120 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
4121 SYMBOL_DOMAIN (psym), namespace))
4123 int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym), name_len);
4131 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)
4145 int M = (U + i) >> 1;
4146 struct partial_symbol *psym = start[M];
4147 if (SYMBOL_LINKAGE_NAME (psym)[0] < '_')
4149 else if (SYMBOL_LINKAGE_NAME (psym)[0] > '_')
4151 else if (strcmp (SYMBOL_LINKAGE_NAME (psym), "_ada_") < 0)
4162 struct partial_symbol *psym = start[i];
4164 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
4165 SYMBOL_DOMAIN (psym), namespace))
4169 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym)[0];
4172 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym), 5);
4174 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym) + 5,
4184 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)
4194 /* Find a symbol table containing symbol SYM or NULL if none. */
4196 static struct symtab *
4197 symtab_for_sym (struct symbol *sym)
4200 struct objfile *objfile;
4202 struct symbol *tmp_sym;
4203 struct dict_iterator iter;
4206 ALL_PRIMARY_SYMTABS (objfile, s)
4208 switch (SYMBOL_CLASS (sym))
4216 case LOC_CONST_BYTES:
4217 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
4218 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4220 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
4221 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4227 switch (SYMBOL_CLASS (sym))
4232 case LOC_REGPARM_ADDR:
4236 for (j = FIRST_LOCAL_BLOCK;
4237 j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s)); j += 1)
4239 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), j);
4240 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4251 /* Return a minimal symbol matching NAME according to Ada decoding
4252 rules. Returns NULL if there is no such minimal symbol. Names
4253 prefixed with "standard__" are handled specially: "standard__" is
4254 first stripped off, and only static and global symbols are searched. */
4256 struct minimal_symbol *
4257 ada_lookup_simple_minsym (const char *name)
4259 struct objfile *objfile;
4260 struct minimal_symbol *msymbol;
4263 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
4265 name += sizeof ("standard__") - 1;
4269 wild_match = (strstr (name, "__") == NULL);
4271 ALL_MSYMBOLS (objfile, msymbol)
4273 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match)
4274 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4281 /* For all subprograms that statically enclose the subprogram of the
4282 selected frame, add symbols matching identifier NAME in DOMAIN
4283 and their blocks to the list of data in OBSTACKP, as for
4284 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4288 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4289 const char *name, domain_enum namespace,
4294 /* True if TYPE is definitely an artificial type supplied to a symbol
4295 for which no debugging information was given in the symbol file. */
4298 is_nondebugging_type (struct type *type)
4300 char *name = ada_type_name (type);
4301 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4304 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4305 duplicate other symbols in the list (The only case I know of where
4306 this happens is when object files containing stabs-in-ecoff are
4307 linked with files containing ordinary ecoff debugging symbols (or no
4308 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4309 Returns the number of items in the modified list. */
4312 remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4321 /* If two symbols have the same name and one of them is a stub type,
4322 the get rid of the stub. */
4324 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4325 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4327 for (j = 0; j < nsyms; j++)
4330 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4331 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4332 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4333 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
4338 /* Two symbols with the same name, same class and same address
4339 should be identical. */
4341 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
4342 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4343 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4345 for (j = 0; j < nsyms; j += 1)
4348 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4349 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4350 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
4351 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4352 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4353 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
4360 for (j = i + 1; j < nsyms; j += 1)
4361 syms[j - 1] = syms[j];
4370 /* Given a type that corresponds to a renaming entity, use the type name
4371 to extract the scope (package name or function name, fully qualified,
4372 and following the GNAT encoding convention) where this renaming has been
4373 defined. The string returned needs to be deallocated after use. */
4376 xget_renaming_scope (struct type *renaming_type)
4378 /* The renaming types adhere to the following convention:
4379 <scope>__<rename>___<XR extension>.
4380 So, to extract the scope, we search for the "___XR" extension,
4381 and then backtrack until we find the first "__". */
4383 const char *name = type_name_no_tag (renaming_type);
4384 char *suffix = strstr (name, "___XR");
4389 /* Now, backtrack a bit until we find the first "__". Start looking
4390 at suffix - 3, as the <rename> part is at least one character long. */
4392 for (last = suffix - 3; last > name; last--)
4393 if (last[0] == '_' && last[1] == '_')
4396 /* Make a copy of scope and return it. */
4398 scope_len = last - name;
4399 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
4401 strncpy (scope, name, scope_len);
4402 scope[scope_len] = '\0';
4407 /* Return nonzero if NAME corresponds to a package name. */
4410 is_package_name (const char *name)
4412 /* Here, We take advantage of the fact that no symbols are generated
4413 for packages, while symbols are generated for each function.
4414 So the condition for NAME represent a package becomes equivalent
4415 to NAME not existing in our list of symbols. There is only one
4416 small complication with library-level functions (see below). */
4420 /* If it is a function that has not been defined at library level,
4421 then we should be able to look it up in the symbols. */
4422 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4425 /* Library-level function names start with "_ada_". See if function
4426 "_ada_" followed by NAME can be found. */
4428 /* Do a quick check that NAME does not contain "__", since library-level
4429 functions names cannot contain "__" in them. */
4430 if (strstr (name, "__") != NULL)
4433 fun_name = xstrprintf ("_ada_%s", name);
4435 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4438 /* Return nonzero if SYM corresponds to a renaming entity that is
4439 not visible from FUNCTION_NAME. */
4442 old_renaming_is_invisible (const struct symbol *sym, char *function_name)
4446 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4449 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
4451 make_cleanup (xfree, scope);
4453 /* If the rename has been defined in a package, then it is visible. */
4454 if (is_package_name (scope))
4457 /* Check that the rename is in the current function scope by checking
4458 that its name starts with SCOPE. */
4460 /* If the function name starts with "_ada_", it means that it is
4461 a library-level function. Strip this prefix before doing the
4462 comparison, as the encoding for the renaming does not contain
4464 if (strncmp (function_name, "_ada_", 5) == 0)
4467 return (strncmp (function_name, scope, strlen (scope)) != 0);
4470 /* Remove entries from SYMS that corresponds to a renaming entity that
4471 is not visible from the function associated with CURRENT_BLOCK or
4472 that is superfluous due to the presence of more specific renaming
4473 information. Places surviving symbols in the initial entries of
4474 SYMS and returns the number of surviving symbols.
4477 First, in cases where an object renaming is implemented as a
4478 reference variable, GNAT may produce both the actual reference
4479 variable and the renaming encoding. In this case, we discard the
4482 Second, GNAT emits a type following a specified encoding for each renaming
4483 entity. Unfortunately, STABS currently does not support the definition
4484 of types that are local to a given lexical block, so all renamings types
4485 are emitted at library level. As a consequence, if an application
4486 contains two renaming entities using the same name, and a user tries to
4487 print the value of one of these entities, the result of the ada symbol
4488 lookup will also contain the wrong renaming type.
4490 This function partially covers for this limitation by attempting to
4491 remove from the SYMS list renaming symbols that should be visible
4492 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4493 method with the current information available. The implementation
4494 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4496 - When the user tries to print a rename in a function while there
4497 is another rename entity defined in a package: Normally, the
4498 rename in the function has precedence over the rename in the
4499 package, so the latter should be removed from the list. This is
4500 currently not the case.
4502 - This function will incorrectly remove valid renames if
4503 the CURRENT_BLOCK corresponds to a function which symbol name
4504 has been changed by an "Export" pragma. As a consequence,
4505 the user will be unable to print such rename entities. */
4508 remove_irrelevant_renamings (struct ada_symbol_info *syms,
4509 int nsyms, const struct block *current_block)
4511 struct symbol *current_function;
4512 char *current_function_name;
4514 int is_new_style_renaming;
4516 /* If there is both a renaming foo___XR... encoded as a variable and
4517 a simple variable foo in the same block, discard the latter.
4518 First, zero out such symbols, then compress. */
4519 is_new_style_renaming = 0;
4520 for (i = 0; i < nsyms; i += 1)
4522 struct symbol *sym = syms[i].sym;
4523 struct block *block = syms[i].block;
4527 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4529 name = SYMBOL_LINKAGE_NAME (sym);
4530 suffix = strstr (name, "___XR");
4534 int name_len = suffix - name;
4536 is_new_style_renaming = 1;
4537 for (j = 0; j < nsyms; j += 1)
4538 if (i != j && syms[j].sym != NULL
4539 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
4541 && block == syms[j].block)
4545 if (is_new_style_renaming)
4549 for (j = k = 0; j < nsyms; j += 1)
4550 if (syms[j].sym != NULL)
4558 /* Extract the function name associated to CURRENT_BLOCK.
4559 Abort if unable to do so. */
4561 if (current_block == NULL)
4564 current_function = block_linkage_function (current_block);
4565 if (current_function == NULL)
4568 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4569 if (current_function_name == NULL)
4572 /* Check each of the symbols, and remove it from the list if it is
4573 a type corresponding to a renaming that is out of the scope of
4574 the current block. */
4579 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
4580 == ADA_OBJECT_RENAMING
4581 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4584 for (j = i + 1; j < nsyms; j += 1)
4585 syms[j - 1] = syms[j];
4595 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4596 whose name and domain match NAME and DOMAIN respectively.
4597 If no match was found, then extend the search to "enclosing"
4598 routines (in other words, if we're inside a nested function,
4599 search the symbols defined inside the enclosing functions).
4601 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4604 ada_add_local_symbols (struct obstack *obstackp, const char *name,
4605 struct block *block, domain_enum domain,
4608 int block_depth = 0;
4610 while (block != NULL)
4613 ada_add_block_symbols (obstackp, block, name, domain, NULL, wild_match);
4615 /* If we found a non-function match, assume that's the one. */
4616 if (is_nonfunction (defns_collected (obstackp, 0),
4617 num_defns_collected (obstackp)))
4620 block = BLOCK_SUPERBLOCK (block);
4623 /* If no luck so far, try to find NAME as a local symbol in some lexically
4624 enclosing subprogram. */
4625 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
4626 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match);
4629 /* Add to OBSTACKP all non-local symbols whose name and domain match
4630 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
4631 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
4634 ada_add_non_local_symbols (struct obstack *obstackp, const char *name,
4635 domain_enum domain, int global,
4638 struct objfile *objfile;
4639 struct partial_symtab *ps;
4641 ALL_PSYMTABS (objfile, ps)
4645 || ada_lookup_partial_symbol (ps, name, global, domain, wild_match))
4647 struct symtab *s = PSYMTAB_TO_SYMTAB (ps);
4648 const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
4650 if (s == NULL || !s->primary)
4652 ada_add_block_symbols (obstackp,
4653 BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), block_kind),
4654 name, domain, objfile, wild_match);
4659 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4660 scope and in global scopes, returning the number of matches. Sets
4661 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4662 indicating the symbols found and the blocks and symbol tables (if
4663 any) in which they were found. This vector are transient---good only to
4664 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4665 symbol match within the nest of blocks whose innermost member is BLOCK0,
4666 is the one match returned (no other matches in that or
4667 enclosing blocks is returned). If there are any matches in or
4668 surrounding BLOCK0, then these alone are returned. Otherwise, the
4669 search extends to global and file-scope (static) symbol tables.
4670 Names prefixed with "standard__" are handled specially: "standard__"
4671 is first stripped off, and only static and global symbols are searched. */
4674 ada_lookup_symbol_list (const char *name0, const struct block *block0,
4675 domain_enum namespace,
4676 struct ada_symbol_info **results)
4679 struct block *block;
4685 obstack_free (&symbol_list_obstack, NULL);
4686 obstack_init (&symbol_list_obstack);
4690 /* Search specified block and its superiors. */
4692 wild_match = (strstr (name0, "__") == NULL);
4694 block = (struct block *) block0; /* FIXME: No cast ought to be
4695 needed, but adding const will
4696 have a cascade effect. */
4698 /* Special case: If the user specifies a symbol name inside package
4699 Standard, do a non-wild matching of the symbol name without
4700 the "standard__" prefix. This was primarily introduced in order
4701 to allow the user to specifically access the standard exceptions
4702 using, for instance, Standard.Constraint_Error when Constraint_Error
4703 is ambiguous (due to the user defining its own Constraint_Error
4704 entity inside its program). */
4705 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
4709 name = name0 + sizeof ("standard__") - 1;
4712 /* Check the non-global symbols. If we have ANY match, then we're done. */
4714 ada_add_local_symbols (&symbol_list_obstack, name, block, namespace,
4716 if (num_defns_collected (&symbol_list_obstack) > 0)
4719 /* No non-global symbols found. Check our cache to see if we have
4720 already performed this search before. If we have, then return
4724 if (lookup_cached_symbol (name0, namespace, &sym, &block))
4727 add_defn_to_vec (&symbol_list_obstack, sym, block);
4731 /* Search symbols from all global blocks. */
4733 ada_add_non_local_symbols (&symbol_list_obstack, name, namespace, 1,
4736 /* Now add symbols from all per-file blocks if we've gotten no hits
4737 (not strictly correct, but perhaps better than an error). */
4739 if (num_defns_collected (&symbol_list_obstack) == 0)
4740 ada_add_non_local_symbols (&symbol_list_obstack, name, namespace, 0,
4744 ndefns = num_defns_collected (&symbol_list_obstack);
4745 *results = defns_collected (&symbol_list_obstack, 1);
4747 ndefns = remove_extra_symbols (*results, ndefns);
4750 cache_symbol (name0, namespace, NULL, NULL);
4752 if (ndefns == 1 && cacheIfUnique)
4753 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
4755 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
4761 ada_lookup_encoded_symbol (const char *name, const struct block *block0,
4762 domain_enum namespace, struct block **block_found)
4764 struct ada_symbol_info *candidates;
4767 n_candidates = ada_lookup_symbol_list (name, block0, namespace, &candidates);
4769 if (n_candidates == 0)
4772 if (block_found != NULL)
4773 *block_found = candidates[0].block;
4775 return fixup_symbol_section (candidates[0].sym, NULL);
4778 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4779 scope and in global scopes, or NULL if none. NAME is folded and
4780 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4781 choosing the first symbol if there are multiple choices.
4782 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4783 table in which the symbol was found (in both cases, these
4784 assignments occur only if the pointers are non-null). */
4786 ada_lookup_symbol (const char *name, const struct block *block0,
4787 domain_enum namespace, int *is_a_field_of_this)
4789 if (is_a_field_of_this != NULL)
4790 *is_a_field_of_this = 0;
4793 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
4794 block0, namespace, NULL);
4797 static struct symbol *
4798 ada_lookup_symbol_nonlocal (const char *name,
4799 const char *linkage_name,
4800 const struct block *block,
4801 const domain_enum domain)
4803 if (linkage_name == NULL)
4804 linkage_name = name;
4805 return ada_lookup_symbol (linkage_name, block_static_block (block), domain,
4810 /* True iff STR is a possible encoded suffix of a normal Ada name
4811 that is to be ignored for matching purposes. Suffixes of parallel
4812 names (e.g., XVE) are not included here. Currently, the possible suffixes
4813 are given by any of the regular expressions:
4815 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
4816 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4817 _E[0-9]+[bs]$ [protected object entry suffixes]
4818 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4820 Also, any leading "__[0-9]+" sequence is skipped before the suffix
4821 match is performed. This sequence is used to differentiate homonyms,
4822 is an optional part of a valid name suffix. */
4825 is_name_suffix (const char *str)
4828 const char *matching;
4829 const int len = strlen (str);
4831 /* Skip optional leading __[0-9]+. */
4833 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
4836 while (isdigit (str[0]))
4842 if (str[0] == '.' || str[0] == '$')
4845 while (isdigit (matching[0]))
4847 if (matching[0] == '\0')
4853 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
4856 while (isdigit (matching[0]))
4858 if (matching[0] == '\0')
4863 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4864 with a N at the end. Unfortunately, the compiler uses the same
4865 convention for other internal types it creates. So treating
4866 all entity names that end with an "N" as a name suffix causes
4867 some regressions. For instance, consider the case of an enumerated
4868 type. To support the 'Image attribute, it creates an array whose
4870 Having a single character like this as a suffix carrying some
4871 information is a bit risky. Perhaps we should change the encoding
4872 to be something like "_N" instead. In the meantime, do not do
4873 the following check. */
4874 /* Protected Object Subprograms */
4875 if (len == 1 && str [0] == 'N')
4880 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
4883 while (isdigit (matching[0]))
4885 if ((matching[0] == 'b' || matching[0] == 's')
4886 && matching [1] == '\0')
4890 /* ??? We should not modify STR directly, as we are doing below. This
4891 is fine in this case, but may become problematic later if we find
4892 that this alternative did not work, and want to try matching
4893 another one from the begining of STR. Since we modified it, we
4894 won't be able to find the begining of the string anymore! */
4898 while (str[0] != '_' && str[0] != '\0')
4900 if (str[0] != 'n' && str[0] != 'b')
4906 if (str[0] == '\000')
4911 if (str[1] != '_' || str[2] == '\000')
4915 if (strcmp (str + 3, "JM") == 0)
4917 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4918 the LJM suffix in favor of the JM one. But we will
4919 still accept LJM as a valid suffix for a reasonable
4920 amount of time, just to allow ourselves to debug programs
4921 compiled using an older version of GNAT. */
4922 if (strcmp (str + 3, "LJM") == 0)
4926 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
4927 || str[4] == 'U' || str[4] == 'P')
4929 if (str[4] == 'R' && str[5] != 'T')
4933 if (!isdigit (str[2]))
4935 for (k = 3; str[k] != '\0'; k += 1)
4936 if (!isdigit (str[k]) && str[k] != '_')
4940 if (str[0] == '$' && isdigit (str[1]))
4942 for (k = 2; str[k] != '\0'; k += 1)
4943 if (!isdigit (str[k]) && str[k] != '_')
4950 /* Return non-zero if the string starting at NAME and ending before
4951 NAME_END contains no capital letters. */
4954 is_valid_name_for_wild_match (const char *name0)
4956 const char *decoded_name = ada_decode (name0);
4959 /* If the decoded name starts with an angle bracket, it means that
4960 NAME0 does not follow the GNAT encoding format. It should then
4961 not be allowed as a possible wild match. */
4962 if (decoded_name[0] == '<')
4965 for (i=0; decoded_name[i] != '\0'; i++)
4966 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
4972 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4973 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4974 informational suffixes of NAME (i.e., for which is_name_suffix is
4978 wild_match (const char *patn0, int patn_len, const char *name0)
4985 match = strstr (start, patn0);
4990 || (match > name0 + 1 && match[-1] == '_' && match[-2] == '_')
4991 || (match == name0 + 5 && strncmp ("_ada_", name0, 5) == 0))
4992 && is_name_suffix (match + patn_len))
4993 return (match == name0 || is_valid_name_for_wild_match (name0));
4999 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5000 vector *defn_symbols, updating the list of symbols in OBSTACKP
5001 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5002 OBJFILE is the section containing BLOCK.
5003 SYMTAB is recorded with each symbol added. */
5006 ada_add_block_symbols (struct obstack *obstackp,
5007 struct block *block, const char *name,
5008 domain_enum domain, struct objfile *objfile,
5011 struct dict_iterator iter;
5012 int name_len = strlen (name);
5013 /* A matching argument symbol, if any. */
5014 struct symbol *arg_sym;
5015 /* Set true when we find a matching non-argument symbol. */
5024 ALL_BLOCK_SYMBOLS (block, iter, sym)
5026 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5027 SYMBOL_DOMAIN (sym), domain)
5028 && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (sym)))
5030 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5032 else if (SYMBOL_IS_ARGUMENT (sym))
5037 add_defn_to_vec (obstackp,
5038 fixup_symbol_section (sym, objfile),
5046 ALL_BLOCK_SYMBOLS (block, iter, sym)
5048 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5049 SYMBOL_DOMAIN (sym), domain))
5051 int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym), name_len);
5053 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len))
5055 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5057 if (SYMBOL_IS_ARGUMENT (sym))
5062 add_defn_to_vec (obstackp,
5063 fixup_symbol_section (sym, objfile),
5072 if (!found_sym && arg_sym != NULL)
5074 add_defn_to_vec (obstackp,
5075 fixup_symbol_section (arg_sym, objfile),
5084 ALL_BLOCK_SYMBOLS (block, iter, sym)
5086 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5087 SYMBOL_DOMAIN (sym), domain))
5091 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5094 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5096 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5101 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5103 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5105 if (SYMBOL_IS_ARGUMENT (sym))
5110 add_defn_to_vec (obstackp,
5111 fixup_symbol_section (sym, objfile),
5119 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5120 They aren't parameters, right? */
5121 if (!found_sym && arg_sym != NULL)
5123 add_defn_to_vec (obstackp,
5124 fixup_symbol_section (arg_sym, objfile),
5131 /* Symbol Completion */
5133 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5134 name in a form that's appropriate for the completion. The result
5135 does not need to be deallocated, but is only good until the next call.
5137 TEXT_LEN is equal to the length of TEXT.
5138 Perform a wild match if WILD_MATCH is set.
5139 ENCODED should be set if TEXT represents the start of a symbol name
5140 in its encoded form. */
5143 symbol_completion_match (const char *sym_name,
5144 const char *text, int text_len,
5145 int wild_match, int encoded)
5148 const int verbatim_match = (text[0] == '<');
5153 /* Strip the leading angle bracket. */
5158 /* First, test against the fully qualified name of the symbol. */
5160 if (strncmp (sym_name, text, text_len) == 0)
5163 if (match && !encoded)
5165 /* One needed check before declaring a positive match is to verify
5166 that iff we are doing a verbatim match, the decoded version
5167 of the symbol name starts with '<'. Otherwise, this symbol name
5168 is not a suitable completion. */
5169 const char *sym_name_copy = sym_name;
5170 int has_angle_bracket;
5172 sym_name = ada_decode (sym_name);
5173 has_angle_bracket = (sym_name[0] == '<');
5174 match = (has_angle_bracket == verbatim_match);
5175 sym_name = sym_name_copy;
5178 if (match && !verbatim_match)
5180 /* When doing non-verbatim match, another check that needs to
5181 be done is to verify that the potentially matching symbol name
5182 does not include capital letters, because the ada-mode would
5183 not be able to understand these symbol names without the
5184 angle bracket notation. */
5187 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5192 /* Second: Try wild matching... */
5194 if (!match && wild_match)
5196 /* Since we are doing wild matching, this means that TEXT
5197 may represent an unqualified symbol name. We therefore must
5198 also compare TEXT against the unqualified name of the symbol. */
5199 sym_name = ada_unqualified_name (ada_decode (sym_name));
5201 if (strncmp (sym_name, text, text_len) == 0)
5205 /* Finally: If we found a mach, prepare the result to return. */
5211 sym_name = add_angle_brackets (sym_name);
5214 sym_name = ada_decode (sym_name);
5219 typedef char *char_ptr;
5220 DEF_VEC_P (char_ptr);
5222 /* A companion function to ada_make_symbol_completion_list().
5223 Check if SYM_NAME represents a symbol which name would be suitable
5224 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5225 it is appended at the end of the given string vector SV.
5227 ORIG_TEXT is the string original string from the user command
5228 that needs to be completed. WORD is the entire command on which
5229 completion should be performed. These two parameters are used to
5230 determine which part of the symbol name should be added to the
5232 if WILD_MATCH is set, then wild matching is performed.
5233 ENCODED should be set if TEXT represents a symbol name in its
5234 encoded formed (in which case the completion should also be
5238 symbol_completion_add (VEC(char_ptr) **sv,
5239 const char *sym_name,
5240 const char *text, int text_len,
5241 const char *orig_text, const char *word,
5242 int wild_match, int encoded)
5244 const char *match = symbol_completion_match (sym_name, text, text_len,
5245 wild_match, encoded);
5251 /* We found a match, so add the appropriate completion to the given
5254 if (word == orig_text)
5256 completion = xmalloc (strlen (match) + 5);
5257 strcpy (completion, match);
5259 else if (word > orig_text)
5261 /* Return some portion of sym_name. */
5262 completion = xmalloc (strlen (match) + 5);
5263 strcpy (completion, match + (word - orig_text));
5267 /* Return some of ORIG_TEXT plus sym_name. */
5268 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
5269 strncpy (completion, word, orig_text - word);
5270 completion[orig_text - word] = '\0';
5271 strcat (completion, match);
5274 VEC_safe_push (char_ptr, *sv, completion);
5277 /* Return a list of possible symbol names completing TEXT0. The list
5278 is NULL terminated. WORD is the entire command on which completion
5282 ada_make_symbol_completion_list (char *text0, char *word)
5288 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
5291 struct partial_symtab *ps;
5292 struct minimal_symbol *msymbol;
5293 struct objfile *objfile;
5294 struct block *b, *surrounding_static_block = 0;
5296 struct dict_iterator iter;
5298 if (text0[0] == '<')
5300 text = xstrdup (text0);
5301 make_cleanup (xfree, text);
5302 text_len = strlen (text);
5308 text = xstrdup (ada_encode (text0));
5309 make_cleanup (xfree, text);
5310 text_len = strlen (text);
5311 for (i = 0; i < text_len; i++)
5312 text[i] = tolower (text[i]);
5314 encoded = (strstr (text0, "__") != NULL);
5315 /* If the name contains a ".", then the user is entering a fully
5316 qualified entity name, and the match must not be done in wild
5317 mode. Similarly, if the user wants to complete what looks like
5318 an encoded name, the match must not be done in wild mode. */
5319 wild_match = (strchr (text0, '.') == NULL && !encoded);
5322 /* First, look at the partial symtab symbols. */
5323 ALL_PSYMTABS (objfile, ps)
5325 struct partial_symbol **psym;
5327 /* If the psymtab's been read in we'll get it when we search
5328 through the blockvector. */
5332 for (psym = objfile->global_psymbols.list + ps->globals_offset;
5333 psym < (objfile->global_psymbols.list + ps->globals_offset
5334 + ps->n_global_syms); psym++)
5337 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (*psym),
5338 text, text_len, text0, word,
5339 wild_match, encoded);
5342 for (psym = objfile->static_psymbols.list + ps->statics_offset;
5343 psym < (objfile->static_psymbols.list + ps->statics_offset
5344 + ps->n_static_syms); psym++)
5347 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (*psym),
5348 text, text_len, text0, word,
5349 wild_match, encoded);
5353 /* At this point scan through the misc symbol vectors and add each
5354 symbol you find to the list. Eventually we want to ignore
5355 anything that isn't a text symbol (everything else will be
5356 handled by the psymtab code above). */
5358 ALL_MSYMBOLS (objfile, msymbol)
5361 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
5362 text, text_len, text0, word, wild_match, encoded);
5365 /* Search upwards from currently selected frame (so that we can
5366 complete on local vars. */
5368 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
5370 if (!BLOCK_SUPERBLOCK (b))
5371 surrounding_static_block = b; /* For elmin of dups */
5373 ALL_BLOCK_SYMBOLS (b, iter, sym)
5375 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5376 text, text_len, text0, word,
5377 wild_match, encoded);
5381 /* Go through the symtabs and check the externs and statics for
5382 symbols which match. */
5384 ALL_SYMTABS (objfile, s)
5387 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5388 ALL_BLOCK_SYMBOLS (b, iter, sym)
5390 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5391 text, text_len, text0, word,
5392 wild_match, encoded);
5396 ALL_SYMTABS (objfile, s)
5399 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
5400 /* Don't do this block twice. */
5401 if (b == surrounding_static_block)
5403 ALL_BLOCK_SYMBOLS (b, iter, sym)
5405 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5406 text, text_len, text0, word,
5407 wild_match, encoded);
5411 /* Append the closing NULL entry. */
5412 VEC_safe_push (char_ptr, completions, NULL);
5414 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5415 return the copy. It's unfortunate that we have to make a copy
5416 of an array that we're about to destroy, but there is nothing much
5417 we can do about it. Fortunately, it's typically not a very large
5420 const size_t completions_size =
5421 VEC_length (char_ptr, completions) * sizeof (char *);
5422 char **result = malloc (completions_size);
5424 memcpy (result, VEC_address (char_ptr, completions), completions_size);
5426 VEC_free (char_ptr, completions);
5433 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5434 for tagged types. */
5437 ada_is_dispatch_table_ptr_type (struct type *type)
5441 if (TYPE_CODE (type) != TYPE_CODE_PTR)
5444 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
5448 return (strcmp (name, "ada__tags__dispatch_table") == 0);
5451 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5452 to be invisible to users. */
5455 ada_is_ignored_field (struct type *type, int field_num)
5457 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5460 /* Check the name of that field. */
5462 const char *name = TYPE_FIELD_NAME (type, field_num);
5464 /* Anonymous field names should not be printed.
5465 brobecker/2007-02-20: I don't think this can actually happen
5466 but we don't want to print the value of annonymous fields anyway. */
5470 /* A field named "_parent" is internally generated by GNAT for
5471 tagged types, and should not be printed either. */
5472 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
5476 /* If this is the dispatch table of a tagged type, then ignore. */
5477 if (ada_is_tagged_type (type, 1)
5478 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num)))
5481 /* Not a special field, so it should not be ignored. */
5485 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5486 pointer or reference type whose ultimate target has a tag field. */
5489 ada_is_tagged_type (struct type *type, int refok)
5491 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
5494 /* True iff TYPE represents the type of X'Tag */
5497 ada_is_tag_type (struct type *type)
5499 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
5503 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5504 return (name != NULL
5505 && strcmp (name, "ada__tags__dispatch_table") == 0);
5509 /* The type of the tag on VAL. */
5512 ada_tag_type (struct value *val)
5514 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
5517 /* The value of the tag on VAL. */
5520 ada_value_tag (struct value *val)
5522 return ada_value_struct_elt (val, "_tag", 0);
5525 /* The value of the tag on the object of type TYPE whose contents are
5526 saved at VALADDR, if it is non-null, or is at memory address
5529 static struct value *
5530 value_tag_from_contents_and_address (struct type *type,
5531 const gdb_byte *valaddr,
5534 int tag_byte_offset, dummy1, dummy2;
5535 struct type *tag_type;
5536 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
5539 const gdb_byte *valaddr1 = ((valaddr == NULL)
5541 : valaddr + tag_byte_offset);
5542 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
5544 return value_from_contents_and_address (tag_type, valaddr1, address1);
5549 static struct type *
5550 type_from_tag (struct value *tag)
5552 const char *type_name = ada_tag_name (tag);
5553 if (type_name != NULL)
5554 return ada_find_any_type (ada_encode (type_name));
5565 static int ada_tag_name_1 (void *);
5566 static int ada_tag_name_2 (struct tag_args *);
5568 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5569 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5570 The value stored in ARGS->name is valid until the next call to
5574 ada_tag_name_1 (void *args0)
5576 struct tag_args *args = (struct tag_args *) args0;
5577 static char name[1024];
5581 val = ada_value_struct_elt (args->tag, "tsd", 1);
5583 return ada_tag_name_2 (args);
5584 val = ada_value_struct_elt (val, "expanded_name", 1);
5587 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5588 for (p = name; *p != '\0'; p += 1)
5595 /* Utility function for ada_tag_name_1 that tries the second
5596 representation for the dispatch table (in which there is no
5597 explicit 'tsd' field in the referent of the tag pointer, and instead
5598 the tsd pointer is stored just before the dispatch table. */
5601 ada_tag_name_2 (struct tag_args *args)
5603 struct type *info_type;
5604 static char name[1024];
5606 struct value *val, *valp;
5609 info_type = ada_find_any_type ("ada__tags__type_specific_data");
5610 if (info_type == NULL)
5612 info_type = lookup_pointer_type (lookup_pointer_type (info_type));
5613 valp = value_cast (info_type, args->tag);
5616 val = value_ind (value_ptradd (valp,
5617 value_from_longest (builtin_type_int8, -1)));
5620 val = ada_value_struct_elt (val, "expanded_name", 1);
5623 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5624 for (p = name; *p != '\0'; p += 1)
5631 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5635 ada_tag_name (struct value *tag)
5637 struct tag_args args;
5638 if (!ada_is_tag_type (value_type (tag)))
5642 catch_errors (ada_tag_name_1, &args, NULL, RETURN_MASK_ALL);
5646 /* The parent type of TYPE, or NULL if none. */
5649 ada_parent_type (struct type *type)
5653 type = ada_check_typedef (type);
5655 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5658 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5659 if (ada_is_parent_field (type, i))
5661 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
5663 /* If the _parent field is a pointer, then dereference it. */
5664 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
5665 parent_type = TYPE_TARGET_TYPE (parent_type);
5666 /* If there is a parallel XVS type, get the actual base type. */
5667 parent_type = ada_get_base_type (parent_type);
5669 return ada_check_typedef (parent_type);
5675 /* True iff field number FIELD_NUM of structure type TYPE contains the
5676 parent-type (inherited) fields of a derived type. Assumes TYPE is
5677 a structure type with at least FIELD_NUM+1 fields. */
5680 ada_is_parent_field (struct type *type, int field_num)
5682 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5683 return (name != NULL
5684 && (strncmp (name, "PARENT", 6) == 0
5685 || strncmp (name, "_parent", 7) == 0));
5688 /* True iff field number FIELD_NUM of structure type TYPE is a
5689 transparent wrapper field (which should be silently traversed when doing
5690 field selection and flattened when printing). Assumes TYPE is a
5691 structure type with at least FIELD_NUM+1 fields. Such fields are always
5695 ada_is_wrapper_field (struct type *type, int field_num)
5697 const char *name = TYPE_FIELD_NAME (type, field_num);
5698 return (name != NULL
5699 && (strncmp (name, "PARENT", 6) == 0
5700 || strcmp (name, "REP") == 0
5701 || strncmp (name, "_parent", 7) == 0
5702 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
5705 /* True iff field number FIELD_NUM of structure or union type TYPE
5706 is a variant wrapper. Assumes TYPE is a structure type with at least
5707 FIELD_NUM+1 fields. */
5710 ada_is_variant_part (struct type *type, int field_num)
5712 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5713 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
5714 || (is_dynamic_field (type, field_num)
5715 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
5716 == TYPE_CODE_UNION)));
5719 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5720 whose discriminants are contained in the record type OUTER_TYPE,
5721 returns the type of the controlling discriminant for the variant. */
5724 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
5726 char *name = ada_variant_discrim_name (var_type);
5728 ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
5730 return builtin_type_int32;
5735 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5736 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5737 represents a 'when others' clause; otherwise 0. */
5740 ada_is_others_clause (struct type *type, int field_num)
5742 const char *name = TYPE_FIELD_NAME (type, field_num);
5743 return (name != NULL && name[0] == 'O');
5746 /* Assuming that TYPE0 is the type of the variant part of a record,
5747 returns the name of the discriminant controlling the variant.
5748 The value is valid until the next call to ada_variant_discrim_name. */
5751 ada_variant_discrim_name (struct type *type0)
5753 static char *result = NULL;
5754 static size_t result_len = 0;
5757 const char *discrim_end;
5758 const char *discrim_start;
5760 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
5761 type = TYPE_TARGET_TYPE (type0);
5765 name = ada_type_name (type);
5767 if (name == NULL || name[0] == '\000')
5770 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
5773 if (strncmp (discrim_end, "___XVN", 6) == 0)
5776 if (discrim_end == name)
5779 for (discrim_start = discrim_end; discrim_start != name + 3;
5782 if (discrim_start == name + 1)
5784 if ((discrim_start > name + 3
5785 && strncmp (discrim_start - 3, "___", 3) == 0)
5786 || discrim_start[-1] == '.')
5790 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
5791 strncpy (result, discrim_start, discrim_end - discrim_start);
5792 result[discrim_end - discrim_start] = '\0';
5796 /* Scan STR for a subtype-encoded number, beginning at position K.
5797 Put the position of the character just past the number scanned in
5798 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5799 Return 1 if there was a valid number at the given position, and 0
5800 otherwise. A "subtype-encoded" number consists of the absolute value
5801 in decimal, followed by the letter 'm' to indicate a negative number.
5802 Assumes 0m does not occur. */
5805 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
5809 if (!isdigit (str[k]))
5812 /* Do it the hard way so as not to make any assumption about
5813 the relationship of unsigned long (%lu scan format code) and
5816 while (isdigit (str[k]))
5818 RU = RU * 10 + (str[k] - '0');
5825 *R = (-(LONGEST) (RU - 1)) - 1;
5831 /* NOTE on the above: Technically, C does not say what the results of
5832 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5833 number representable as a LONGEST (although either would probably work
5834 in most implementations). When RU>0, the locution in the then branch
5835 above is always equivalent to the negative of RU. */
5842 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5843 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5844 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5847 ada_in_variant (LONGEST val, struct type *type, int field_num)
5849 const char *name = TYPE_FIELD_NAME (type, field_num);
5862 if (!ada_scan_number (name, p + 1, &W, &p))
5871 if (!ada_scan_number (name, p + 1, &L, &p)
5872 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
5874 if (val >= L && val <= U)
5886 /* FIXME: Lots of redundancy below. Try to consolidate. */
5888 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5889 ARG_TYPE, extract and return the value of one of its (non-static)
5890 fields. FIELDNO says which field. Differs from value_primitive_field
5891 only in that it can handle packed values of arbitrary type. */
5893 static struct value *
5894 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
5895 struct type *arg_type)
5899 arg_type = ada_check_typedef (arg_type);
5900 type = TYPE_FIELD_TYPE (arg_type, fieldno);
5902 /* Handle packed fields. */
5904 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
5906 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
5907 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
5909 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
5910 offset + bit_pos / 8,
5911 bit_pos % 8, bit_size, type);
5914 return value_primitive_field (arg1, offset, fieldno, arg_type);
5917 /* Find field with name NAME in object of type TYPE. If found,
5918 set the following for each argument that is non-null:
5919 - *FIELD_TYPE_P to the field's type;
5920 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
5921 an object of that type;
5922 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
5923 - *BIT_SIZE_P to its size in bits if the field is packed, and
5925 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
5926 fields up to but not including the desired field, or by the total
5927 number of fields if not found. A NULL value of NAME never
5928 matches; the function just counts visible fields in this case.
5930 Returns 1 if found, 0 otherwise. */
5933 find_struct_field (char *name, struct type *type, int offset,
5934 struct type **field_type_p,
5935 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
5940 type = ada_check_typedef (type);
5942 if (field_type_p != NULL)
5943 *field_type_p = NULL;
5944 if (byte_offset_p != NULL)
5946 if (bit_offset_p != NULL)
5948 if (bit_size_p != NULL)
5951 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5953 int bit_pos = TYPE_FIELD_BITPOS (type, i);
5954 int fld_offset = offset + bit_pos / 8;
5955 char *t_field_name = TYPE_FIELD_NAME (type, i);
5957 if (t_field_name == NULL)
5960 else if (name != NULL && field_name_match (t_field_name, name))
5962 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5963 if (field_type_p != NULL)
5964 *field_type_p = TYPE_FIELD_TYPE (type, i);
5965 if (byte_offset_p != NULL)
5966 *byte_offset_p = fld_offset;
5967 if (bit_offset_p != NULL)
5968 *bit_offset_p = bit_pos % 8;
5969 if (bit_size_p != NULL)
5970 *bit_size_p = bit_size;
5973 else if (ada_is_wrapper_field (type, i))
5975 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
5976 field_type_p, byte_offset_p, bit_offset_p,
5977 bit_size_p, index_p))
5980 else if (ada_is_variant_part (type, i))
5982 /* PNH: Wait. Do we ever execute this section, or is ARG always of
5985 struct type *field_type
5986 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
5988 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
5990 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
5992 + TYPE_FIELD_BITPOS (field_type, j) / 8,
5993 field_type_p, byte_offset_p,
5994 bit_offset_p, bit_size_p, index_p))
5998 else if (index_p != NULL)
6004 /* Number of user-visible fields in record type TYPE. */
6007 num_visible_fields (struct type *type)
6011 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6015 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6016 and search in it assuming it has (class) type TYPE.
6017 If found, return value, else return NULL.
6019 Searches recursively through wrapper fields (e.g., '_parent'). */
6021 static struct value *
6022 ada_search_struct_field (char *name, struct value *arg, int offset,
6026 type = ada_check_typedef (type);
6028 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6030 char *t_field_name = TYPE_FIELD_NAME (type, i);
6032 if (t_field_name == NULL)
6035 else if (field_name_match (t_field_name, name))
6036 return ada_value_primitive_field (arg, offset, i, type);
6038 else if (ada_is_wrapper_field (type, i))
6040 struct value *v = /* Do not let indent join lines here. */
6041 ada_search_struct_field (name, arg,
6042 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6043 TYPE_FIELD_TYPE (type, i));
6048 else if (ada_is_variant_part (type, i))
6050 /* PNH: Do we ever get here? See find_struct_field. */
6052 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6053 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6055 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
6057 struct value *v = ada_search_struct_field /* Force line break. */
6059 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6060 TYPE_FIELD_TYPE (field_type, j));
6069 static struct value *ada_index_struct_field_1 (int *, struct value *,
6070 int, struct type *);
6073 /* Return field #INDEX in ARG, where the index is that returned by
6074 * find_struct_field through its INDEX_P argument. Adjust the address
6075 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6076 * If found, return value, else return NULL. */
6078 static struct value *
6079 ada_index_struct_field (int index, struct value *arg, int offset,
6082 return ada_index_struct_field_1 (&index, arg, offset, type);
6086 /* Auxiliary function for ada_index_struct_field. Like
6087 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6090 static struct value *
6091 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6095 type = ada_check_typedef (type);
6097 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6099 if (TYPE_FIELD_NAME (type, i) == NULL)
6101 else if (ada_is_wrapper_field (type, i))
6103 struct value *v = /* Do not let indent join lines here. */
6104 ada_index_struct_field_1 (index_p, arg,
6105 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6106 TYPE_FIELD_TYPE (type, i));
6111 else if (ada_is_variant_part (type, i))
6113 /* PNH: Do we ever get here? See ada_search_struct_field,
6114 find_struct_field. */
6115 error (_("Cannot assign this kind of variant record"));
6117 else if (*index_p == 0)
6118 return ada_value_primitive_field (arg, offset, i, type);
6125 /* Given ARG, a value of type (pointer or reference to a)*
6126 structure/union, extract the component named NAME from the ultimate
6127 target structure/union and return it as a value with its
6130 The routine searches for NAME among all members of the structure itself
6131 and (recursively) among all members of any wrapper members
6134 If NO_ERR, then simply return NULL in case of error, rather than
6138 ada_value_struct_elt (struct value *arg, char *name, int no_err)
6140 struct type *t, *t1;
6144 t1 = t = ada_check_typedef (value_type (arg));
6145 if (TYPE_CODE (t) == TYPE_CODE_REF)
6147 t1 = TYPE_TARGET_TYPE (t);
6150 t1 = ada_check_typedef (t1);
6151 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
6153 arg = coerce_ref (arg);
6158 while (TYPE_CODE (t) == TYPE_CODE_PTR)
6160 t1 = TYPE_TARGET_TYPE (t);
6163 t1 = ada_check_typedef (t1);
6164 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
6166 arg = value_ind (arg);
6173 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
6177 v = ada_search_struct_field (name, arg, 0, t);
6180 int bit_offset, bit_size, byte_offset;
6181 struct type *field_type;
6184 if (TYPE_CODE (t) == TYPE_CODE_PTR)
6185 address = value_as_address (arg);
6187 address = unpack_pointer (t, value_contents (arg));
6189 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
6190 if (find_struct_field (name, t1, 0,
6191 &field_type, &byte_offset, &bit_offset,
6196 if (TYPE_CODE (t) == TYPE_CODE_REF)
6197 arg = ada_coerce_ref (arg);
6199 arg = ada_value_ind (arg);
6200 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6201 bit_offset, bit_size,
6205 v = value_at_lazy (field_type, address + byte_offset);
6209 if (v != NULL || no_err)
6212 error (_("There is no member named %s."), name);
6218 error (_("Attempt to extract a component of a value that is not a record."));
6221 /* Given a type TYPE, look up the type of the component of type named NAME.
6222 If DISPP is non-null, add its byte displacement from the beginning of a
6223 structure (pointed to by a value) of type TYPE to *DISPP (does not
6224 work for packed fields).
6226 Matches any field whose name has NAME as a prefix, possibly
6229 TYPE can be either a struct or union. If REFOK, TYPE may also
6230 be a (pointer or reference)+ to a struct or union, and the
6231 ultimate target type will be searched.
6233 Looks recursively into variant clauses and parent types.
6235 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6236 TYPE is not a type of the right kind. */
6238 static struct type *
6239 ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6240 int noerr, int *dispp)
6247 if (refok && type != NULL)
6250 type = ada_check_typedef (type);
6251 if (TYPE_CODE (type) != TYPE_CODE_PTR
6252 && TYPE_CODE (type) != TYPE_CODE_REF)
6254 type = TYPE_TARGET_TYPE (type);
6258 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6259 && TYPE_CODE (type) != TYPE_CODE_UNION))
6265 target_terminal_ours ();
6266 gdb_flush (gdb_stdout);
6268 error (_("Type (null) is not a structure or union type"));
6271 /* XXX: type_sprint */
6272 fprintf_unfiltered (gdb_stderr, _("Type "));
6273 type_print (type, "", gdb_stderr, -1);
6274 error (_(" is not a structure or union type"));
6279 type = to_static_fixed_type (type);
6281 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6283 char *t_field_name = TYPE_FIELD_NAME (type, i);
6287 if (t_field_name == NULL)
6290 else if (field_name_match (t_field_name, name))
6293 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
6294 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6297 else if (ada_is_wrapper_field (type, i))
6300 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
6305 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6310 else if (ada_is_variant_part (type, i))
6313 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6315 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
6317 /* FIXME pnh 2008/01/26: We check for a field that is
6318 NOT wrapped in a struct, since the compiler sometimes
6319 generates these for unchecked variant types. Revisit
6320 if the compiler changes this practice. */
6321 char *v_field_name = TYPE_FIELD_NAME (field_type, j);
6323 if (v_field_name != NULL
6324 && field_name_match (v_field_name, name))
6325 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
6327 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
6333 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6344 target_terminal_ours ();
6345 gdb_flush (gdb_stdout);
6348 /* XXX: type_sprint */
6349 fprintf_unfiltered (gdb_stderr, _("Type "));
6350 type_print (type, "", gdb_stderr, -1);
6351 error (_(" has no component named <null>"));
6355 /* XXX: type_sprint */
6356 fprintf_unfiltered (gdb_stderr, _("Type "));
6357 type_print (type, "", gdb_stderr, -1);
6358 error (_(" has no component named %s"), name);
6365 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6366 within a value of type OUTER_TYPE, return true iff VAR_TYPE
6367 represents an unchecked union (that is, the variant part of a
6368 record that is named in an Unchecked_Union pragma). */
6371 is_unchecked_variant (struct type *var_type, struct type *outer_type)
6373 char *discrim_name = ada_variant_discrim_name (var_type);
6374 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
6379 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6380 within a value of type OUTER_TYPE that is stored in GDB at
6381 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6382 numbering from 0) is applicable. Returns -1 if none are. */
6385 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
6386 const gdb_byte *outer_valaddr)
6390 char *discrim_name = ada_variant_discrim_name (var_type);
6391 struct value *outer;
6392 struct value *discrim;
6393 LONGEST discrim_val;
6395 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
6396 discrim = ada_value_struct_elt (outer, discrim_name, 1);
6397 if (discrim == NULL)
6399 discrim_val = value_as_long (discrim);
6402 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
6404 if (ada_is_others_clause (var_type, i))
6406 else if (ada_in_variant (discrim_val, var_type, i))
6410 return others_clause;
6415 /* Dynamic-Sized Records */
6417 /* Strategy: The type ostensibly attached to a value with dynamic size
6418 (i.e., a size that is not statically recorded in the debugging
6419 data) does not accurately reflect the size or layout of the value.
6420 Our strategy is to convert these values to values with accurate,
6421 conventional types that are constructed on the fly. */
6423 /* There is a subtle and tricky problem here. In general, we cannot
6424 determine the size of dynamic records without its data. However,
6425 the 'struct value' data structure, which GDB uses to represent
6426 quantities in the inferior process (the target), requires the size
6427 of the type at the time of its allocation in order to reserve space
6428 for GDB's internal copy of the data. That's why the
6429 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6430 rather than struct value*s.
6432 However, GDB's internal history variables ($1, $2, etc.) are
6433 struct value*s containing internal copies of the data that are not, in
6434 general, the same as the data at their corresponding addresses in
6435 the target. Fortunately, the types we give to these values are all
6436 conventional, fixed-size types (as per the strategy described
6437 above), so that we don't usually have to perform the
6438 'to_fixed_xxx_type' conversions to look at their values.
6439 Unfortunately, there is one exception: if one of the internal
6440 history variables is an array whose elements are unconstrained
6441 records, then we will need to create distinct fixed types for each
6442 element selected. */
6444 /* The upshot of all of this is that many routines take a (type, host
6445 address, target address) triple as arguments to represent a value.
6446 The host address, if non-null, is supposed to contain an internal
6447 copy of the relevant data; otherwise, the program is to consult the
6448 target at the target address. */
6450 /* Assuming that VAL0 represents a pointer value, the result of
6451 dereferencing it. Differs from value_ind in its treatment of
6452 dynamic-sized types. */
6455 ada_value_ind (struct value *val0)
6457 struct value *val = unwrap_value (value_ind (val0));
6458 return ada_to_fixed_value (val);
6461 /* The value resulting from dereferencing any "reference to"
6462 qualifiers on VAL0. */
6464 static struct value *
6465 ada_coerce_ref (struct value *val0)
6467 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
6469 struct value *val = val0;
6470 val = coerce_ref (val);
6471 val = unwrap_value (val);
6472 return ada_to_fixed_value (val);
6478 /* Return OFF rounded upward if necessary to a multiple of
6479 ALIGNMENT (a power of 2). */
6482 align_value (unsigned int off, unsigned int alignment)
6484 return (off + alignment - 1) & ~(alignment - 1);
6487 /* Return the bit alignment required for field #F of template type TYPE. */
6490 field_alignment (struct type *type, int f)
6492 const char *name = TYPE_FIELD_NAME (type, f);
6496 /* The field name should never be null, unless the debugging information
6497 is somehow malformed. In this case, we assume the field does not
6498 require any alignment. */
6502 len = strlen (name);
6504 if (!isdigit (name[len - 1]))
6507 if (isdigit (name[len - 2]))
6508 align_offset = len - 2;
6510 align_offset = len - 1;
6512 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
6513 return TARGET_CHAR_BIT;
6515 return atoi (name + align_offset) * TARGET_CHAR_BIT;
6518 /* Find a symbol named NAME. Ignores ambiguity. */
6521 ada_find_any_symbol (const char *name)
6525 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
6526 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
6529 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
6533 /* Find a type named NAME. Ignores ambiguity. */
6536 ada_find_any_type (const char *name)
6538 struct symbol *sym = ada_find_any_symbol (name);
6539 struct type *type = NULL;
6542 type = SYMBOL_TYPE (sym);
6545 type = language_lookup_primitive_type_by_name
6546 (language_def (language_ada), current_gdbarch, name);
6551 /* Given NAME and an associated BLOCK, search all symbols for
6552 NAME suffixed with "___XR", which is the ``renaming'' symbol
6553 associated to NAME. Return this symbol if found, return
6557 ada_find_renaming_symbol (const char *name, struct block *block)
6561 sym = find_old_style_renaming_symbol (name, block);
6566 /* Not right yet. FIXME pnh 7/20/2007. */
6567 sym = ada_find_any_symbol (name);
6568 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
6574 static struct symbol *
6575 find_old_style_renaming_symbol (const char *name, struct block *block)
6577 const struct symbol *function_sym = block_linkage_function (block);
6580 if (function_sym != NULL)
6582 /* If the symbol is defined inside a function, NAME is not fully
6583 qualified. This means we need to prepend the function name
6584 as well as adding the ``___XR'' suffix to build the name of
6585 the associated renaming symbol. */
6586 char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
6587 /* Function names sometimes contain suffixes used
6588 for instance to qualify nested subprograms. When building
6589 the XR type name, we need to make sure that this suffix is
6590 not included. So do not include any suffix in the function
6591 name length below. */
6592 const int function_name_len = ada_name_prefix_len (function_name);
6593 const int rename_len = function_name_len + 2 /* "__" */
6594 + strlen (name) + 6 /* "___XR\0" */ ;
6596 /* Strip the suffix if necessary. */
6597 function_name[function_name_len] = '\0';
6599 /* Library-level functions are a special case, as GNAT adds
6600 a ``_ada_'' prefix to the function name to avoid namespace
6601 pollution. However, the renaming symbols themselves do not
6602 have this prefix, so we need to skip this prefix if present. */
6603 if (function_name_len > 5 /* "_ada_" */
6604 && strstr (function_name, "_ada_") == function_name)
6605 function_name = function_name + 5;
6607 rename = (char *) alloca (rename_len * sizeof (char));
6608 sprintf (rename, "%s__%s___XR", function_name, name);
6612 const int rename_len = strlen (name) + 6;
6613 rename = (char *) alloca (rename_len * sizeof (char));
6614 sprintf (rename, "%s___XR", name);
6617 return ada_find_any_symbol (rename);
6620 /* Because of GNAT encoding conventions, several GDB symbols may match a
6621 given type name. If the type denoted by TYPE0 is to be preferred to
6622 that of TYPE1 for purposes of type printing, return non-zero;
6623 otherwise return 0. */
6626 ada_prefer_type (struct type *type0, struct type *type1)
6630 else if (type0 == NULL)
6632 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
6634 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
6636 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
6638 else if (ada_is_packed_array_type (type0))
6640 else if (ada_is_array_descriptor_type (type0)
6641 && !ada_is_array_descriptor_type (type1))
6645 const char *type0_name = type_name_no_tag (type0);
6646 const char *type1_name = type_name_no_tag (type1);
6648 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
6649 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
6655 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6656 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6659 ada_type_name (struct type *type)
6663 else if (TYPE_NAME (type) != NULL)
6664 return TYPE_NAME (type);
6666 return TYPE_TAG_NAME (type);
6669 /* Find a parallel type to TYPE whose name is formed by appending
6670 SUFFIX to the name of TYPE. */
6673 ada_find_parallel_type (struct type *type, const char *suffix)
6676 static size_t name_len = 0;
6678 char *typename = ada_type_name (type);
6680 if (typename == NULL)
6683 len = strlen (typename);
6685 GROW_VECT (name, name_len, len + strlen (suffix) + 1);
6687 strcpy (name, typename);
6688 strcpy (name + len, suffix);
6690 return ada_find_any_type (name);
6694 /* If TYPE is a variable-size record type, return the corresponding template
6695 type describing its fields. Otherwise, return NULL. */
6697 static struct type *
6698 dynamic_template_type (struct type *type)
6700 type = ada_check_typedef (type);
6702 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
6703 || ada_type_name (type) == NULL)
6707 int len = strlen (ada_type_name (type));
6708 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
6711 return ada_find_parallel_type (type, "___XVE");
6715 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6716 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6719 is_dynamic_field (struct type *templ_type, int field_num)
6721 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
6723 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
6724 && strstr (name, "___XVL") != NULL;
6727 /* The index of the variant field of TYPE, or -1 if TYPE does not
6728 represent a variant record type. */
6731 variant_field_index (struct type *type)
6735 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6738 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
6740 if (ada_is_variant_part (type, f))
6746 /* A record type with no fields. */
6748 static struct type *
6749 empty_record (struct objfile *objfile)
6751 struct type *type = alloc_type (objfile);
6752 TYPE_CODE (type) = TYPE_CODE_STRUCT;
6753 TYPE_NFIELDS (type) = 0;
6754 TYPE_FIELDS (type) = NULL;
6755 INIT_CPLUS_SPECIFIC (type);
6756 TYPE_NAME (type) = "<empty>";
6757 TYPE_TAG_NAME (type) = NULL;
6758 TYPE_LENGTH (type) = 0;
6762 /* An ordinary record type (with fixed-length fields) that describes
6763 the value of type TYPE at VALADDR or ADDRESS (see comments at
6764 the beginning of this section) VAL according to GNAT conventions.
6765 DVAL0 should describe the (portion of a) record that contains any
6766 necessary discriminants. It should be NULL if value_type (VAL) is
6767 an outer-level type (i.e., as opposed to a branch of a variant.) A
6768 variant field (unless unchecked) is replaced by a particular branch
6771 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6772 length are not statically known are discarded. As a consequence,
6773 VALADDR, ADDRESS and DVAL0 are ignored.
6775 NOTE: Limitations: For now, we assume that dynamic fields and
6776 variants occupy whole numbers of bytes. However, they need not be
6780 ada_template_to_fixed_record_type_1 (struct type *type,
6781 const gdb_byte *valaddr,
6782 CORE_ADDR address, struct value *dval0,
6783 int keep_dynamic_fields)
6785 struct value *mark = value_mark ();
6788 int nfields, bit_len;
6791 int fld_bit_len, bit_incr;
6794 /* Compute the number of fields in this record type that are going
6795 to be processed: unless keep_dynamic_fields, this includes only
6796 fields whose position and length are static will be processed. */
6797 if (keep_dynamic_fields)
6798 nfields = TYPE_NFIELDS (type);
6802 while (nfields < TYPE_NFIELDS (type)
6803 && !ada_is_variant_part (type, nfields)
6804 && !is_dynamic_field (type, nfields))
6808 rtype = alloc_type (TYPE_OBJFILE (type));
6809 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6810 INIT_CPLUS_SPECIFIC (rtype);
6811 TYPE_NFIELDS (rtype) = nfields;
6812 TYPE_FIELDS (rtype) = (struct field *)
6813 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6814 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
6815 TYPE_NAME (rtype) = ada_type_name (type);
6816 TYPE_TAG_NAME (rtype) = NULL;
6817 TYPE_FIXED_INSTANCE (rtype) = 1;
6823 for (f = 0; f < nfields; f += 1)
6825 off = align_value (off, field_alignment (type, f))
6826 + TYPE_FIELD_BITPOS (type, f);
6827 TYPE_FIELD_BITPOS (rtype, f) = off;
6828 TYPE_FIELD_BITSIZE (rtype, f) = 0;
6830 if (ada_is_variant_part (type, f))
6833 fld_bit_len = bit_incr = 0;
6835 else if (is_dynamic_field (type, f))
6839 /* rtype's length is computed based on the run-time
6840 value of discriminants. If the discriminants are not
6841 initialized, the type size may be completely bogus and
6842 GDB may fail to allocate a value for it. So check the
6843 size first before creating the value. */
6845 dval = value_from_contents_and_address (rtype, valaddr, address);
6850 /* Get the fixed type of the field. Note that, in this case, we
6851 do not want to get the real type out of the tag: if the current
6852 field is the parent part of a tagged record, we will get the
6853 tag of the object. Clearly wrong: the real type of the parent
6854 is not the real type of the child. We would end up in an infinite
6856 TYPE_FIELD_TYPE (rtype, f) =
6859 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
6860 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6861 cond_offset_target (address, off / TARGET_CHAR_BIT), dval, 0);
6862 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6863 bit_incr = fld_bit_len =
6864 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6868 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
6869 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6870 if (TYPE_FIELD_BITSIZE (type, f) > 0)
6871 bit_incr = fld_bit_len =
6872 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
6874 bit_incr = fld_bit_len =
6875 TYPE_LENGTH (TYPE_FIELD_TYPE (type, f)) * TARGET_CHAR_BIT;
6877 if (off + fld_bit_len > bit_len)
6878 bit_len = off + fld_bit_len;
6880 TYPE_LENGTH (rtype) =
6881 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
6884 /* We handle the variant part, if any, at the end because of certain
6885 odd cases in which it is re-ordered so as NOT to be the last field of
6886 the record. This can happen in the presence of representation
6888 if (variant_field >= 0)
6890 struct type *branch_type;
6892 off = TYPE_FIELD_BITPOS (rtype, variant_field);
6895 dval = value_from_contents_and_address (rtype, valaddr, address);
6900 to_fixed_variant_branch_type
6901 (TYPE_FIELD_TYPE (type, variant_field),
6902 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6903 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
6904 if (branch_type == NULL)
6906 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
6907 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
6908 TYPE_NFIELDS (rtype) -= 1;
6912 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
6913 TYPE_FIELD_NAME (rtype, variant_field) = "S";
6915 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
6917 if (off + fld_bit_len > bit_len)
6918 bit_len = off + fld_bit_len;
6919 TYPE_LENGTH (rtype) =
6920 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
6924 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6925 should contain the alignment of that record, which should be a strictly
6926 positive value. If null or negative, then something is wrong, most
6927 probably in the debug info. In that case, we don't round up the size
6928 of the resulting type. If this record is not part of another structure,
6929 the current RTYPE length might be good enough for our purposes. */
6930 if (TYPE_LENGTH (type) <= 0)
6932 if (TYPE_NAME (rtype))
6933 warning (_("Invalid type size for `%s' detected: %d."),
6934 TYPE_NAME (rtype), TYPE_LENGTH (type));
6936 warning (_("Invalid type size for <unnamed> detected: %d."),
6937 TYPE_LENGTH (type));
6941 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
6942 TYPE_LENGTH (type));
6945 value_free_to_mark (mark);
6946 if (TYPE_LENGTH (rtype) > varsize_limit)
6947 error (_("record type with dynamic size is larger than varsize-limit"));
6951 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6954 static struct type *
6955 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
6956 CORE_ADDR address, struct value *dval0)
6958 return ada_template_to_fixed_record_type_1 (type, valaddr,
6962 /* An ordinary record type in which ___XVL-convention fields and
6963 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6964 static approximations, containing all possible fields. Uses
6965 no runtime values. Useless for use in values, but that's OK,
6966 since the results are used only for type determinations. Works on both
6967 structs and unions. Representation note: to save space, we memorize
6968 the result of this function in the TYPE_TARGET_TYPE of the
6971 static struct type *
6972 template_to_static_fixed_type (struct type *type0)
6978 if (TYPE_TARGET_TYPE (type0) != NULL)
6979 return TYPE_TARGET_TYPE (type0);
6981 nfields = TYPE_NFIELDS (type0);
6984 for (f = 0; f < nfields; f += 1)
6986 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
6987 struct type *new_type;
6989 if (is_dynamic_field (type0, f))
6990 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
6992 new_type = static_unwrap_type (field_type);
6993 if (type == type0 && new_type != field_type)
6995 TYPE_TARGET_TYPE (type0) = type = alloc_type (TYPE_OBJFILE (type0));
6996 TYPE_CODE (type) = TYPE_CODE (type0);
6997 INIT_CPLUS_SPECIFIC (type);
6998 TYPE_NFIELDS (type) = nfields;
6999 TYPE_FIELDS (type) = (struct field *)
7000 TYPE_ALLOC (type, nfields * sizeof (struct field));
7001 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7002 sizeof (struct field) * nfields);
7003 TYPE_NAME (type) = ada_type_name (type0);
7004 TYPE_TAG_NAME (type) = NULL;
7005 TYPE_FIXED_INSTANCE (type) = 1;
7006 TYPE_LENGTH (type) = 0;
7008 TYPE_FIELD_TYPE (type, f) = new_type;
7009 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
7014 /* Given an object of type TYPE whose contents are at VALADDR and
7015 whose address in memory is ADDRESS, returns a revision of TYPE,
7016 which should be a non-dynamic-sized record, in which the variant
7017 part, if any, is replaced with the appropriate branch. Looks
7018 for discriminant values in DVAL0, which can be NULL if the record
7019 contains the necessary discriminant values. */
7021 static struct type *
7022 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
7023 CORE_ADDR address, struct value *dval0)
7025 struct value *mark = value_mark ();
7028 struct type *branch_type;
7029 int nfields = TYPE_NFIELDS (type);
7030 int variant_field = variant_field_index (type);
7032 if (variant_field == -1)
7036 dval = value_from_contents_and_address (type, valaddr, address);
7040 rtype = alloc_type (TYPE_OBJFILE (type));
7041 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7042 INIT_CPLUS_SPECIFIC (rtype);
7043 TYPE_NFIELDS (rtype) = nfields;
7044 TYPE_FIELDS (rtype) =
7045 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7046 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
7047 sizeof (struct field) * nfields);
7048 TYPE_NAME (rtype) = ada_type_name (type);
7049 TYPE_TAG_NAME (rtype) = NULL;
7050 TYPE_FIXED_INSTANCE (rtype) = 1;
7051 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7053 branch_type = to_fixed_variant_branch_type
7054 (TYPE_FIELD_TYPE (type, variant_field),
7055 cond_offset_host (valaddr,
7056 TYPE_FIELD_BITPOS (type, variant_field)
7058 cond_offset_target (address,
7059 TYPE_FIELD_BITPOS (type, variant_field)
7060 / TARGET_CHAR_BIT), dval);
7061 if (branch_type == NULL)
7064 for (f = variant_field + 1; f < nfields; f += 1)
7065 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7066 TYPE_NFIELDS (rtype) -= 1;
7070 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7071 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7072 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
7073 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
7075 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
7077 value_free_to_mark (mark);
7081 /* An ordinary record type (with fixed-length fields) that describes
7082 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7083 beginning of this section]. Any necessary discriminants' values
7084 should be in DVAL, a record value; it may be NULL if the object
7085 at ADDR itself contains any necessary discriminant values.
7086 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7087 values from the record are needed. Except in the case that DVAL,
7088 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7089 unchecked) is replaced by a particular branch of the variant.
7091 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7092 is questionable and may be removed. It can arise during the
7093 processing of an unconstrained-array-of-record type where all the
7094 variant branches have exactly the same size. This is because in
7095 such cases, the compiler does not bother to use the XVS convention
7096 when encoding the record. I am currently dubious of this
7097 shortcut and suspect the compiler should be altered. FIXME. */
7099 static struct type *
7100 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
7101 CORE_ADDR address, struct value *dval)
7103 struct type *templ_type;
7105 if (TYPE_FIXED_INSTANCE (type0))
7108 templ_type = dynamic_template_type (type0);
7110 if (templ_type != NULL)
7111 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
7112 else if (variant_field_index (type0) >= 0)
7114 if (dval == NULL && valaddr == NULL && address == 0)
7116 return to_record_with_fixed_variant_part (type0, valaddr, address,
7121 TYPE_FIXED_INSTANCE (type0) = 1;
7127 /* An ordinary record type (with fixed-length fields) that describes
7128 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7129 union type. Any necessary discriminants' values should be in DVAL,
7130 a record value. That is, this routine selects the appropriate
7131 branch of the union at ADDR according to the discriminant value
7132 indicated in the union's type name. Returns VAR_TYPE0 itself if
7133 it represents a variant subject to a pragma Unchecked_Union. */
7135 static struct type *
7136 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
7137 CORE_ADDR address, struct value *dval)
7140 struct type *templ_type;
7141 struct type *var_type;
7143 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
7144 var_type = TYPE_TARGET_TYPE (var_type0);
7146 var_type = var_type0;
7148 templ_type = ada_find_parallel_type (var_type, "___XVU");
7150 if (templ_type != NULL)
7151 var_type = templ_type;
7153 if (is_unchecked_variant (var_type, value_type (dval)))
7156 ada_which_variant_applies (var_type,
7157 value_type (dval), value_contents (dval));
7160 return empty_record (TYPE_OBJFILE (var_type));
7161 else if (is_dynamic_field (var_type, which))
7162 return to_fixed_record_type
7163 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
7164 valaddr, address, dval);
7165 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
7167 to_fixed_record_type
7168 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
7170 return TYPE_FIELD_TYPE (var_type, which);
7173 /* Assuming that TYPE0 is an array type describing the type of a value
7174 at ADDR, and that DVAL describes a record containing any
7175 discriminants used in TYPE0, returns a type for the value that
7176 contains no dynamic components (that is, no components whose sizes
7177 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7178 true, gives an error message if the resulting type's size is over
7181 static struct type *
7182 to_fixed_array_type (struct type *type0, struct value *dval,
7185 struct type *index_type_desc;
7186 struct type *result;
7188 if (ada_is_packed_array_type (type0) /* revisit? */
7189 || TYPE_FIXED_INSTANCE (type0))
7192 index_type_desc = ada_find_parallel_type (type0, "___XA");
7193 if (index_type_desc == NULL)
7195 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
7196 /* NOTE: elt_type---the fixed version of elt_type0---should never
7197 depend on the contents of the array in properly constructed
7199 /* Create a fixed version of the array element type.
7200 We're not providing the address of an element here,
7201 and thus the actual object value cannot be inspected to do
7202 the conversion. This should not be a problem, since arrays of
7203 unconstrained objects are not allowed. In particular, all
7204 the elements of an array of a tagged type should all be of
7205 the same type specified in the debugging info. No need to
7206 consult the object tag. */
7207 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
7209 if (elt_type0 == elt_type)
7212 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
7213 elt_type, TYPE_INDEX_TYPE (type0));
7218 struct type *elt_type0;
7221 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
7222 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
7224 /* NOTE: result---the fixed version of elt_type0---should never
7225 depend on the contents of the array in properly constructed
7227 /* Create a fixed version of the array element type.
7228 We're not providing the address of an element here,
7229 and thus the actual object value cannot be inspected to do
7230 the conversion. This should not be a problem, since arrays of
7231 unconstrained objects are not allowed. In particular, all
7232 the elements of an array of a tagged type should all be of
7233 the same type specified in the debugging info. No need to
7234 consult the object tag. */
7236 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
7237 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
7239 struct type *range_type =
7240 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i),
7241 dval, TYPE_OBJFILE (type0));
7242 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
7243 result, range_type);
7245 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
7246 error (_("array type with dynamic size is larger than varsize-limit"));
7249 TYPE_FIXED_INSTANCE (result) = 1;
7254 /* A standard type (containing no dynamically sized components)
7255 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7256 DVAL describes a record containing any discriminants used in TYPE0,
7257 and may be NULL if there are none, or if the object of type TYPE at
7258 ADDRESS or in VALADDR contains these discriminants.
7260 If CHECK_TAG is not null, in the case of tagged types, this function
7261 attempts to locate the object's tag and use it to compute the actual
7262 type. However, when ADDRESS is null, we cannot use it to determine the
7263 location of the tag, and therefore compute the tagged type's actual type.
7264 So we return the tagged type without consulting the tag. */
7266 static struct type *
7267 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
7268 CORE_ADDR address, struct value *dval, int check_tag)
7270 type = ada_check_typedef (type);
7271 switch (TYPE_CODE (type))
7275 case TYPE_CODE_STRUCT:
7277 struct type *static_type = to_static_fixed_type (type);
7278 struct type *fixed_record_type =
7279 to_fixed_record_type (type, valaddr, address, NULL);
7280 /* If STATIC_TYPE is a tagged type and we know the object's address,
7281 then we can determine its tag, and compute the object's actual
7282 type from there. Note that we have to use the fixed record
7283 type (the parent part of the record may have dynamic fields
7284 and the way the location of _tag is expressed may depend on
7287 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
7289 struct type *real_type =
7290 type_from_tag (value_tag_from_contents_and_address
7294 if (real_type != NULL)
7295 return to_fixed_record_type (real_type, valaddr, address, NULL);
7298 /* Check to see if there is a parallel ___XVZ variable.
7299 If there is, then it provides the actual size of our type. */
7300 else if (ada_type_name (fixed_record_type) != NULL)
7302 char *name = ada_type_name (fixed_record_type);
7303 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
7307 sprintf (xvz_name, "%s___XVZ", name);
7308 size = get_int_var_value (xvz_name, &xvz_found);
7309 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
7311 fixed_record_type = copy_type (fixed_record_type);
7312 TYPE_LENGTH (fixed_record_type) = size;
7314 /* The FIXED_RECORD_TYPE may have be a stub. We have
7315 observed this when the debugging info is STABS, and
7316 apparently it is something that is hard to fix.
7318 In practice, we don't need the actual type definition
7319 at all, because the presence of the XVZ variable allows us
7320 to assume that there must be a XVS type as well, which we
7321 should be able to use later, when we need the actual type
7324 In the meantime, pretend that the "fixed" type we are
7325 returning is NOT a stub, because this can cause trouble
7326 when using this type to create new types targeting it.
7327 Indeed, the associated creation routines often check
7328 whether the target type is a stub and will try to replace
7329 it, thus using a type with the wrong size. This, in turn,
7330 might cause the new type to have the wrong size too.
7331 Consider the case of an array, for instance, where the size
7332 of the array is computed from the number of elements in
7333 our array multiplied by the size of its element. */
7334 TYPE_STUB (fixed_record_type) = 0;
7337 return fixed_record_type;
7339 case TYPE_CODE_ARRAY:
7340 return to_fixed_array_type (type, dval, 1);
7341 case TYPE_CODE_UNION:
7345 return to_fixed_variant_branch_type (type, valaddr, address, dval);
7349 /* The same as ada_to_fixed_type_1, except that it preserves the type
7350 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7351 ada_to_fixed_type_1 would return the type referenced by TYPE. */
7354 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
7355 CORE_ADDR address, struct value *dval, int check_tag)
7358 struct type *fixed_type =
7359 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
7361 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
7362 && TYPE_TARGET_TYPE (type) == fixed_type)
7368 /* A standard (static-sized) type corresponding as well as possible to
7369 TYPE0, but based on no runtime data. */
7371 static struct type *
7372 to_static_fixed_type (struct type *type0)
7379 if (TYPE_FIXED_INSTANCE (type0))
7382 type0 = ada_check_typedef (type0);
7384 switch (TYPE_CODE (type0))
7388 case TYPE_CODE_STRUCT:
7389 type = dynamic_template_type (type0);
7391 return template_to_static_fixed_type (type);
7393 return template_to_static_fixed_type (type0);
7394 case TYPE_CODE_UNION:
7395 type = ada_find_parallel_type (type0, "___XVU");
7397 return template_to_static_fixed_type (type);
7399 return template_to_static_fixed_type (type0);
7403 /* A static approximation of TYPE with all type wrappers removed. */
7405 static struct type *
7406 static_unwrap_type (struct type *type)
7408 if (ada_is_aligner_type (type))
7410 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
7411 if (ada_type_name (type1) == NULL)
7412 TYPE_NAME (type1) = ada_type_name (type);
7414 return static_unwrap_type (type1);
7418 struct type *raw_real_type = ada_get_base_type (type);
7419 if (raw_real_type == type)
7422 return to_static_fixed_type (raw_real_type);
7426 /* In some cases, incomplete and private types require
7427 cross-references that are not resolved as records (for example,
7429 type FooP is access Foo;
7431 type Foo is array ...;
7432 ). In these cases, since there is no mechanism for producing
7433 cross-references to such types, we instead substitute for FooP a
7434 stub enumeration type that is nowhere resolved, and whose tag is
7435 the name of the actual type. Call these types "non-record stubs". */
7437 /* A type equivalent to TYPE that is not a non-record stub, if one
7438 exists, otherwise TYPE. */
7441 ada_check_typedef (struct type *type)
7446 CHECK_TYPEDEF (type);
7447 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
7448 || !TYPE_STUB (type)
7449 || TYPE_TAG_NAME (type) == NULL)
7453 char *name = TYPE_TAG_NAME (type);
7454 struct type *type1 = ada_find_any_type (name);
7455 return (type1 == NULL) ? type : type1;
7459 /* A value representing the data at VALADDR/ADDRESS as described by
7460 type TYPE0, but with a standard (static-sized) type that correctly
7461 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7462 type, then return VAL0 [this feature is simply to avoid redundant
7463 creation of struct values]. */
7465 static struct value *
7466 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
7469 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
7470 if (type == type0 && val0 != NULL)
7473 return value_from_contents_and_address (type, 0, address);
7476 /* A value representing VAL, but with a standard (static-sized) type
7477 that correctly describes it. Does not necessarily create a new
7480 static struct value *
7481 ada_to_fixed_value (struct value *val)
7483 return ada_to_fixed_value_create (value_type (val),
7484 VALUE_ADDRESS (val) + value_offset (val),
7488 /* A value representing VAL, but with a standard (static-sized) type
7489 chosen to approximate the real type of VAL as well as possible, but
7490 without consulting any runtime values. For Ada dynamic-sized
7491 types, therefore, the type of the result is likely to be inaccurate. */
7493 static struct value *
7494 ada_to_static_fixed_value (struct value *val)
7497 to_static_fixed_type (static_unwrap_type (value_type (val)));
7498 if (type == value_type (val))
7501 return coerce_unspec_val_to_type (val, type);
7507 /* Table mapping attribute numbers to names.
7508 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7510 static const char *attribute_names[] = {
7528 ada_attribute_name (enum exp_opcode n)
7530 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
7531 return attribute_names[n - OP_ATR_FIRST + 1];
7533 return attribute_names[0];
7536 /* Evaluate the 'POS attribute applied to ARG. */
7539 pos_atr (struct value *arg)
7541 struct value *val = coerce_ref (arg);
7542 struct type *type = value_type (val);
7544 if (!discrete_type_p (type))
7545 error (_("'POS only defined on discrete types"));
7547 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7550 LONGEST v = value_as_long (val);
7552 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7554 if (v == TYPE_FIELD_BITPOS (type, i))
7557 error (_("enumeration value is invalid: can't find 'POS"));
7560 return value_as_long (val);
7563 static struct value *
7564 value_pos_atr (struct type *type, struct value *arg)
7566 return value_from_longest (type, pos_atr (arg));
7569 /* Evaluate the TYPE'VAL attribute applied to ARG. */
7571 static struct value *
7572 value_val_atr (struct type *type, struct value *arg)
7574 if (!discrete_type_p (type))
7575 error (_("'VAL only defined on discrete types"));
7576 if (!integer_type_p (value_type (arg)))
7577 error (_("'VAL requires integral argument"));
7579 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7581 long pos = value_as_long (arg);
7582 if (pos < 0 || pos >= TYPE_NFIELDS (type))
7583 error (_("argument to 'VAL out of range"));
7584 return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
7587 return value_from_longest (type, value_as_long (arg));
7593 /* True if TYPE appears to be an Ada character type.
7594 [At the moment, this is true only for Character and Wide_Character;
7595 It is a heuristic test that could stand improvement]. */
7598 ada_is_character_type (struct type *type)
7602 /* If the type code says it's a character, then assume it really is,
7603 and don't check any further. */
7604 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
7607 /* Otherwise, assume it's a character type iff it is a discrete type
7608 with a known character type name. */
7609 name = ada_type_name (type);
7610 return (name != NULL
7611 && (TYPE_CODE (type) == TYPE_CODE_INT
7612 || TYPE_CODE (type) == TYPE_CODE_RANGE)
7613 && (strcmp (name, "character") == 0
7614 || strcmp (name, "wide_character") == 0
7615 || strcmp (name, "wide_wide_character") == 0
7616 || strcmp (name, "unsigned char") == 0));
7619 /* True if TYPE appears to be an Ada string type. */
7622 ada_is_string_type (struct type *type)
7624 type = ada_check_typedef (type);
7626 && TYPE_CODE (type) != TYPE_CODE_PTR
7627 && (ada_is_simple_array_type (type)
7628 || ada_is_array_descriptor_type (type))
7629 && ada_array_arity (type) == 1)
7631 struct type *elttype = ada_array_element_type (type, 1);
7633 return ada_is_character_type (elttype);
7640 /* True if TYPE is a struct type introduced by the compiler to force the
7641 alignment of a value. Such types have a single field with a
7642 distinctive name. */
7645 ada_is_aligner_type (struct type *type)
7647 type = ada_check_typedef (type);
7649 /* If we can find a parallel XVS type, then the XVS type should
7650 be used instead of this type. And hence, this is not an aligner
7652 if (ada_find_parallel_type (type, "___XVS") != NULL)
7655 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
7656 && TYPE_NFIELDS (type) == 1
7657 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
7660 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7661 the parallel type. */
7664 ada_get_base_type (struct type *raw_type)
7666 struct type *real_type_namer;
7667 struct type *raw_real_type;
7669 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
7672 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
7673 if (real_type_namer == NULL
7674 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
7675 || TYPE_NFIELDS (real_type_namer) != 1)
7678 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
7679 if (raw_real_type == NULL)
7682 return raw_real_type;
7685 /* The type of value designated by TYPE, with all aligners removed. */
7688 ada_aligned_type (struct type *type)
7690 if (ada_is_aligner_type (type))
7691 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
7693 return ada_get_base_type (type);
7697 /* The address of the aligned value in an object at address VALADDR
7698 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7701 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
7703 if (ada_is_aligner_type (type))
7704 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
7706 TYPE_FIELD_BITPOS (type,
7707 0) / TARGET_CHAR_BIT);
7714 /* The printed representation of an enumeration literal with encoded
7715 name NAME. The value is good to the next call of ada_enum_name. */
7717 ada_enum_name (const char *name)
7719 static char *result;
7720 static size_t result_len = 0;
7723 /* First, unqualify the enumeration name:
7724 1. Search for the last '.' character. If we find one, then skip
7725 all the preceeding characters, the unqualified name starts
7726 right after that dot.
7727 2. Otherwise, we may be debugging on a target where the compiler
7728 translates dots into "__". Search forward for double underscores,
7729 but stop searching when we hit an overloading suffix, which is
7730 of the form "__" followed by digits. */
7732 tmp = strrchr (name, '.');
7737 while ((tmp = strstr (name, "__")) != NULL)
7739 if (isdigit (tmp[2]))
7749 if (name[1] == 'U' || name[1] == 'W')
7751 if (sscanf (name + 2, "%x", &v) != 1)
7757 GROW_VECT (result, result_len, 16);
7758 if (isascii (v) && isprint (v))
7759 sprintf (result, "'%c'", v);
7760 else if (name[1] == 'U')
7761 sprintf (result, "[\"%02x\"]", v);
7763 sprintf (result, "[\"%04x\"]", v);
7769 tmp = strstr (name, "__");
7771 tmp = strstr (name, "$");
7774 GROW_VECT (result, result_len, tmp - name + 1);
7775 strncpy (result, name, tmp - name);
7776 result[tmp - name] = '\0';
7784 static struct value *
7785 evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos,
7788 return (*exp->language_defn->la_exp_desc->evaluate_exp)
7789 (expect_type, exp, pos, noside);
7792 /* Evaluate the subexpression of EXP starting at *POS as for
7793 evaluate_type, updating *POS to point just past the evaluated
7796 static struct value *
7797 evaluate_subexp_type (struct expression *exp, int *pos)
7799 return (*exp->language_defn->la_exp_desc->evaluate_exp)
7800 (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
7803 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7806 static struct value *
7807 unwrap_value (struct value *val)
7809 struct type *type = ada_check_typedef (value_type (val));
7810 if (ada_is_aligner_type (type))
7812 struct value *v = ada_value_struct_elt (val, "F", 0);
7813 struct type *val_type = ada_check_typedef (value_type (v));
7814 if (ada_type_name (val_type) == NULL)
7815 TYPE_NAME (val_type) = ada_type_name (type);
7817 return unwrap_value (v);
7821 struct type *raw_real_type =
7822 ada_check_typedef (ada_get_base_type (type));
7824 if (type == raw_real_type)
7828 coerce_unspec_val_to_type
7829 (val, ada_to_fixed_type (raw_real_type, 0,
7830 VALUE_ADDRESS (val) + value_offset (val),
7835 static struct value *
7836 cast_to_fixed (struct type *type, struct value *arg)
7840 if (type == value_type (arg))
7842 else if (ada_is_fixed_point_type (value_type (arg)))
7843 val = ada_float_to_fixed (type,
7844 ada_fixed_to_float (value_type (arg),
7845 value_as_long (arg)));
7848 DOUBLEST argd = value_as_double (arg);
7849 val = ada_float_to_fixed (type, argd);
7852 return value_from_longest (type, val);
7855 static struct value *
7856 cast_from_fixed (struct type *type, struct value *arg)
7858 DOUBLEST val = ada_fixed_to_float (value_type (arg),
7859 value_as_long (arg));
7860 return value_from_double (type, val);
7863 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7864 return the converted value. */
7866 static struct value *
7867 coerce_for_assign (struct type *type, struct value *val)
7869 struct type *type2 = value_type (val);
7873 type2 = ada_check_typedef (type2);
7874 type = ada_check_typedef (type);
7876 if (TYPE_CODE (type2) == TYPE_CODE_PTR
7877 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7879 val = ada_value_ind (val);
7880 type2 = value_type (val);
7883 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
7884 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7886 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
7887 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
7888 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
7889 error (_("Incompatible types in assignment"));
7890 deprecated_set_value_type (val, type);
7895 static struct value *
7896 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
7899 struct type *type1, *type2;
7902 arg1 = coerce_ref (arg1);
7903 arg2 = coerce_ref (arg2);
7904 type1 = base_type (ada_check_typedef (value_type (arg1)));
7905 type2 = base_type (ada_check_typedef (value_type (arg2)));
7907 if (TYPE_CODE (type1) != TYPE_CODE_INT
7908 || TYPE_CODE (type2) != TYPE_CODE_INT)
7909 return value_binop (arg1, arg2, op);
7918 return value_binop (arg1, arg2, op);
7921 v2 = value_as_long (arg2);
7923 error (_("second operand of %s must not be zero."), op_string (op));
7925 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
7926 return value_binop (arg1, arg2, op);
7928 v1 = value_as_long (arg1);
7933 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
7934 v += v > 0 ? -1 : 1;
7942 /* Should not reach this point. */
7946 val = allocate_value (type1);
7947 store_unsigned_integer (value_contents_raw (val),
7948 TYPE_LENGTH (value_type (val)), v);
7953 ada_value_equal (struct value *arg1, struct value *arg2)
7955 if (ada_is_direct_array_type (value_type (arg1))
7956 || ada_is_direct_array_type (value_type (arg2)))
7958 /* Automatically dereference any array reference before
7959 we attempt to perform the comparison. */
7960 arg1 = ada_coerce_ref (arg1);
7961 arg2 = ada_coerce_ref (arg2);
7963 arg1 = ada_coerce_to_simple_array (arg1);
7964 arg2 = ada_coerce_to_simple_array (arg2);
7965 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
7966 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
7967 error (_("Attempt to compare array with non-array"));
7968 /* FIXME: The following works only for types whose
7969 representations use all bits (no padding or undefined bits)
7970 and do not have user-defined equality. */
7972 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
7973 && memcmp (value_contents (arg1), value_contents (arg2),
7974 TYPE_LENGTH (value_type (arg1))) == 0;
7976 return value_equal (arg1, arg2);
7979 /* Total number of component associations in the aggregate starting at
7980 index PC in EXP. Assumes that index PC is the start of an
7984 num_component_specs (struct expression *exp, int pc)
7987 m = exp->elts[pc + 1].longconst;
7990 for (i = 0; i < m; i += 1)
7992 switch (exp->elts[pc].opcode)
7998 n += exp->elts[pc + 1].longconst;
8001 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
8006 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
8007 component of LHS (a simple array or a record), updating *POS past
8008 the expression, assuming that LHS is contained in CONTAINER. Does
8009 not modify the inferior's memory, nor does it modify LHS (unless
8010 LHS == CONTAINER). */
8013 assign_component (struct value *container, struct value *lhs, LONGEST index,
8014 struct expression *exp, int *pos)
8016 struct value *mark = value_mark ();
8018 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
8020 struct value *index_val = value_from_longest (builtin_type_int32, index);
8021 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
8025 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
8026 elt = ada_to_fixed_value (unwrap_value (elt));
8029 if (exp->elts[*pos].opcode == OP_AGGREGATE)
8030 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
8032 value_assign_to_component (container, elt,
8033 ada_evaluate_subexp (NULL, exp, pos,
8036 value_free_to_mark (mark);
8039 /* Assuming that LHS represents an lvalue having a record or array
8040 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8041 of that aggregate's value to LHS, advancing *POS past the
8042 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8043 lvalue containing LHS (possibly LHS itself). Does not modify
8044 the inferior's memory, nor does it modify the contents of
8045 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
8047 static struct value *
8048 assign_aggregate (struct value *container,
8049 struct value *lhs, struct expression *exp,
8050 int *pos, enum noside noside)
8052 struct type *lhs_type;
8053 int n = exp->elts[*pos+1].longconst;
8054 LONGEST low_index, high_index;
8057 int max_indices, num_indices;
8058 int is_array_aggregate;
8060 struct value *mark = value_mark ();
8063 if (noside != EVAL_NORMAL)
8066 for (i = 0; i < n; i += 1)
8067 ada_evaluate_subexp (NULL, exp, pos, noside);
8071 container = ada_coerce_ref (container);
8072 if (ada_is_direct_array_type (value_type (container)))
8073 container = ada_coerce_to_simple_array (container);
8074 lhs = ada_coerce_ref (lhs);
8075 if (!deprecated_value_modifiable (lhs))
8076 error (_("Left operand of assignment is not a modifiable lvalue."));
8078 lhs_type = value_type (lhs);
8079 if (ada_is_direct_array_type (lhs_type))
8081 lhs = ada_coerce_to_simple_array (lhs);
8082 lhs_type = value_type (lhs);
8083 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
8084 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
8085 is_array_aggregate = 1;
8087 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
8090 high_index = num_visible_fields (lhs_type) - 1;
8091 is_array_aggregate = 0;
8094 error (_("Left-hand side must be array or record."));
8096 num_specs = num_component_specs (exp, *pos - 3);
8097 max_indices = 4 * num_specs + 4;
8098 indices = alloca (max_indices * sizeof (indices[0]));
8099 indices[0] = indices[1] = low_index - 1;
8100 indices[2] = indices[3] = high_index + 1;
8103 for (i = 0; i < n; i += 1)
8105 switch (exp->elts[*pos].opcode)
8108 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
8109 &num_indices, max_indices,
8110 low_index, high_index);
8113 aggregate_assign_positional (container, lhs, exp, pos, indices,
8114 &num_indices, max_indices,
8115 low_index, high_index);
8119 error (_("Misplaced 'others' clause"));
8120 aggregate_assign_others (container, lhs, exp, pos, indices,
8121 num_indices, low_index, high_index);
8124 error (_("Internal error: bad aggregate clause"));
8131 /* Assign into the component of LHS indexed by the OP_POSITIONAL
8132 construct at *POS, updating *POS past the construct, given that
8133 the positions are relative to lower bound LOW, where HIGH is the
8134 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8135 updating *NUM_INDICES as needed. CONTAINER is as for
8136 assign_aggregate. */
8138 aggregate_assign_positional (struct value *container,
8139 struct value *lhs, struct expression *exp,
8140 int *pos, LONGEST *indices, int *num_indices,
8141 int max_indices, LONGEST low, LONGEST high)
8143 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
8145 if (ind - 1 == high)
8146 warning (_("Extra components in aggregate ignored."));
8149 add_component_interval (ind, ind, indices, num_indices, max_indices);
8151 assign_component (container, lhs, ind, exp, pos);
8154 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8157 /* Assign into the components of LHS indexed by the OP_CHOICES
8158 construct at *POS, updating *POS past the construct, given that
8159 the allowable indices are LOW..HIGH. Record the indices assigned
8160 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8161 needed. CONTAINER is as for assign_aggregate. */
8163 aggregate_assign_from_choices (struct value *container,
8164 struct value *lhs, struct expression *exp,
8165 int *pos, LONGEST *indices, int *num_indices,
8166 int max_indices, LONGEST low, LONGEST high)
8169 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
8170 int choice_pos, expr_pc;
8171 int is_array = ada_is_direct_array_type (value_type (lhs));
8173 choice_pos = *pos += 3;
8175 for (j = 0; j < n_choices; j += 1)
8176 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8178 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8180 for (j = 0; j < n_choices; j += 1)
8182 LONGEST lower, upper;
8183 enum exp_opcode op = exp->elts[choice_pos].opcode;
8184 if (op == OP_DISCRETE_RANGE)
8187 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8189 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8194 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
8205 name = &exp->elts[choice_pos + 2].string;
8208 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
8211 error (_("Invalid record component association."));
8213 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
8215 if (! find_struct_field (name, value_type (lhs), 0,
8216 NULL, NULL, NULL, NULL, &ind))
8217 error (_("Unknown component name: %s."), name);
8218 lower = upper = ind;
8221 if (lower <= upper && (lower < low || upper > high))
8222 error (_("Index in component association out of bounds."));
8224 add_component_interval (lower, upper, indices, num_indices,
8226 while (lower <= upper)
8230 assign_component (container, lhs, lower, exp, &pos1);
8236 /* Assign the value of the expression in the OP_OTHERS construct in
8237 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8238 have not been previously assigned. The index intervals already assigned
8239 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8240 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
8242 aggregate_assign_others (struct value *container,
8243 struct value *lhs, struct expression *exp,
8244 int *pos, LONGEST *indices, int num_indices,
8245 LONGEST low, LONGEST high)
8248 int expr_pc = *pos+1;
8250 for (i = 0; i < num_indices - 2; i += 2)
8253 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
8257 assign_component (container, lhs, ind, exp, &pos);
8260 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8263 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
8264 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8265 modifying *SIZE as needed. It is an error if *SIZE exceeds
8266 MAX_SIZE. The resulting intervals do not overlap. */
8268 add_component_interval (LONGEST low, LONGEST high,
8269 LONGEST* indices, int *size, int max_size)
8272 for (i = 0; i < *size; i += 2) {
8273 if (high >= indices[i] && low <= indices[i + 1])
8276 for (kh = i + 2; kh < *size; kh += 2)
8277 if (high < indices[kh])
8279 if (low < indices[i])
8281 indices[i + 1] = indices[kh - 1];
8282 if (high > indices[i + 1])
8283 indices[i + 1] = high;
8284 memcpy (indices + i + 2, indices + kh, *size - kh);
8285 *size -= kh - i - 2;
8288 else if (high < indices[i])
8292 if (*size == max_size)
8293 error (_("Internal error: miscounted aggregate components."));
8295 for (j = *size-1; j >= i+2; j -= 1)
8296 indices[j] = indices[j - 2];
8298 indices[i + 1] = high;
8301 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8304 static struct value *
8305 ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
8307 if (type == ada_check_typedef (value_type (arg2)))
8310 if (ada_is_fixed_point_type (type))
8311 return (cast_to_fixed (type, arg2));
8313 if (ada_is_fixed_point_type (value_type (arg2)))
8314 return cast_from_fixed (type, arg2);
8316 return value_cast (type, arg2);
8319 static struct value *
8320 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
8321 int *pos, enum noside noside)
8324 int tem, tem2, tem3;
8326 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
8329 struct value **argvec;
8333 op = exp->elts[pc].opcode;
8339 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
8340 arg1 = unwrap_value (arg1);
8342 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8343 then we need to perform the conversion manually, because
8344 evaluate_subexp_standard doesn't do it. This conversion is
8345 necessary in Ada because the different kinds of float/fixed
8346 types in Ada have different representations.
8348 Similarly, we need to perform the conversion from OP_LONG
8350 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
8351 arg1 = ada_value_cast (expect_type, arg1, noside);
8357 struct value *result;
8359 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
8360 /* The result type will have code OP_STRING, bashed there from
8361 OP_ARRAY. Bash it back. */
8362 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
8363 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
8369 type = exp->elts[pc + 1].type;
8370 arg1 = evaluate_subexp (type, exp, pos, noside);
8371 if (noside == EVAL_SKIP)
8373 arg1 = ada_value_cast (type, arg1, noside);
8378 type = exp->elts[pc + 1].type;
8379 return ada_evaluate_subexp (type, exp, pos, noside);
8382 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8383 if (exp->elts[*pos].opcode == OP_AGGREGATE)
8385 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
8386 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
8388 return ada_value_assign (arg1, arg1);
8390 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8391 except if the lhs of our assignment is a convenience variable.
8392 In the case of assigning to a convenience variable, the lhs
8393 should be exactly the result of the evaluation of the rhs. */
8394 type = value_type (arg1);
8395 if (VALUE_LVAL (arg1) == lval_internalvar)
8397 arg2 = evaluate_subexp (type, exp, pos, noside);
8398 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
8400 if (ada_is_fixed_point_type (value_type (arg1)))
8401 arg2 = cast_to_fixed (value_type (arg1), arg2);
8402 else if (ada_is_fixed_point_type (value_type (arg2)))
8404 (_("Fixed-point values must be assigned to fixed-point variables"));
8406 arg2 = coerce_for_assign (value_type (arg1), arg2);
8407 return ada_value_assign (arg1, arg2);
8410 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8411 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8412 if (noside == EVAL_SKIP)
8414 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
8415 return (value_from_longest
8417 value_as_long (arg1) + value_as_long (arg2)));
8418 if ((ada_is_fixed_point_type (value_type (arg1))
8419 || ada_is_fixed_point_type (value_type (arg2)))
8420 && value_type (arg1) != value_type (arg2))
8421 error (_("Operands of fixed-point addition must have the same type"));
8422 /* Do the addition, and cast the result to the type of the first
8423 argument. We cannot cast the result to a reference type, so if
8424 ARG1 is a reference type, find its underlying type. */
8425 type = value_type (arg1);
8426 while (TYPE_CODE (type) == TYPE_CODE_REF)
8427 type = TYPE_TARGET_TYPE (type);
8428 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8429 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
8432 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8433 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8434 if (noside == EVAL_SKIP)
8436 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
8437 return (value_from_longest
8439 value_as_long (arg1) - value_as_long (arg2)));
8440 if ((ada_is_fixed_point_type (value_type (arg1))
8441 || ada_is_fixed_point_type (value_type (arg2)))
8442 && value_type (arg1) != value_type (arg2))
8443 error (_("Operands of fixed-point subtraction must have the same type"));
8444 /* Do the substraction, and cast the result to the type of the first
8445 argument. We cannot cast the result to a reference type, so if
8446 ARG1 is a reference type, find its underlying type. */
8447 type = value_type (arg1);
8448 while (TYPE_CODE (type) == TYPE_CODE_REF)
8449 type = TYPE_TARGET_TYPE (type);
8450 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8451 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
8455 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8456 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8457 if (noside == EVAL_SKIP)
8459 else if (noside == EVAL_AVOID_SIDE_EFFECTS
8460 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
8462 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8463 return value_zero (value_type (arg1), not_lval);
8467 type = builtin_type (exp->gdbarch)->builtin_double;
8468 if (ada_is_fixed_point_type (value_type (arg1)))
8469 arg1 = cast_from_fixed (type, arg1);
8470 if (ada_is_fixed_point_type (value_type (arg2)))
8471 arg2 = cast_from_fixed (type, arg2);
8472 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8473 return ada_value_binop (arg1, arg2, op);
8478 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8479 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8480 if (noside == EVAL_SKIP)
8482 else if (noside == EVAL_AVOID_SIDE_EFFECTS
8483 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
8484 return value_zero (value_type (arg1), not_lval);
8487 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8488 return ada_value_binop (arg1, arg2, op);
8492 case BINOP_NOTEQUAL:
8493 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8494 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
8495 if (noside == EVAL_SKIP)
8497 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8501 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8502 tem = ada_value_equal (arg1, arg2);
8504 if (op == BINOP_NOTEQUAL)
8506 type = language_bool_type (exp->language_defn, exp->gdbarch);
8507 return value_from_longest (type, (LONGEST) tem);
8510 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8511 if (noside == EVAL_SKIP)
8513 else if (ada_is_fixed_point_type (value_type (arg1)))
8514 return value_cast (value_type (arg1), value_neg (arg1));
8517 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
8518 return value_neg (arg1);
8521 case BINOP_LOGICAL_AND:
8522 case BINOP_LOGICAL_OR:
8523 case UNOP_LOGICAL_NOT:
8528 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8529 type = language_bool_type (exp->language_defn, exp->gdbarch);
8530 return value_cast (type, val);
8533 case BINOP_BITWISE_AND:
8534 case BINOP_BITWISE_IOR:
8535 case BINOP_BITWISE_XOR:
8539 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
8541 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8543 return value_cast (value_type (arg1), val);
8549 if (noside == EVAL_SKIP)
8554 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
8555 /* Only encountered when an unresolved symbol occurs in a
8556 context other than a function call, in which case, it is
8558 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8559 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
8560 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8562 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
8563 if (ada_is_tagged_type (type, 0))
8565 /* Tagged types are a little special in the fact that the real
8566 type is dynamic and can only be determined by inspecting the
8567 object's tag. This means that we need to get the object's
8568 value first (EVAL_NORMAL) and then extract the actual object
8571 Note that we cannot skip the final step where we extract
8572 the object type from its tag, because the EVAL_NORMAL phase
8573 results in dynamic components being resolved into fixed ones.
8574 This can cause problems when trying to print the type
8575 description of tagged types whose parent has a dynamic size:
8576 We use the type name of the "_parent" component in order
8577 to print the name of the ancestor type in the type description.
8578 If that component had a dynamic size, the resolution into
8579 a fixed type would result in the loss of that type name,
8580 thus preventing us from printing the name of the ancestor
8581 type in the type description. */
8582 struct type *actual_type;
8584 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
8585 actual_type = type_from_tag (ada_value_tag (arg1));
8586 if (actual_type == NULL)
8587 /* If, for some reason, we were unable to determine
8588 the actual type from the tag, then use the static
8589 approximation that we just computed as a fallback.
8590 This can happen if the debugging information is
8591 incomplete, for instance. */
8594 return value_zero (actual_type, not_lval);
8599 (to_static_fixed_type
8600 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
8606 unwrap_value (evaluate_subexp_standard
8607 (expect_type, exp, pos, noside));
8608 return ada_to_fixed_value (arg1);
8614 /* Allocate arg vector, including space for the function to be
8615 called in argvec[0] and a terminating NULL. */
8616 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8618 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
8620 if (exp->elts[*pos].opcode == OP_VAR_VALUE
8621 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
8622 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8623 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
8626 for (tem = 0; tem <= nargs; tem += 1)
8627 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8630 if (noside == EVAL_SKIP)
8634 if (ada_is_packed_array_type (desc_base_type (value_type (argvec[0]))))
8635 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
8636 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
8637 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
8638 && VALUE_LVAL (argvec[0]) == lval_memory))
8639 argvec[0] = value_addr (argvec[0]);
8641 type = ada_check_typedef (value_type (argvec[0]));
8642 if (TYPE_CODE (type) == TYPE_CODE_PTR)
8644 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
8646 case TYPE_CODE_FUNC:
8647 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8649 case TYPE_CODE_ARRAY:
8651 case TYPE_CODE_STRUCT:
8652 if (noside != EVAL_AVOID_SIDE_EFFECTS)
8653 argvec[0] = ada_value_ind (argvec[0]);
8654 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8657 error (_("cannot subscript or call something of type `%s'"),
8658 ada_type_name (value_type (argvec[0])));
8663 switch (TYPE_CODE (type))
8665 case TYPE_CODE_FUNC:
8666 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8667 return allocate_value (TYPE_TARGET_TYPE (type));
8668 return call_function_by_hand (argvec[0], nargs, argvec + 1);
8669 case TYPE_CODE_STRUCT:
8673 arity = ada_array_arity (type);
8674 type = ada_array_element_type (type, nargs);
8676 error (_("cannot subscript or call a record"));
8678 error (_("wrong number of subscripts; expecting %d"), arity);
8679 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8680 return value_zero (ada_aligned_type (type), lval_memory);
8682 unwrap_value (ada_value_subscript
8683 (argvec[0], nargs, argvec + 1));
8685 case TYPE_CODE_ARRAY:
8686 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8688 type = ada_array_element_type (type, nargs);
8690 error (_("element type of array unknown"));
8692 return value_zero (ada_aligned_type (type), lval_memory);
8695 unwrap_value (ada_value_subscript
8696 (ada_coerce_to_simple_array (argvec[0]),
8697 nargs, argvec + 1));
8698 case TYPE_CODE_PTR: /* Pointer to array */
8699 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
8700 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8702 type = ada_array_element_type (type, nargs);
8704 error (_("element type of array unknown"));
8706 return value_zero (ada_aligned_type (type), lval_memory);
8709 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
8710 nargs, argvec + 1));
8713 error (_("Attempt to index or call something other than an "
8714 "array or function"));
8719 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8720 struct value *low_bound_val =
8721 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8722 struct value *high_bound_val =
8723 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8726 low_bound_val = coerce_ref (low_bound_val);
8727 high_bound_val = coerce_ref (high_bound_val);
8728 low_bound = pos_atr (low_bound_val);
8729 high_bound = pos_atr (high_bound_val);
8731 if (noside == EVAL_SKIP)
8734 /* If this is a reference to an aligner type, then remove all
8736 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8737 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
8738 TYPE_TARGET_TYPE (value_type (array)) =
8739 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
8741 if (ada_is_packed_array_type (value_type (array)))
8742 error (_("cannot slice a packed array"));
8744 /* If this is a reference to an array or an array lvalue,
8745 convert to a pointer. */
8746 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8747 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
8748 && VALUE_LVAL (array) == lval_memory))
8749 array = value_addr (array);
8751 if (noside == EVAL_AVOID_SIDE_EFFECTS
8752 && ada_is_array_descriptor_type (ada_check_typedef
8753 (value_type (array))))
8754 return empty_array (ada_type_of_array (array, 0), low_bound);
8756 array = ada_coerce_to_simple_array_ptr (array);
8758 /* If we have more than one level of pointer indirection,
8759 dereference the value until we get only one level. */
8760 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
8761 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
8763 array = value_ind (array);
8765 /* Make sure we really do have an array type before going further,
8766 to avoid a SEGV when trying to get the index type or the target
8767 type later down the road if the debug info generated by
8768 the compiler is incorrect or incomplete. */
8769 if (!ada_is_simple_array_type (value_type (array)))
8770 error (_("cannot take slice of non-array"));
8772 if (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR)
8774 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
8775 return empty_array (TYPE_TARGET_TYPE (value_type (array)),
8779 struct type *arr_type0 =
8780 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array)),
8782 return ada_value_slice_from_ptr (array, arr_type0,
8783 longest_to_int (low_bound),
8784 longest_to_int (high_bound));
8787 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8789 else if (high_bound < low_bound)
8790 return empty_array (value_type (array), low_bound);
8792 return ada_value_slice (array, longest_to_int (low_bound),
8793 longest_to_int (high_bound));
8798 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8799 type = exp->elts[pc + 1].type;
8801 if (noside == EVAL_SKIP)
8804 switch (TYPE_CODE (type))
8807 lim_warning (_("Membership test incompletely implemented; "
8808 "always returns true"));
8809 type = language_bool_type (exp->language_defn, exp->gdbarch);
8810 return value_from_longest (type, (LONGEST) 1);
8812 case TYPE_CODE_RANGE:
8813 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
8814 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
8815 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8816 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
8817 type = language_bool_type (exp->language_defn, exp->gdbarch);
8819 value_from_longest (type,
8820 (value_less (arg1, arg3)
8821 || value_equal (arg1, arg3))
8822 && (value_less (arg2, arg1)
8823 || value_equal (arg2, arg1)));
8826 case BINOP_IN_BOUNDS:
8828 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8829 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8831 if (noside == EVAL_SKIP)
8834 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8836 type = language_bool_type (exp->language_defn, exp->gdbarch);
8837 return value_zero (type, not_lval);
8840 tem = longest_to_int (exp->elts[pc + 1].longconst);
8842 if (tem < 1 || tem > ada_array_arity (value_type (arg2)))
8843 error (_("invalid dimension number to 'range"));
8845 arg3 = ada_array_bound (arg2, tem, 1);
8846 arg2 = ada_array_bound (arg2, tem, 0);
8848 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8849 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
8850 type = language_bool_type (exp->language_defn, exp->gdbarch);
8852 value_from_longest (type,
8853 (value_less (arg1, arg3)
8854 || value_equal (arg1, arg3))
8855 && (value_less (arg2, arg1)
8856 || value_equal (arg2, arg1)));
8858 case TERNOP_IN_RANGE:
8859 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8860 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8861 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8863 if (noside == EVAL_SKIP)
8866 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8867 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
8868 type = language_bool_type (exp->language_defn, exp->gdbarch);
8870 value_from_longest (type,
8871 (value_less (arg1, arg3)
8872 || value_equal (arg1, arg3))
8873 && (value_less (arg2, arg1)
8874 || value_equal (arg2, arg1)));
8880 struct type *type_arg;
8881 if (exp->elts[*pos].opcode == OP_TYPE)
8883 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
8885 type_arg = exp->elts[pc + 2].type;
8889 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8893 if (exp->elts[*pos].opcode != OP_LONG)
8894 error (_("Invalid operand to '%s"), ada_attribute_name (op));
8895 tem = longest_to_int (exp->elts[*pos + 2].longconst);
8898 if (noside == EVAL_SKIP)
8901 if (type_arg == NULL)
8903 arg1 = ada_coerce_ref (arg1);
8905 if (ada_is_packed_array_type (value_type (arg1)))
8906 arg1 = ada_coerce_to_simple_array (arg1);
8908 if (tem < 1 || tem > ada_array_arity (value_type (arg1)))
8909 error (_("invalid dimension number to '%s"),
8910 ada_attribute_name (op));
8912 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8914 type = ada_index_type (value_type (arg1), tem);
8917 (_("attempt to take bound of something that is not an array"));
8918 return allocate_value (type);
8923 default: /* Should never happen. */
8924 error (_("unexpected attribute encountered"));
8926 return ada_array_bound (arg1, tem, 0);
8928 return ada_array_bound (arg1, tem, 1);
8930 return ada_array_length (arg1, tem);
8933 else if (discrete_type_p (type_arg))
8935 struct type *range_type;
8936 char *name = ada_type_name (type_arg);
8938 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
8940 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
8941 if (range_type == NULL)
8942 range_type = type_arg;
8946 error (_("unexpected attribute encountered"));
8948 return value_from_longest
8949 (range_type, discrete_type_low_bound (range_type));
8951 return value_from_longest
8952 (range_type, discrete_type_high_bound (range_type));
8954 error (_("the 'length attribute applies only to array types"));
8957 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
8958 error (_("unimplemented type attribute"));
8963 if (ada_is_packed_array_type (type_arg))
8964 type_arg = decode_packed_array_type (type_arg);
8966 if (tem < 1 || tem > ada_array_arity (type_arg))
8967 error (_("invalid dimension number to '%s"),
8968 ada_attribute_name (op));
8970 type = ada_index_type (type_arg, tem);
8973 (_("attempt to take bound of something that is not an array"));
8974 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8975 return allocate_value (type);
8980 error (_("unexpected attribute encountered"));
8982 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
8983 return value_from_longest (type, low);
8985 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
8986 return value_from_longest (type, high);
8988 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
8989 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
8990 return value_from_longest (type, high - low + 1);
8996 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8997 if (noside == EVAL_SKIP)
9000 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9001 return value_zero (ada_tag_type (arg1), not_lval);
9003 return ada_value_tag (arg1);
9007 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9008 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9009 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9010 if (noside == EVAL_SKIP)
9012 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9013 return value_zero (value_type (arg1), not_lval);
9016 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9017 return value_binop (arg1, arg2,
9018 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
9021 case OP_ATR_MODULUS:
9023 struct type *type_arg = exp->elts[pc + 2].type;
9024 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9026 if (noside == EVAL_SKIP)
9029 if (!ada_is_modular_type (type_arg))
9030 error (_("'modulus must be applied to modular type"));
9032 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
9033 ada_modulus (type_arg));
9038 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9039 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9040 if (noside == EVAL_SKIP)
9042 type = builtin_type (exp->gdbarch)->builtin_int;
9043 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9044 return value_zero (type, not_lval);
9046 return value_pos_atr (type, arg1);
9049 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9050 type = value_type (arg1);
9052 /* If the argument is a reference, then dereference its type, since
9053 the user is really asking for the size of the actual object,
9054 not the size of the pointer. */
9055 if (TYPE_CODE (type) == TYPE_CODE_REF)
9056 type = TYPE_TARGET_TYPE (type);
9058 if (noside == EVAL_SKIP)
9060 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9061 return value_zero (builtin_type_int32, not_lval);
9063 return value_from_longest (builtin_type_int32,
9064 TARGET_CHAR_BIT * TYPE_LENGTH (type));
9067 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9068 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9069 type = exp->elts[pc + 2].type;
9070 if (noside == EVAL_SKIP)
9072 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9073 return value_zero (type, not_lval);
9075 return value_val_atr (type, arg1);
9078 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9079 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9080 if (noside == EVAL_SKIP)
9082 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9083 return value_zero (value_type (arg1), not_lval);
9086 /* For integer exponentiation operations,
9087 only promote the first argument. */
9088 if (is_integral_type (value_type (arg2)))
9089 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9091 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9093 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 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9108 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
9109 return value_neg (arg1);
9114 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9115 if (noside == EVAL_SKIP)
9117 type = ada_check_typedef (value_type (arg1));
9118 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9120 if (ada_is_array_descriptor_type (type))
9121 /* GDB allows dereferencing GNAT array descriptors. */
9123 struct type *arrType = ada_type_of_array (arg1, 0);
9124 if (arrType == NULL)
9125 error (_("Attempt to dereference null array pointer."));
9126 return value_at_lazy (arrType, 0);
9128 else if (TYPE_CODE (type) == TYPE_CODE_PTR
9129 || TYPE_CODE (type) == TYPE_CODE_REF
9130 /* In C you can dereference an array to get the 1st elt. */
9131 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
9133 type = to_static_fixed_type
9135 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
9137 return value_zero (type, lval_memory);
9139 else if (TYPE_CODE (type) == TYPE_CODE_INT)
9141 /* GDB allows dereferencing an int. */
9142 if (expect_type == NULL)
9143 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
9148 to_static_fixed_type (ada_aligned_type (expect_type));
9149 return value_zero (expect_type, lval_memory);
9153 error (_("Attempt to take contents of a non-pointer value."));
9155 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
9156 type = ada_check_typedef (value_type (arg1));
9158 if (TYPE_CODE (type) == TYPE_CODE_INT)
9159 /* GDB allows dereferencing an int. If we were given
9160 the expect_type, then use that as the target type.
9161 Otherwise, assume that the target type is an int. */
9163 if (expect_type != NULL)
9164 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
9167 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
9168 (CORE_ADDR) value_as_address (arg1));
9171 if (ada_is_array_descriptor_type (type))
9172 /* GDB allows dereferencing GNAT array descriptors. */
9173 return ada_coerce_to_simple_array (arg1);
9175 return ada_value_ind (arg1);
9177 case STRUCTOP_STRUCT:
9178 tem = longest_to_int (exp->elts[pc + 1].longconst);
9179 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
9180 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9181 if (noside == EVAL_SKIP)
9183 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9185 struct type *type1 = value_type (arg1);
9186 if (ada_is_tagged_type (type1, 1))
9188 type = ada_lookup_struct_elt_type (type1,
9189 &exp->elts[pc + 2].string,
9192 /* In this case, we assume that the field COULD exist
9193 in some extension of the type. Return an object of
9194 "type" void, which will match any formal
9195 (see ada_type_match). */
9196 return value_zero (builtin_type_void, lval_memory);
9200 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
9203 return value_zero (ada_aligned_type (type), lval_memory);
9207 ada_to_fixed_value (unwrap_value
9208 (ada_value_struct_elt
9209 (arg1, &exp->elts[pc + 2].string, 0)));
9211 /* The value is not supposed to be used. This is here to make it
9212 easier to accommodate expressions that contain types. */
9214 if (noside == EVAL_SKIP)
9216 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9217 return allocate_value (exp->elts[pc + 1].type);
9219 error (_("Attempt to use a type name as an expression"));
9224 case OP_DISCRETE_RANGE:
9227 if (noside == EVAL_NORMAL)
9231 error (_("Undefined name, ambiguous name, or renaming used in "
9232 "component association: %s."), &exp->elts[pc+2].string);
9234 error (_("Aggregates only allowed on the right of an assignment"));
9236 internal_error (__FILE__, __LINE__, _("aggregate apparently mangled"));
9239 ada_forward_operator_length (exp, pc, &oplen, &nargs);
9241 for (tem = 0; tem < nargs; tem += 1)
9242 ada_evaluate_subexp (NULL, exp, pos, noside);
9247 return value_from_longest (builtin_type_int8, (LONGEST) 1);
9253 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9254 type name that encodes the 'small and 'delta information.
9255 Otherwise, return NULL. */
9258 fixed_type_info (struct type *type)
9260 const char *name = ada_type_name (type);
9261 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
9263 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
9265 const char *tail = strstr (name, "___XF_");
9271 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
9272 return fixed_type_info (TYPE_TARGET_TYPE (type));
9277 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9280 ada_is_fixed_point_type (struct type *type)
9282 return fixed_type_info (type) != NULL;
9285 /* Return non-zero iff TYPE represents a System.Address type. */
9288 ada_is_system_address_type (struct type *type)
9290 return (TYPE_NAME (type)
9291 && strcmp (TYPE_NAME (type), "system__address") == 0);
9294 /* Assuming that TYPE is the representation of an Ada fixed-point
9295 type, return its delta, or -1 if the type is malformed and the
9296 delta cannot be determined. */
9299 ada_delta (struct type *type)
9301 const char *encoding = fixed_type_info (type);
9304 /* Strictly speaking, num and den are encoded as integer. However,
9305 they may not fit into a long, and they will have to be converted
9306 to DOUBLEST anyway. So scan them as DOUBLEST. */
9307 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
9314 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9315 factor ('SMALL value) associated with the type. */
9318 scaling_factor (struct type *type)
9320 const char *encoding = fixed_type_info (type);
9321 DOUBLEST num0, den0, num1, den1;
9324 /* Strictly speaking, num's and den's are encoded as integer. However,
9325 they may not fit into a long, and they will have to be converted
9326 to DOUBLEST anyway. So scan them as DOUBLEST. */
9327 n = sscanf (encoding,
9328 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
9329 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
9330 &num0, &den0, &num1, &den1);
9341 /* Assuming that X is the representation of a value of fixed-point
9342 type TYPE, return its floating-point equivalent. */
9345 ada_fixed_to_float (struct type *type, LONGEST x)
9347 return (DOUBLEST) x *scaling_factor (type);
9350 /* The representation of a fixed-point value of type TYPE
9351 corresponding to the value X. */
9354 ada_float_to_fixed (struct type *type, DOUBLEST x)
9356 return (LONGEST) (x / scaling_factor (type) + 0.5);
9360 /* VAX floating formats */
9362 /* Non-zero iff TYPE represents one of the special VAX floating-point
9366 ada_is_vax_floating_type (struct type *type)
9369 (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
9372 && (TYPE_CODE (type) == TYPE_CODE_INT
9373 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9374 && strncmp (ada_type_name (type) + name_len - 6, "___XF", 5) == 0;
9377 /* The type of special VAX floating-point type this is, assuming
9378 ada_is_vax_floating_point. */
9381 ada_vax_float_type_suffix (struct type *type)
9383 return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
9386 /* A value representing the special debugging function that outputs
9387 VAX floating-point values of the type represented by TYPE. Assumes
9388 ada_is_vax_floating_type (TYPE). */
9391 ada_vax_float_print_function (struct type *type)
9393 switch (ada_vax_float_type_suffix (type))
9396 return get_var_value ("DEBUG_STRING_F", 0);
9398 return get_var_value ("DEBUG_STRING_D", 0);
9400 return get_var_value ("DEBUG_STRING_G", 0);
9402 error (_("invalid VAX floating-point type"));
9409 /* Scan STR beginning at position K for a discriminant name, and
9410 return the value of that discriminant field of DVAL in *PX. If
9411 PNEW_K is not null, put the position of the character beyond the
9412 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9413 not alter *PX and *PNEW_K if unsuccessful. */
9416 scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
9419 static char *bound_buffer = NULL;
9420 static size_t bound_buffer_len = 0;
9423 struct value *bound_val;
9425 if (dval == NULL || str == NULL || str[k] == '\0')
9428 pend = strstr (str + k, "__");
9432 k += strlen (bound);
9436 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
9437 bound = bound_buffer;
9438 strncpy (bound_buffer, str + k, pend - (str + k));
9439 bound[pend - (str + k)] = '\0';
9443 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
9444 if (bound_val == NULL)
9447 *px = value_as_long (bound_val);
9453 /* Value of variable named NAME in the current environment. If
9454 no such variable found, then if ERR_MSG is null, returns 0, and
9455 otherwise causes an error with message ERR_MSG. */
9457 static struct value *
9458 get_var_value (char *name, char *err_msg)
9460 struct ada_symbol_info *syms;
9463 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
9468 if (err_msg == NULL)
9471 error (("%s"), err_msg);
9474 return value_of_variable (syms[0].sym, syms[0].block);
9477 /* Value of integer variable named NAME in the current environment. If
9478 no such variable found, returns 0, and sets *FLAG to 0. If
9479 successful, sets *FLAG to 1. */
9482 get_int_var_value (char *name, int *flag)
9484 struct value *var_val = get_var_value (name, 0);
9496 return value_as_long (var_val);
9501 /* Return a range type whose base type is that of the range type named
9502 NAME in the current environment, and whose bounds are calculated
9503 from NAME according to the GNAT range encoding conventions.
9504 Extract discriminant values, if needed, from DVAL. If a new type
9505 must be created, allocate in OBJFILE's space. The bounds
9506 information, in general, is encoded in NAME, the base type given in
9507 the named range type. */
9509 static struct type *
9510 to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
9512 struct type *raw_type = ada_find_any_type (name);
9513 struct type *base_type;
9516 if (raw_type == NULL)
9517 base_type = builtin_type_int32;
9518 else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
9519 base_type = TYPE_TARGET_TYPE (raw_type);
9521 base_type = raw_type;
9523 subtype_info = strstr (name, "___XD");
9524 if (subtype_info == NULL)
9526 LONGEST L = discrete_type_low_bound (raw_type);
9527 LONGEST U = discrete_type_high_bound (raw_type);
9528 if (L < INT_MIN || U > INT_MAX)
9531 return create_range_type (alloc_type (objfile), raw_type,
9532 discrete_type_low_bound (raw_type),
9533 discrete_type_high_bound (raw_type));
9537 static char *name_buf = NULL;
9538 static size_t name_len = 0;
9539 int prefix_len = subtype_info - name;
9545 GROW_VECT (name_buf, name_len, prefix_len + 5);
9546 strncpy (name_buf, name, prefix_len);
9547 name_buf[prefix_len] = '\0';
9550 bounds_str = strchr (subtype_info, '_');
9553 if (*subtype_info == 'L')
9555 if (!ada_scan_number (bounds_str, n, &L, &n)
9556 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
9558 if (bounds_str[n] == '_')
9560 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
9567 strcpy (name_buf + prefix_len, "___L");
9568 L = get_int_var_value (name_buf, &ok);
9571 lim_warning (_("Unknown lower bound, using 1."));
9576 if (*subtype_info == 'U')
9578 if (!ada_scan_number (bounds_str, n, &U, &n)
9579 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
9585 strcpy (name_buf + prefix_len, "___U");
9586 U = get_int_var_value (name_buf, &ok);
9589 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
9594 if (objfile == NULL)
9595 objfile = TYPE_OBJFILE (base_type);
9596 type = create_range_type (alloc_type (objfile), base_type, L, U);
9597 TYPE_NAME (type) = name;
9602 /* True iff NAME is the name of a range type. */
9605 ada_is_range_type_name (const char *name)
9607 return (name != NULL && strstr (name, "___XD"));
9613 /* True iff TYPE is an Ada modular type. */
9616 ada_is_modular_type (struct type *type)
9618 struct type *subranged_type = base_type (type);
9620 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
9621 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
9622 && TYPE_UNSIGNED (subranged_type));
9625 /* Try to determine the lower and upper bounds of the given modular type
9626 using the type name only. Return non-zero and set L and U as the lower
9627 and upper bounds (respectively) if successful. */
9630 ada_modulus_from_name (struct type *type, ULONGEST *modulus)
9632 char *name = ada_type_name (type);
9640 /* Discrete type bounds are encoded using an __XD suffix. In our case,
9641 we are looking for static bounds, which means an __XDLU suffix.
9642 Moreover, we know that the lower bound of modular types is always
9643 zero, so the actual suffix should start with "__XDLU_0__", and
9644 then be followed by the upper bound value. */
9645 suffix = strstr (name, "__XDLU_0__");
9649 if (!ada_scan_number (suffix, k, &U, NULL))
9652 *modulus = (ULONGEST) U + 1;
9656 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9659 ada_modulus (struct type *type)
9663 /* Normally, the modulus of a modular type is equal to the value of
9664 its upper bound + 1. However, the upper bound is currently stored
9665 as an int, which is not always big enough to hold the actual bound
9666 value. To workaround this, try to take advantage of the encoding
9667 that GNAT uses with with discrete types. To avoid some unnecessary
9668 parsing, we do this only when the size of TYPE is greater than
9669 the size of the field holding the bound. */
9670 if (TYPE_LENGTH (type) > sizeof (TYPE_HIGH_BOUND (type))
9671 && ada_modulus_from_name (type, &modulus))
9674 return (ULONGEST) (unsigned int) TYPE_HIGH_BOUND (type) + 1;
9678 /* Ada exception catchpoint support:
9679 ---------------------------------
9681 We support 3 kinds of exception catchpoints:
9682 . catchpoints on Ada exceptions
9683 . catchpoints on unhandled Ada exceptions
9684 . catchpoints on failed assertions
9686 Exceptions raised during failed assertions, or unhandled exceptions
9687 could perfectly be caught with the general catchpoint on Ada exceptions.
9688 However, we can easily differentiate these two special cases, and having
9689 the option to distinguish these two cases from the rest can be useful
9690 to zero-in on certain situations.
9692 Exception catchpoints are a specialized form of breakpoint,
9693 since they rely on inserting breakpoints inside known routines
9694 of the GNAT runtime. The implementation therefore uses a standard
9695 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9698 Support in the runtime for exception catchpoints have been changed
9699 a few times already, and these changes affect the implementation
9700 of these catchpoints. In order to be able to support several
9701 variants of the runtime, we use a sniffer that will determine
9702 the runtime variant used by the program being debugged.
9704 At this time, we do not support the use of conditions on Ada exception
9705 catchpoints. The COND and COND_STRING fields are therefore set
9706 to NULL (most of the time, see below).
9708 Conditions where EXP_STRING, COND, and COND_STRING are used:
9710 When a user specifies the name of a specific exception in the case
9711 of catchpoints on Ada exceptions, we store the name of that exception
9712 in the EXP_STRING. We then translate this request into an actual
9713 condition stored in COND_STRING, and then parse it into an expression
9716 /* The different types of catchpoints that we introduced for catching
9719 enum exception_catchpoint_kind
9722 ex_catch_exception_unhandled,
9726 /* Ada's standard exceptions. */
9728 static char *standard_exc[] = {
9735 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
9737 /* A structure that describes how to support exception catchpoints
9738 for a given executable. */
9740 struct exception_support_info
9742 /* The name of the symbol to break on in order to insert
9743 a catchpoint on exceptions. */
9744 const char *catch_exception_sym;
9746 /* The name of the symbol to break on in order to insert
9747 a catchpoint on unhandled exceptions. */
9748 const char *catch_exception_unhandled_sym;
9750 /* The name of the symbol to break on in order to insert
9751 a catchpoint on failed assertions. */
9752 const char *catch_assert_sym;
9754 /* Assuming that the inferior just triggered an unhandled exception
9755 catchpoint, this function is responsible for returning the address
9756 in inferior memory where the name of that exception is stored.
9757 Return zero if the address could not be computed. */
9758 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
9761 static CORE_ADDR ada_unhandled_exception_name_addr (void);
9762 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
9764 /* The following exception support info structure describes how to
9765 implement exception catchpoints with the latest version of the
9766 Ada runtime (as of 2007-03-06). */
9768 static const struct exception_support_info default_exception_support_info =
9770 "__gnat_debug_raise_exception", /* catch_exception_sym */
9771 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9772 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9773 ada_unhandled_exception_name_addr
9776 /* The following exception support info structure describes how to
9777 implement exception catchpoints with a slightly older version
9778 of the Ada runtime. */
9780 static const struct exception_support_info exception_support_info_fallback =
9782 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9783 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9784 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9785 ada_unhandled_exception_name_addr_from_raise
9788 /* For each executable, we sniff which exception info structure to use
9789 and cache it in the following global variable. */
9791 static const struct exception_support_info *exception_info = NULL;
9793 /* Inspect the Ada runtime and determine which exception info structure
9794 should be used to provide support for exception catchpoints.
9796 This function will always set exception_info, or raise an error. */
9799 ada_exception_support_info_sniffer (void)
9803 /* If the exception info is already known, then no need to recompute it. */
9804 if (exception_info != NULL)
9807 /* Check the latest (default) exception support info. */
9808 sym = standard_lookup (default_exception_support_info.catch_exception_sym,
9812 exception_info = &default_exception_support_info;
9816 /* Try our fallback exception suport info. */
9817 sym = standard_lookup (exception_support_info_fallback.catch_exception_sym,
9821 exception_info = &exception_support_info_fallback;
9825 /* Sometimes, it is normal for us to not be able to find the routine
9826 we are looking for. This happens when the program is linked with
9827 the shared version of the GNAT runtime, and the program has not been
9828 started yet. Inform the user of these two possible causes if
9831 if (ada_update_initial_language (language_unknown, NULL) != language_ada)
9832 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9834 /* If the symbol does not exist, then check that the program is
9835 already started, to make sure that shared libraries have been
9836 loaded. If it is not started, this may mean that the symbol is
9837 in a shared library. */
9839 if (ptid_get_pid (inferior_ptid) == 0)
9840 error (_("Unable to insert catchpoint. Try to start the program first."));
9842 /* At this point, we know that we are debugging an Ada program and
9843 that the inferior has been started, but we still are not able to
9844 find the run-time symbols. That can mean that we are in
9845 configurable run time mode, or that a-except as been optimized
9846 out by the linker... In any case, at this point it is not worth
9847 supporting this feature. */
9849 error (_("Cannot insert catchpoints in this configuration."));
9852 /* An observer of "executable_changed" events.
9853 Its role is to clear certain cached values that need to be recomputed
9854 each time a new executable is loaded by GDB. */
9857 ada_executable_changed_observer (void)
9859 /* If the executable changed, then it is possible that the Ada runtime
9860 is different. So we need to invalidate the exception support info
9862 exception_info = NULL;
9865 /* Return the name of the function at PC, NULL if could not find it.
9866 This function only checks the debugging information, not the symbol
9870 function_name_from_pc (CORE_ADDR pc)
9874 if (!find_pc_partial_function (pc, &func_name, NULL, NULL))
9880 /* True iff FRAME is very likely to be that of a function that is
9881 part of the runtime system. This is all very heuristic, but is
9882 intended to be used as advice as to what frames are uninteresting
9886 is_known_support_routine (struct frame_info *frame)
9888 struct symtab_and_line sal;
9892 /* If this code does not have any debugging information (no symtab),
9893 This cannot be any user code. */
9895 find_frame_sal (frame, &sal);
9896 if (sal.symtab == NULL)
9899 /* If there is a symtab, but the associated source file cannot be
9900 located, then assume this is not user code: Selecting a frame
9901 for which we cannot display the code would not be very helpful
9902 for the user. This should also take care of case such as VxWorks
9903 where the kernel has some debugging info provided for a few units. */
9905 if (symtab_to_fullname (sal.symtab) == NULL)
9908 /* Check the unit filename againt the Ada runtime file naming.
9909 We also check the name of the objfile against the name of some
9910 known system libraries that sometimes come with debugging info
9913 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
9915 re_comp (known_runtime_file_name_patterns[i]);
9916 if (re_exec (sal.symtab->filename))
9918 if (sal.symtab->objfile != NULL
9919 && re_exec (sal.symtab->objfile->name))
9923 /* Check whether the function is a GNAT-generated entity. */
9925 func_name = function_name_from_pc (get_frame_address_in_block (frame));
9926 if (func_name == NULL)
9929 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
9931 re_comp (known_auxiliary_function_name_patterns[i]);
9932 if (re_exec (func_name))
9939 /* Find the first frame that contains debugging information and that is not
9940 part of the Ada run-time, starting from FI and moving upward. */
9943 ada_find_printable_frame (struct frame_info *fi)
9945 for (; fi != NULL; fi = get_prev_frame (fi))
9947 if (!is_known_support_routine (fi))
9956 /* Assuming that the inferior just triggered an unhandled exception
9957 catchpoint, return the address in inferior memory where the name
9958 of the exception is stored.
9960 Return zero if the address could not be computed. */
9963 ada_unhandled_exception_name_addr (void)
9965 return parse_and_eval_address ("e.full_name");
9968 /* Same as ada_unhandled_exception_name_addr, except that this function
9969 should be used when the inferior uses an older version of the runtime,
9970 where the exception name needs to be extracted from a specific frame
9971 several frames up in the callstack. */
9974 ada_unhandled_exception_name_addr_from_raise (void)
9977 struct frame_info *fi;
9979 /* To determine the name of this exception, we need to select
9980 the frame corresponding to RAISE_SYM_NAME. This frame is
9981 at least 3 levels up, so we simply skip the first 3 frames
9982 without checking the name of their associated function. */
9983 fi = get_current_frame ();
9984 for (frame_level = 0; frame_level < 3; frame_level += 1)
9986 fi = get_prev_frame (fi);
9990 const char *func_name =
9991 function_name_from_pc (get_frame_address_in_block (fi));
9992 if (func_name != NULL
9993 && strcmp (func_name, exception_info->catch_exception_sym) == 0)
9994 break; /* We found the frame we were looking for... */
9995 fi = get_prev_frame (fi);
10002 return parse_and_eval_address ("id.full_name");
10005 /* Assuming the inferior just triggered an Ada exception catchpoint
10006 (of any type), return the address in inferior memory where the name
10007 of the exception is stored, if applicable.
10009 Return zero if the address could not be computed, or if not relevant. */
10012 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex,
10013 struct breakpoint *b)
10017 case ex_catch_exception:
10018 return (parse_and_eval_address ("e.full_name"));
10021 case ex_catch_exception_unhandled:
10022 return exception_info->unhandled_exception_name_addr ();
10025 case ex_catch_assert:
10026 return 0; /* Exception name is not relevant in this case. */
10030 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10034 return 0; /* Should never be reached. */
10037 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
10038 any error that ada_exception_name_addr_1 might cause to be thrown.
10039 When an error is intercepted, a warning with the error message is printed,
10040 and zero is returned. */
10043 ada_exception_name_addr (enum exception_catchpoint_kind ex,
10044 struct breakpoint *b)
10046 struct gdb_exception e;
10047 CORE_ADDR result = 0;
10049 TRY_CATCH (e, RETURN_MASK_ERROR)
10051 result = ada_exception_name_addr_1 (ex, b);
10056 warning (_("failed to get exception name: %s"), e.message);
10063 /* Implement the PRINT_IT method in the breakpoint_ops structure
10064 for all exception catchpoint kinds. */
10066 static enum print_stop_action
10067 print_it_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
10069 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
10070 char exception_name[256];
10074 read_memory (addr, exception_name, sizeof (exception_name) - 1);
10075 exception_name [sizeof (exception_name) - 1] = '\0';
10078 ada_find_printable_frame (get_current_frame ());
10080 annotate_catchpoint (b->number);
10083 case ex_catch_exception:
10085 printf_filtered (_("\nCatchpoint %d, %s at "),
10086 b->number, exception_name);
10088 printf_filtered (_("\nCatchpoint %d, exception at "), b->number);
10090 case ex_catch_exception_unhandled:
10092 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10093 b->number, exception_name);
10095 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10098 case ex_catch_assert:
10099 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10104 return PRINT_SRC_AND_LOC;
10107 /* Implement the PRINT_ONE method in the breakpoint_ops structure
10108 for all exception catchpoint kinds. */
10111 print_one_exception (enum exception_catchpoint_kind ex,
10112 struct breakpoint *b, CORE_ADDR *last_addr)
10114 struct value_print_options opts;
10116 get_user_print_options (&opts);
10117 if (opts.addressprint)
10119 annotate_field (4);
10120 ui_out_field_core_addr (uiout, "addr", b->loc->address);
10123 annotate_field (5);
10124 *last_addr = b->loc->address;
10127 case ex_catch_exception:
10128 if (b->exp_string != NULL)
10130 char *msg = xstrprintf (_("`%s' Ada exception"), b->exp_string);
10132 ui_out_field_string (uiout, "what", msg);
10136 ui_out_field_string (uiout, "what", "all Ada exceptions");
10140 case ex_catch_exception_unhandled:
10141 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
10144 case ex_catch_assert:
10145 ui_out_field_string (uiout, "what", "failed Ada assertions");
10149 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10154 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
10155 for all exception catchpoint kinds. */
10158 print_mention_exception (enum exception_catchpoint_kind ex,
10159 struct breakpoint *b)
10163 case ex_catch_exception:
10164 if (b->exp_string != NULL)
10165 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10166 b->number, b->exp_string);
10168 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b->number);
10172 case ex_catch_exception_unhandled:
10173 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10177 case ex_catch_assert:
10178 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b->number);
10182 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10187 /* Virtual table for "catch exception" breakpoints. */
10189 static enum print_stop_action
10190 print_it_catch_exception (struct breakpoint *b)
10192 return print_it_exception (ex_catch_exception, b);
10196 print_one_catch_exception (struct breakpoint *b, CORE_ADDR *last_addr)
10198 print_one_exception (ex_catch_exception, b, last_addr);
10202 print_mention_catch_exception (struct breakpoint *b)
10204 print_mention_exception (ex_catch_exception, b);
10207 static struct breakpoint_ops catch_exception_breakpoint_ops =
10211 NULL, /* breakpoint_hit */
10212 print_it_catch_exception,
10213 print_one_catch_exception,
10214 print_mention_catch_exception
10217 /* Virtual table for "catch exception unhandled" breakpoints. */
10219 static enum print_stop_action
10220 print_it_catch_exception_unhandled (struct breakpoint *b)
10222 return print_it_exception (ex_catch_exception_unhandled, b);
10226 print_one_catch_exception_unhandled (struct breakpoint *b, CORE_ADDR *last_addr)
10228 print_one_exception (ex_catch_exception_unhandled, b, last_addr);
10232 print_mention_catch_exception_unhandled (struct breakpoint *b)
10234 print_mention_exception (ex_catch_exception_unhandled, b);
10237 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops = {
10240 NULL, /* breakpoint_hit */
10241 print_it_catch_exception_unhandled,
10242 print_one_catch_exception_unhandled,
10243 print_mention_catch_exception_unhandled
10246 /* Virtual table for "catch assert" breakpoints. */
10248 static enum print_stop_action
10249 print_it_catch_assert (struct breakpoint *b)
10251 return print_it_exception (ex_catch_assert, b);
10255 print_one_catch_assert (struct breakpoint *b, CORE_ADDR *last_addr)
10257 print_one_exception (ex_catch_assert, b, last_addr);
10261 print_mention_catch_assert (struct breakpoint *b)
10263 print_mention_exception (ex_catch_assert, b);
10266 static struct breakpoint_ops catch_assert_breakpoint_ops = {
10269 NULL, /* breakpoint_hit */
10270 print_it_catch_assert,
10271 print_one_catch_assert,
10272 print_mention_catch_assert
10275 /* Return non-zero if B is an Ada exception catchpoint. */
10278 ada_exception_catchpoint_p (struct breakpoint *b)
10280 return (b->ops == &catch_exception_breakpoint_ops
10281 || b->ops == &catch_exception_unhandled_breakpoint_ops
10282 || b->ops == &catch_assert_breakpoint_ops);
10285 /* Return a newly allocated copy of the first space-separated token
10286 in ARGSP, and then adjust ARGSP to point immediately after that
10289 Return NULL if ARGPS does not contain any more tokens. */
10292 ada_get_next_arg (char **argsp)
10294 char *args = *argsp;
10298 /* Skip any leading white space. */
10300 while (isspace (*args))
10303 if (args[0] == '\0')
10304 return NULL; /* No more arguments. */
10306 /* Find the end of the current argument. */
10309 while (*end != '\0' && !isspace (*end))
10312 /* Adjust ARGSP to point to the start of the next argument. */
10316 /* Make a copy of the current argument and return it. */
10318 result = xmalloc (end - args + 1);
10319 strncpy (result, args, end - args);
10320 result[end - args] = '\0';
10325 /* Split the arguments specified in a "catch exception" command.
10326 Set EX to the appropriate catchpoint type.
10327 Set EXP_STRING to the name of the specific exception if
10328 specified by the user. */
10331 catch_ada_exception_command_split (char *args,
10332 enum exception_catchpoint_kind *ex,
10335 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
10336 char *exception_name;
10338 exception_name = ada_get_next_arg (&args);
10339 make_cleanup (xfree, exception_name);
10341 /* Check that we do not have any more arguments. Anything else
10344 while (isspace (*args))
10347 if (args[0] != '\0')
10348 error (_("Junk at end of expression"));
10350 discard_cleanups (old_chain);
10352 if (exception_name == NULL)
10354 /* Catch all exceptions. */
10355 *ex = ex_catch_exception;
10356 *exp_string = NULL;
10358 else if (strcmp (exception_name, "unhandled") == 0)
10360 /* Catch unhandled exceptions. */
10361 *ex = ex_catch_exception_unhandled;
10362 *exp_string = NULL;
10366 /* Catch a specific exception. */
10367 *ex = ex_catch_exception;
10368 *exp_string = exception_name;
10372 /* Return the name of the symbol on which we should break in order to
10373 implement a catchpoint of the EX kind. */
10375 static const char *
10376 ada_exception_sym_name (enum exception_catchpoint_kind ex)
10378 gdb_assert (exception_info != NULL);
10382 case ex_catch_exception:
10383 return (exception_info->catch_exception_sym);
10385 case ex_catch_exception_unhandled:
10386 return (exception_info->catch_exception_unhandled_sym);
10388 case ex_catch_assert:
10389 return (exception_info->catch_assert_sym);
10392 internal_error (__FILE__, __LINE__,
10393 _("unexpected catchpoint kind (%d)"), ex);
10397 /* Return the breakpoint ops "virtual table" used for catchpoints
10400 static struct breakpoint_ops *
10401 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex)
10405 case ex_catch_exception:
10406 return (&catch_exception_breakpoint_ops);
10408 case ex_catch_exception_unhandled:
10409 return (&catch_exception_unhandled_breakpoint_ops);
10411 case ex_catch_assert:
10412 return (&catch_assert_breakpoint_ops);
10415 internal_error (__FILE__, __LINE__,
10416 _("unexpected catchpoint kind (%d)"), ex);
10420 /* Return the condition that will be used to match the current exception
10421 being raised with the exception that the user wants to catch. This
10422 assumes that this condition is used when the inferior just triggered
10423 an exception catchpoint.
10425 The string returned is a newly allocated string that needs to be
10426 deallocated later. */
10429 ada_exception_catchpoint_cond_string (const char *exp_string)
10433 /* The standard exceptions are a special case. They are defined in
10434 runtime units that have been compiled without debugging info; if
10435 EXP_STRING is the not-fully-qualified name of a standard
10436 exception (e.g. "constraint_error") then, during the evaluation
10437 of the condition expression, the symbol lookup on this name would
10438 *not* return this standard exception. The catchpoint condition
10439 may then be set only on user-defined exceptions which have the
10440 same not-fully-qualified name (e.g. my_package.constraint_error).
10442 To avoid this unexcepted behavior, these standard exceptions are
10443 systematically prefixed by "standard". This means that "catch
10444 exception constraint_error" is rewritten into "catch exception
10445 standard.constraint_error".
10447 If an exception named contraint_error is defined in another package of
10448 the inferior program, then the only way to specify this exception as a
10449 breakpoint condition is to use its fully-qualified named:
10450 e.g. my_package.constraint_error. */
10452 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
10454 if (strcmp (standard_exc [i], exp_string) == 0)
10456 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
10460 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string);
10463 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
10465 static struct expression *
10466 ada_parse_catchpoint_condition (char *cond_string,
10467 struct symtab_and_line sal)
10469 return (parse_exp_1 (&cond_string, block_for_pc (sal.pc), 0));
10472 /* Return the symtab_and_line that should be used to insert an exception
10473 catchpoint of the TYPE kind.
10475 EX_STRING should contain the name of a specific exception
10476 that the catchpoint should catch, or NULL otherwise.
10478 The idea behind all the remaining parameters is that their names match
10479 the name of certain fields in the breakpoint structure that are used to
10480 handle exception catchpoints. This function returns the value to which
10481 these fields should be set, depending on the type of catchpoint we need
10484 If COND and COND_STRING are both non-NULL, any value they might
10485 hold will be free'ed, and then replaced by newly allocated ones.
10486 These parameters are left untouched otherwise. */
10488 static struct symtab_and_line
10489 ada_exception_sal (enum exception_catchpoint_kind ex, char *exp_string,
10490 char **addr_string, char **cond_string,
10491 struct expression **cond, struct breakpoint_ops **ops)
10493 const char *sym_name;
10494 struct symbol *sym;
10495 struct symtab_and_line sal;
10497 /* First, find out which exception support info to use. */
10498 ada_exception_support_info_sniffer ();
10500 /* Then lookup the function on which we will break in order to catch
10501 the Ada exceptions requested by the user. */
10503 sym_name = ada_exception_sym_name (ex);
10504 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
10506 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10507 that should be compiled with debugging information. As a result, we
10508 expect to find that symbol in the symtabs. If we don't find it, then
10509 the target most likely does not support Ada exceptions, or we cannot
10510 insert exception breakpoints yet, because the GNAT runtime hasn't been
10513 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10514 in such a way that no debugging information is produced for the symbol
10515 we are looking for. In this case, we could search the minimal symbols
10516 as a fall-back mechanism. This would still be operating in degraded
10517 mode, however, as we would still be missing the debugging information
10518 that is needed in order to extract the name of the exception being
10519 raised (this name is printed in the catchpoint message, and is also
10520 used when trying to catch a specific exception). We do not handle
10521 this case for now. */
10524 error (_("Unable to break on '%s' in this configuration."), sym_name);
10526 /* Make sure that the symbol we found corresponds to a function. */
10527 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
10528 error (_("Symbol \"%s\" is not a function (class = %d)"),
10529 sym_name, SYMBOL_CLASS (sym));
10531 sal = find_function_start_sal (sym, 1);
10533 /* Set ADDR_STRING. */
10535 *addr_string = xstrdup (sym_name);
10537 /* Set the COND and COND_STRING (if not NULL). */
10539 if (cond_string != NULL && cond != NULL)
10541 if (*cond_string != NULL)
10543 xfree (*cond_string);
10544 *cond_string = NULL;
10551 if (exp_string != NULL)
10553 *cond_string = ada_exception_catchpoint_cond_string (exp_string);
10554 *cond = ada_parse_catchpoint_condition (*cond_string, sal);
10559 *ops = ada_exception_breakpoint_ops (ex);
10564 /* Parse the arguments (ARGS) of the "catch exception" command.
10566 Set TYPE to the appropriate exception catchpoint type.
10567 If the user asked the catchpoint to catch only a specific
10568 exception, then save the exception name in ADDR_STRING.
10570 See ada_exception_sal for a description of all the remaining
10571 function arguments of this function. */
10573 struct symtab_and_line
10574 ada_decode_exception_location (char *args, char **addr_string,
10575 char **exp_string, char **cond_string,
10576 struct expression **cond,
10577 struct breakpoint_ops **ops)
10579 enum exception_catchpoint_kind ex;
10581 catch_ada_exception_command_split (args, &ex, exp_string);
10582 return ada_exception_sal (ex, *exp_string, addr_string, cond_string,
10586 struct symtab_and_line
10587 ada_decode_assert_location (char *args, char **addr_string,
10588 struct breakpoint_ops **ops)
10590 /* Check that no argument where provided at the end of the command. */
10594 while (isspace (*args))
10597 error (_("Junk at end of arguments."));
10600 return ada_exception_sal (ex_catch_assert, NULL, addr_string, NULL, NULL,
10605 /* Information about operators given special treatment in functions
10607 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10609 #define ADA_OPERATORS \
10610 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10611 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10612 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10613 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10614 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10615 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10616 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10617 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10618 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10619 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10620 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10621 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10622 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10623 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10624 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
10625 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10626 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10627 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10628 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
10631 ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp)
10633 switch (exp->elts[pc - 1].opcode)
10636 operator_length_standard (exp, pc, oplenp, argsp);
10639 #define OP_DEFN(op, len, args, binop) \
10640 case op: *oplenp = len; *argsp = args; break;
10646 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
10651 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
10657 ada_op_name (enum exp_opcode opcode)
10662 return op_name_standard (opcode);
10664 #define OP_DEFN(op, len, args, binop) case op: return #op;
10669 return "OP_AGGREGATE";
10671 return "OP_CHOICES";
10677 /* As for operator_length, but assumes PC is pointing at the first
10678 element of the operator, and gives meaningful results only for the
10679 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
10682 ada_forward_operator_length (struct expression *exp, int pc,
10683 int *oplenp, int *argsp)
10685 switch (exp->elts[pc].opcode)
10688 *oplenp = *argsp = 0;
10691 #define OP_DEFN(op, len, args, binop) \
10692 case op: *oplenp = len; *argsp = args; break;
10698 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
10703 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
10709 int len = longest_to_int (exp->elts[pc + 1].longconst);
10710 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
10718 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
10720 enum exp_opcode op = exp->elts[elt].opcode;
10725 ada_forward_operator_length (exp, elt, &oplen, &nargs);
10729 /* Ada attributes ('Foo). */
10732 case OP_ATR_LENGTH:
10736 case OP_ATR_MODULUS:
10743 case UNOP_IN_RANGE:
10745 /* XXX: gdb_sprint_host_address, type_sprint */
10746 fprintf_filtered (stream, _("Type @"));
10747 gdb_print_host_address (exp->elts[pc + 1].type, stream);
10748 fprintf_filtered (stream, " (");
10749 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
10750 fprintf_filtered (stream, ")");
10752 case BINOP_IN_BOUNDS:
10753 fprintf_filtered (stream, " (%d)",
10754 longest_to_int (exp->elts[pc + 2].longconst));
10756 case TERNOP_IN_RANGE:
10761 case OP_DISCRETE_RANGE:
10762 case OP_POSITIONAL:
10769 char *name = &exp->elts[elt + 2].string;
10770 int len = longest_to_int (exp->elts[elt + 1].longconst);
10771 fprintf_filtered (stream, "Text: `%.*s'", len, name);
10776 return dump_subexp_body_standard (exp, stream, elt);
10780 for (i = 0; i < nargs; i += 1)
10781 elt = dump_subexp (exp, stream, elt);
10786 /* The Ada extension of print_subexp (q.v.). */
10789 ada_print_subexp (struct expression *exp, int *pos,
10790 struct ui_file *stream, enum precedence prec)
10792 int oplen, nargs, i;
10794 enum exp_opcode op = exp->elts[pc].opcode;
10796 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10803 print_subexp_standard (exp, pos, stream, prec);
10807 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
10810 case BINOP_IN_BOUNDS:
10811 /* XXX: sprint_subexp */
10812 print_subexp (exp, pos, stream, PREC_SUFFIX);
10813 fputs_filtered (" in ", stream);
10814 print_subexp (exp, pos, stream, PREC_SUFFIX);
10815 fputs_filtered ("'range", stream);
10816 if (exp->elts[pc + 1].longconst > 1)
10817 fprintf_filtered (stream, "(%ld)",
10818 (long) exp->elts[pc + 1].longconst);
10821 case TERNOP_IN_RANGE:
10822 if (prec >= PREC_EQUAL)
10823 fputs_filtered ("(", stream);
10824 /* XXX: sprint_subexp */
10825 print_subexp (exp, pos, stream, PREC_SUFFIX);
10826 fputs_filtered (" in ", stream);
10827 print_subexp (exp, pos, stream, PREC_EQUAL);
10828 fputs_filtered (" .. ", stream);
10829 print_subexp (exp, pos, stream, PREC_EQUAL);
10830 if (prec >= PREC_EQUAL)
10831 fputs_filtered (")", stream);
10836 case OP_ATR_LENGTH:
10840 case OP_ATR_MODULUS:
10845 if (exp->elts[*pos].opcode == OP_TYPE)
10847 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
10848 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
10852 print_subexp (exp, pos, stream, PREC_SUFFIX);
10853 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
10857 for (tem = 1; tem < nargs; tem += 1)
10859 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
10860 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
10862 fputs_filtered (")", stream);
10867 type_print (exp->elts[pc + 1].type, "", stream, 0);
10868 fputs_filtered ("'(", stream);
10869 print_subexp (exp, pos, stream, PREC_PREFIX);
10870 fputs_filtered (")", stream);
10873 case UNOP_IN_RANGE:
10874 /* XXX: sprint_subexp */
10875 print_subexp (exp, pos, stream, PREC_SUFFIX);
10876 fputs_filtered (" in ", stream);
10877 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
10880 case OP_DISCRETE_RANGE:
10881 print_subexp (exp, pos, stream, PREC_SUFFIX);
10882 fputs_filtered ("..", stream);
10883 print_subexp (exp, pos, stream, PREC_SUFFIX);
10887 fputs_filtered ("others => ", stream);
10888 print_subexp (exp, pos, stream, PREC_SUFFIX);
10892 for (i = 0; i < nargs-1; i += 1)
10895 fputs_filtered ("|", stream);
10896 print_subexp (exp, pos, stream, PREC_SUFFIX);
10898 fputs_filtered (" => ", stream);
10899 print_subexp (exp, pos, stream, PREC_SUFFIX);
10902 case OP_POSITIONAL:
10903 print_subexp (exp, pos, stream, PREC_SUFFIX);
10907 fputs_filtered ("(", stream);
10908 for (i = 0; i < nargs; i += 1)
10911 fputs_filtered (", ", stream);
10912 print_subexp (exp, pos, stream, PREC_SUFFIX);
10914 fputs_filtered (")", stream);
10919 /* Table mapping opcodes into strings for printing operators
10920 and precedences of the operators. */
10922 static const struct op_print ada_op_print_tab[] = {
10923 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
10924 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
10925 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
10926 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
10927 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
10928 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
10929 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
10930 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
10931 {"<=", BINOP_LEQ, PREC_ORDER, 0},
10932 {">=", BINOP_GEQ, PREC_ORDER, 0},
10933 {">", BINOP_GTR, PREC_ORDER, 0},
10934 {"<", BINOP_LESS, PREC_ORDER, 0},
10935 {">>", BINOP_RSH, PREC_SHIFT, 0},
10936 {"<<", BINOP_LSH, PREC_SHIFT, 0},
10937 {"+", BINOP_ADD, PREC_ADD, 0},
10938 {"-", BINOP_SUB, PREC_ADD, 0},
10939 {"&", BINOP_CONCAT, PREC_ADD, 0},
10940 {"*", BINOP_MUL, PREC_MUL, 0},
10941 {"/", BINOP_DIV, PREC_MUL, 0},
10942 {"rem", BINOP_REM, PREC_MUL, 0},
10943 {"mod", BINOP_MOD, PREC_MUL, 0},
10944 {"**", BINOP_EXP, PREC_REPEAT, 0},
10945 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
10946 {"-", UNOP_NEG, PREC_PREFIX, 0},
10947 {"+", UNOP_PLUS, PREC_PREFIX, 0},
10948 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
10949 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
10950 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
10951 {".all", UNOP_IND, PREC_SUFFIX, 1},
10952 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
10953 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
10957 enum ada_primitive_types {
10958 ada_primitive_type_int,
10959 ada_primitive_type_long,
10960 ada_primitive_type_short,
10961 ada_primitive_type_char,
10962 ada_primitive_type_float,
10963 ada_primitive_type_double,
10964 ada_primitive_type_void,
10965 ada_primitive_type_long_long,
10966 ada_primitive_type_long_double,
10967 ada_primitive_type_natural,
10968 ada_primitive_type_positive,
10969 ada_primitive_type_system_address,
10970 nr_ada_primitive_types
10974 ada_language_arch_info (struct gdbarch *gdbarch,
10975 struct language_arch_info *lai)
10977 const struct builtin_type *builtin = builtin_type (gdbarch);
10978 lai->primitive_type_vector
10979 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
10981 lai->primitive_type_vector [ada_primitive_type_int] =
10982 init_type (TYPE_CODE_INT,
10983 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
10984 0, "integer", (struct objfile *) NULL);
10985 lai->primitive_type_vector [ada_primitive_type_long] =
10986 init_type (TYPE_CODE_INT,
10987 gdbarch_long_bit (gdbarch) / TARGET_CHAR_BIT,
10988 0, "long_integer", (struct objfile *) NULL);
10989 lai->primitive_type_vector [ada_primitive_type_short] =
10990 init_type (TYPE_CODE_INT,
10991 gdbarch_short_bit (gdbarch) / TARGET_CHAR_BIT,
10992 0, "short_integer", (struct objfile *) NULL);
10993 lai->string_char_type =
10994 lai->primitive_type_vector [ada_primitive_type_char] =
10995 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
10996 0, "character", (struct objfile *) NULL);
10997 lai->primitive_type_vector [ada_primitive_type_float] =
10998 init_type (TYPE_CODE_FLT,
10999 gdbarch_float_bit (gdbarch)/ TARGET_CHAR_BIT,
11000 0, "float", (struct objfile *) NULL);
11001 lai->primitive_type_vector [ada_primitive_type_double] =
11002 init_type (TYPE_CODE_FLT,
11003 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
11004 0, "long_float", (struct objfile *) NULL);
11005 lai->primitive_type_vector [ada_primitive_type_long_long] =
11006 init_type (TYPE_CODE_INT,
11007 gdbarch_long_long_bit (gdbarch) / TARGET_CHAR_BIT,
11008 0, "long_long_integer", (struct objfile *) NULL);
11009 lai->primitive_type_vector [ada_primitive_type_long_double] =
11010 init_type (TYPE_CODE_FLT,
11011 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
11012 0, "long_long_float", (struct objfile *) NULL);
11013 lai->primitive_type_vector [ada_primitive_type_natural] =
11014 init_type (TYPE_CODE_INT,
11015 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
11016 0, "natural", (struct objfile *) NULL);
11017 lai->primitive_type_vector [ada_primitive_type_positive] =
11018 init_type (TYPE_CODE_INT,
11019 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
11020 0, "positive", (struct objfile *) NULL);
11021 lai->primitive_type_vector [ada_primitive_type_void] = builtin->builtin_void;
11023 lai->primitive_type_vector [ada_primitive_type_system_address] =
11024 lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
11025 (struct objfile *) NULL));
11026 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
11027 = "system__address";
11029 lai->bool_type_symbol = NULL;
11030 lai->bool_type_default = builtin->builtin_bool;
11033 /* Language vector */
11035 /* Not really used, but needed in the ada_language_defn. */
11038 emit_char (int c, struct ui_file *stream, int quoter)
11040 ada_emit_char (c, stream, quoter, 1);
11046 warnings_issued = 0;
11047 return ada_parse ();
11050 static const struct exp_descriptor ada_exp_descriptor = {
11052 ada_operator_length,
11054 ada_dump_subexp_body,
11055 ada_evaluate_subexp
11058 const struct language_defn ada_language_defn = {
11059 "ada", /* Language name */
11063 case_sensitive_on, /* Yes, Ada is case-insensitive, but
11064 that's not quite what this means. */
11066 macro_expansion_no,
11067 &ada_exp_descriptor,
11071 ada_printchar, /* Print a character constant */
11072 ada_printstr, /* Function to print string constant */
11073 emit_char, /* Function to print single char (not used) */
11074 ada_print_type, /* Print a type using appropriate syntax */
11075 default_print_typedef, /* Print a typedef using appropriate syntax */
11076 ada_val_print, /* Print a value using appropriate syntax */
11077 ada_value_print, /* Print a top-level value */
11078 NULL, /* Language specific skip_trampoline */
11079 NULL, /* name_of_this */
11080 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
11081 basic_lookup_transparent_type, /* lookup_transparent_type */
11082 ada_la_decode, /* Language specific symbol demangler */
11083 NULL, /* Language specific class_name_from_physname */
11084 ada_op_print_tab, /* expression operators for printing */
11085 0, /* c-style arrays */
11086 1, /* String lower bound */
11087 ada_get_gdb_completer_word_break_characters,
11088 ada_make_symbol_completion_list,
11089 ada_language_arch_info,
11090 ada_print_array_index,
11091 default_pass_by_reference,
11096 /* Provide a prototype to silence -Wmissing-prototypes. */
11097 extern initialize_file_ftype _initialize_ada_language;
11100 _initialize_ada_language (void)
11102 add_language (&ada_language_defn);
11104 varsize_limit = 65536;
11106 obstack_init (&symbol_list_obstack);
11108 decoded_names_store = htab_create_alloc
11109 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
11110 NULL, xcalloc, xfree);
11112 observer_attach_executable_changed (ada_executable_changed_observer);