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))
8461 return value_zero (value_type (arg1), not_lval);
8464 type = builtin_type (exp->gdbarch)->builtin_double;
8465 if (ada_is_fixed_point_type (value_type (arg1)))
8466 arg1 = cast_from_fixed (type, arg1);
8467 if (ada_is_fixed_point_type (value_type (arg2)))
8468 arg2 = cast_from_fixed (type, arg2);
8469 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8470 return ada_value_binop (arg1, arg2, op);
8475 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8476 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8477 if (noside == EVAL_SKIP)
8479 else if (noside == EVAL_AVOID_SIDE_EFFECTS
8480 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
8481 return value_zero (value_type (arg1), not_lval);
8484 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8485 return ada_value_binop (arg1, arg2, op);
8489 case BINOP_NOTEQUAL:
8490 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8491 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
8492 if (noside == EVAL_SKIP)
8494 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8498 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8499 tem = ada_value_equal (arg1, arg2);
8501 if (op == BINOP_NOTEQUAL)
8503 type = language_bool_type (exp->language_defn, exp->gdbarch);
8504 return value_from_longest (type, (LONGEST) tem);
8507 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8508 if (noside == EVAL_SKIP)
8510 else if (ada_is_fixed_point_type (value_type (arg1)))
8511 return value_cast (value_type (arg1), value_neg (arg1));
8514 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
8515 return value_neg (arg1);
8518 case BINOP_LOGICAL_AND:
8519 case BINOP_LOGICAL_OR:
8520 case UNOP_LOGICAL_NOT:
8525 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8526 type = language_bool_type (exp->language_defn, exp->gdbarch);
8527 return value_cast (type, val);
8530 case BINOP_BITWISE_AND:
8531 case BINOP_BITWISE_IOR:
8532 case BINOP_BITWISE_XOR:
8536 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
8538 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8540 return value_cast (value_type (arg1), val);
8546 if (noside == EVAL_SKIP)
8551 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
8552 /* Only encountered when an unresolved symbol occurs in a
8553 context other than a function call, in which case, it is
8555 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8556 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
8557 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8559 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
8560 if (ada_is_tagged_type (type, 0))
8562 /* Tagged types are a little special in the fact that the real
8563 type is dynamic and can only be determined by inspecting the
8564 object's tag. This means that we need to get the object's
8565 value first (EVAL_NORMAL) and then extract the actual object
8568 Note that we cannot skip the final step where we extract
8569 the object type from its tag, because the EVAL_NORMAL phase
8570 results in dynamic components being resolved into fixed ones.
8571 This can cause problems when trying to print the type
8572 description of tagged types whose parent has a dynamic size:
8573 We use the type name of the "_parent" component in order
8574 to print the name of the ancestor type in the type description.
8575 If that component had a dynamic size, the resolution into
8576 a fixed type would result in the loss of that type name,
8577 thus preventing us from printing the name of the ancestor
8578 type in the type description. */
8579 struct type *actual_type;
8581 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
8582 actual_type = type_from_tag (ada_value_tag (arg1));
8583 if (actual_type == NULL)
8584 /* If, for some reason, we were unable to determine
8585 the actual type from the tag, then use the static
8586 approximation that we just computed as a fallback.
8587 This can happen if the debugging information is
8588 incomplete, for instance. */
8591 return value_zero (actual_type, not_lval);
8596 (to_static_fixed_type
8597 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
8603 unwrap_value (evaluate_subexp_standard
8604 (expect_type, exp, pos, noside));
8605 return ada_to_fixed_value (arg1);
8611 /* Allocate arg vector, including space for the function to be
8612 called in argvec[0] and a terminating NULL. */
8613 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8615 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
8617 if (exp->elts[*pos].opcode == OP_VAR_VALUE
8618 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
8619 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8620 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
8623 for (tem = 0; tem <= nargs; tem += 1)
8624 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8627 if (noside == EVAL_SKIP)
8631 if (ada_is_packed_array_type (desc_base_type (value_type (argvec[0]))))
8632 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
8633 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
8634 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
8635 && VALUE_LVAL (argvec[0]) == lval_memory))
8636 argvec[0] = value_addr (argvec[0]);
8638 type = ada_check_typedef (value_type (argvec[0]));
8639 if (TYPE_CODE (type) == TYPE_CODE_PTR)
8641 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
8643 case TYPE_CODE_FUNC:
8644 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8646 case TYPE_CODE_ARRAY:
8648 case TYPE_CODE_STRUCT:
8649 if (noside != EVAL_AVOID_SIDE_EFFECTS)
8650 argvec[0] = ada_value_ind (argvec[0]);
8651 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8654 error (_("cannot subscript or call something of type `%s'"),
8655 ada_type_name (value_type (argvec[0])));
8660 switch (TYPE_CODE (type))
8662 case TYPE_CODE_FUNC:
8663 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8664 return allocate_value (TYPE_TARGET_TYPE (type));
8665 return call_function_by_hand (argvec[0], nargs, argvec + 1);
8666 case TYPE_CODE_STRUCT:
8670 arity = ada_array_arity (type);
8671 type = ada_array_element_type (type, nargs);
8673 error (_("cannot subscript or call a record"));
8675 error (_("wrong number of subscripts; expecting %d"), arity);
8676 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8677 return value_zero (ada_aligned_type (type), lval_memory);
8679 unwrap_value (ada_value_subscript
8680 (argvec[0], nargs, argvec + 1));
8682 case TYPE_CODE_ARRAY:
8683 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8685 type = ada_array_element_type (type, nargs);
8687 error (_("element type of array unknown"));
8689 return value_zero (ada_aligned_type (type), lval_memory);
8692 unwrap_value (ada_value_subscript
8693 (ada_coerce_to_simple_array (argvec[0]),
8694 nargs, argvec + 1));
8695 case TYPE_CODE_PTR: /* Pointer to array */
8696 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
8697 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8699 type = ada_array_element_type (type, nargs);
8701 error (_("element type of array unknown"));
8703 return value_zero (ada_aligned_type (type), lval_memory);
8706 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
8707 nargs, argvec + 1));
8710 error (_("Attempt to index or call something other than an "
8711 "array or function"));
8716 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8717 struct value *low_bound_val =
8718 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8719 struct value *high_bound_val =
8720 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8723 low_bound_val = coerce_ref (low_bound_val);
8724 high_bound_val = coerce_ref (high_bound_val);
8725 low_bound = pos_atr (low_bound_val);
8726 high_bound = pos_atr (high_bound_val);
8728 if (noside == EVAL_SKIP)
8731 /* If this is a reference to an aligner type, then remove all
8733 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8734 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
8735 TYPE_TARGET_TYPE (value_type (array)) =
8736 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
8738 if (ada_is_packed_array_type (value_type (array)))
8739 error (_("cannot slice a packed array"));
8741 /* If this is a reference to an array or an array lvalue,
8742 convert to a pointer. */
8743 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8744 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
8745 && VALUE_LVAL (array) == lval_memory))
8746 array = value_addr (array);
8748 if (noside == EVAL_AVOID_SIDE_EFFECTS
8749 && ada_is_array_descriptor_type (ada_check_typedef
8750 (value_type (array))))
8751 return empty_array (ada_type_of_array (array, 0), low_bound);
8753 array = ada_coerce_to_simple_array_ptr (array);
8755 /* If we have more than one level of pointer indirection,
8756 dereference the value until we get only one level. */
8757 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
8758 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
8760 array = value_ind (array);
8762 /* Make sure we really do have an array type before going further,
8763 to avoid a SEGV when trying to get the index type or the target
8764 type later down the road if the debug info generated by
8765 the compiler is incorrect or incomplete. */
8766 if (!ada_is_simple_array_type (value_type (array)))
8767 error (_("cannot take slice of non-array"));
8769 if (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR)
8771 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
8772 return empty_array (TYPE_TARGET_TYPE (value_type (array)),
8776 struct type *arr_type0 =
8777 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array)),
8779 return ada_value_slice_from_ptr (array, arr_type0,
8780 longest_to_int (low_bound),
8781 longest_to_int (high_bound));
8784 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8786 else if (high_bound < low_bound)
8787 return empty_array (value_type (array), low_bound);
8789 return ada_value_slice (array, longest_to_int (low_bound),
8790 longest_to_int (high_bound));
8795 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8796 type = exp->elts[pc + 1].type;
8798 if (noside == EVAL_SKIP)
8801 switch (TYPE_CODE (type))
8804 lim_warning (_("Membership test incompletely implemented; "
8805 "always returns true"));
8806 type = language_bool_type (exp->language_defn, exp->gdbarch);
8807 return value_from_longest (type, (LONGEST) 1);
8809 case TYPE_CODE_RANGE:
8810 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
8811 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
8812 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8813 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
8814 type = language_bool_type (exp->language_defn, exp->gdbarch);
8816 value_from_longest (type,
8817 (value_less (arg1, arg3)
8818 || value_equal (arg1, arg3))
8819 && (value_less (arg2, arg1)
8820 || value_equal (arg2, arg1)));
8823 case BINOP_IN_BOUNDS:
8825 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8826 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8828 if (noside == EVAL_SKIP)
8831 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8833 type = language_bool_type (exp->language_defn, exp->gdbarch);
8834 return value_zero (type, not_lval);
8837 tem = longest_to_int (exp->elts[pc + 1].longconst);
8839 if (tem < 1 || tem > ada_array_arity (value_type (arg2)))
8840 error (_("invalid dimension number to 'range"));
8842 arg3 = ada_array_bound (arg2, tem, 1);
8843 arg2 = ada_array_bound (arg2, tem, 0);
8845 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8846 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
8847 type = language_bool_type (exp->language_defn, exp->gdbarch);
8849 value_from_longest (type,
8850 (value_less (arg1, arg3)
8851 || value_equal (arg1, arg3))
8852 && (value_less (arg2, arg1)
8853 || value_equal (arg2, arg1)));
8855 case TERNOP_IN_RANGE:
8856 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8857 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8858 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8860 if (noside == EVAL_SKIP)
8863 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8864 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
8865 type = language_bool_type (exp->language_defn, exp->gdbarch);
8867 value_from_longest (type,
8868 (value_less (arg1, arg3)
8869 || value_equal (arg1, arg3))
8870 && (value_less (arg2, arg1)
8871 || value_equal (arg2, arg1)));
8877 struct type *type_arg;
8878 if (exp->elts[*pos].opcode == OP_TYPE)
8880 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
8882 type_arg = exp->elts[pc + 2].type;
8886 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8890 if (exp->elts[*pos].opcode != OP_LONG)
8891 error (_("Invalid operand to '%s"), ada_attribute_name (op));
8892 tem = longest_to_int (exp->elts[*pos + 2].longconst);
8895 if (noside == EVAL_SKIP)
8898 if (type_arg == NULL)
8900 arg1 = ada_coerce_ref (arg1);
8902 if (ada_is_packed_array_type (value_type (arg1)))
8903 arg1 = ada_coerce_to_simple_array (arg1);
8905 if (tem < 1 || tem > ada_array_arity (value_type (arg1)))
8906 error (_("invalid dimension number to '%s"),
8907 ada_attribute_name (op));
8909 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8911 type = ada_index_type (value_type (arg1), tem);
8914 (_("attempt to take bound of something that is not an array"));
8915 return allocate_value (type);
8920 default: /* Should never happen. */
8921 error (_("unexpected attribute encountered"));
8923 return ada_array_bound (arg1, tem, 0);
8925 return ada_array_bound (arg1, tem, 1);
8927 return ada_array_length (arg1, tem);
8930 else if (discrete_type_p (type_arg))
8932 struct type *range_type;
8933 char *name = ada_type_name (type_arg);
8935 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
8937 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
8938 if (range_type == NULL)
8939 range_type = type_arg;
8943 error (_("unexpected attribute encountered"));
8945 return value_from_longest
8946 (range_type, discrete_type_low_bound (range_type));
8948 return value_from_longest
8949 (range_type, discrete_type_high_bound (range_type));
8951 error (_("the 'length attribute applies only to array types"));
8954 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
8955 error (_("unimplemented type attribute"));
8960 if (ada_is_packed_array_type (type_arg))
8961 type_arg = decode_packed_array_type (type_arg);
8963 if (tem < 1 || tem > ada_array_arity (type_arg))
8964 error (_("invalid dimension number to '%s"),
8965 ada_attribute_name (op));
8967 type = ada_index_type (type_arg, tem);
8970 (_("attempt to take bound of something that is not an array"));
8971 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8972 return allocate_value (type);
8977 error (_("unexpected attribute encountered"));
8979 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
8980 return value_from_longest (type, low);
8982 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
8983 return value_from_longest (type, high);
8985 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
8986 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
8987 return value_from_longest (type, high - low + 1);
8993 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8994 if (noside == EVAL_SKIP)
8997 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8998 return value_zero (ada_tag_type (arg1), not_lval);
9000 return ada_value_tag (arg1);
9004 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9005 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9006 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9007 if (noside == EVAL_SKIP)
9009 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9010 return value_zero (value_type (arg1), not_lval);
9013 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9014 return value_binop (arg1, arg2,
9015 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
9018 case OP_ATR_MODULUS:
9020 struct type *type_arg = exp->elts[pc + 2].type;
9021 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9023 if (noside == EVAL_SKIP)
9026 if (!ada_is_modular_type (type_arg))
9027 error (_("'modulus must be applied to modular type"));
9029 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
9030 ada_modulus (type_arg));
9035 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9036 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9037 if (noside == EVAL_SKIP)
9039 type = builtin_type (exp->gdbarch)->builtin_int;
9040 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9041 return value_zero (type, not_lval);
9043 return value_pos_atr (type, arg1);
9046 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9047 type = value_type (arg1);
9049 /* If the argument is a reference, then dereference its type, since
9050 the user is really asking for the size of the actual object,
9051 not the size of the pointer. */
9052 if (TYPE_CODE (type) == TYPE_CODE_REF)
9053 type = TYPE_TARGET_TYPE (type);
9055 if (noside == EVAL_SKIP)
9057 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9058 return value_zero (builtin_type_int32, not_lval);
9060 return value_from_longest (builtin_type_int32,
9061 TARGET_CHAR_BIT * TYPE_LENGTH (type));
9064 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9065 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9066 type = exp->elts[pc + 2].type;
9067 if (noside == EVAL_SKIP)
9069 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9070 return value_zero (type, not_lval);
9072 return value_val_atr (type, arg1);
9075 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9076 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9077 if (noside == EVAL_SKIP)
9079 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9080 return value_zero (value_type (arg1), not_lval);
9083 /* For integer exponentiation operations,
9084 only promote the first argument. */
9085 if (is_integral_type (value_type (arg2)))
9086 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9088 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9090 return value_binop (arg1, arg2, op);
9094 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9095 if (noside == EVAL_SKIP)
9101 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9102 if (noside == EVAL_SKIP)
9104 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9105 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
9106 return value_neg (arg1);
9111 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9112 if (noside == EVAL_SKIP)
9114 type = ada_check_typedef (value_type (arg1));
9115 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9117 if (ada_is_array_descriptor_type (type))
9118 /* GDB allows dereferencing GNAT array descriptors. */
9120 struct type *arrType = ada_type_of_array (arg1, 0);
9121 if (arrType == NULL)
9122 error (_("Attempt to dereference null array pointer."));
9123 return value_at_lazy (arrType, 0);
9125 else if (TYPE_CODE (type) == TYPE_CODE_PTR
9126 || TYPE_CODE (type) == TYPE_CODE_REF
9127 /* In C you can dereference an array to get the 1st elt. */
9128 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
9130 type = to_static_fixed_type
9132 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
9134 return value_zero (type, lval_memory);
9136 else if (TYPE_CODE (type) == TYPE_CODE_INT)
9138 /* GDB allows dereferencing an int. */
9139 if (expect_type == NULL)
9140 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
9145 to_static_fixed_type (ada_aligned_type (expect_type));
9146 return value_zero (expect_type, lval_memory);
9150 error (_("Attempt to take contents of a non-pointer value."));
9152 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
9153 type = ada_check_typedef (value_type (arg1));
9155 if (TYPE_CODE (type) == TYPE_CODE_INT)
9156 /* GDB allows dereferencing an int. If we were given
9157 the expect_type, then use that as the target type.
9158 Otherwise, assume that the target type is an int. */
9160 if (expect_type != NULL)
9161 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
9164 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
9165 (CORE_ADDR) value_as_address (arg1));
9168 if (ada_is_array_descriptor_type (type))
9169 /* GDB allows dereferencing GNAT array descriptors. */
9170 return ada_coerce_to_simple_array (arg1);
9172 return ada_value_ind (arg1);
9174 case STRUCTOP_STRUCT:
9175 tem = longest_to_int (exp->elts[pc + 1].longconst);
9176 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
9177 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9178 if (noside == EVAL_SKIP)
9180 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9182 struct type *type1 = value_type (arg1);
9183 if (ada_is_tagged_type (type1, 1))
9185 type = ada_lookup_struct_elt_type (type1,
9186 &exp->elts[pc + 2].string,
9189 /* In this case, we assume that the field COULD exist
9190 in some extension of the type. Return an object of
9191 "type" void, which will match any formal
9192 (see ada_type_match). */
9193 return value_zero (builtin_type_void, lval_memory);
9197 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
9200 return value_zero (ada_aligned_type (type), lval_memory);
9204 ada_to_fixed_value (unwrap_value
9205 (ada_value_struct_elt
9206 (arg1, &exp->elts[pc + 2].string, 0)));
9208 /* The value is not supposed to be used. This is here to make it
9209 easier to accommodate expressions that contain types. */
9211 if (noside == EVAL_SKIP)
9213 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9214 return allocate_value (exp->elts[pc + 1].type);
9216 error (_("Attempt to use a type name as an expression"));
9221 case OP_DISCRETE_RANGE:
9224 if (noside == EVAL_NORMAL)
9228 error (_("Undefined name, ambiguous name, or renaming used in "
9229 "component association: %s."), &exp->elts[pc+2].string);
9231 error (_("Aggregates only allowed on the right of an assignment"));
9233 internal_error (__FILE__, __LINE__, _("aggregate apparently mangled"));
9236 ada_forward_operator_length (exp, pc, &oplen, &nargs);
9238 for (tem = 0; tem < nargs; tem += 1)
9239 ada_evaluate_subexp (NULL, exp, pos, noside);
9244 return value_from_longest (builtin_type_int8, (LONGEST) 1);
9250 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9251 type name that encodes the 'small and 'delta information.
9252 Otherwise, return NULL. */
9255 fixed_type_info (struct type *type)
9257 const char *name = ada_type_name (type);
9258 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
9260 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
9262 const char *tail = strstr (name, "___XF_");
9268 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
9269 return fixed_type_info (TYPE_TARGET_TYPE (type));
9274 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9277 ada_is_fixed_point_type (struct type *type)
9279 return fixed_type_info (type) != NULL;
9282 /* Return non-zero iff TYPE represents a System.Address type. */
9285 ada_is_system_address_type (struct type *type)
9287 return (TYPE_NAME (type)
9288 && strcmp (TYPE_NAME (type), "system__address") == 0);
9291 /* Assuming that TYPE is the representation of an Ada fixed-point
9292 type, return its delta, or -1 if the type is malformed and the
9293 delta cannot be determined. */
9296 ada_delta (struct type *type)
9298 const char *encoding = fixed_type_info (type);
9301 /* Strictly speaking, num and den are encoded as integer. However,
9302 they may not fit into a long, and they will have to be converted
9303 to DOUBLEST anyway. So scan them as DOUBLEST. */
9304 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
9311 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9312 factor ('SMALL value) associated with the type. */
9315 scaling_factor (struct type *type)
9317 const char *encoding = fixed_type_info (type);
9318 DOUBLEST num0, den0, num1, den1;
9321 /* Strictly speaking, num's and den's are encoded as integer. However,
9322 they may not fit into a long, and they will have to be converted
9323 to DOUBLEST anyway. So scan them as DOUBLEST. */
9324 n = sscanf (encoding,
9325 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT
9326 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
9327 &num0, &den0, &num1, &den1);
9338 /* Assuming that X is the representation of a value of fixed-point
9339 type TYPE, return its floating-point equivalent. */
9342 ada_fixed_to_float (struct type *type, LONGEST x)
9344 return (DOUBLEST) x *scaling_factor (type);
9347 /* The representation of a fixed-point value of type TYPE
9348 corresponding to the value X. */
9351 ada_float_to_fixed (struct type *type, DOUBLEST x)
9353 return (LONGEST) (x / scaling_factor (type) + 0.5);
9357 /* VAX floating formats */
9359 /* Non-zero iff TYPE represents one of the special VAX floating-point
9363 ada_is_vax_floating_type (struct type *type)
9366 (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
9369 && (TYPE_CODE (type) == TYPE_CODE_INT
9370 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9371 && strncmp (ada_type_name (type) + name_len - 6, "___XF", 5) == 0;
9374 /* The type of special VAX floating-point type this is, assuming
9375 ada_is_vax_floating_point. */
9378 ada_vax_float_type_suffix (struct type *type)
9380 return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
9383 /* A value representing the special debugging function that outputs
9384 VAX floating-point values of the type represented by TYPE. Assumes
9385 ada_is_vax_floating_type (TYPE). */
9388 ada_vax_float_print_function (struct type *type)
9390 switch (ada_vax_float_type_suffix (type))
9393 return get_var_value ("DEBUG_STRING_F", 0);
9395 return get_var_value ("DEBUG_STRING_D", 0);
9397 return get_var_value ("DEBUG_STRING_G", 0);
9399 error (_("invalid VAX floating-point type"));
9406 /* Scan STR beginning at position K for a discriminant name, and
9407 return the value of that discriminant field of DVAL in *PX. If
9408 PNEW_K is not null, put the position of the character beyond the
9409 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9410 not alter *PX and *PNEW_K if unsuccessful. */
9413 scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
9416 static char *bound_buffer = NULL;
9417 static size_t bound_buffer_len = 0;
9420 struct value *bound_val;
9422 if (dval == NULL || str == NULL || str[k] == '\0')
9425 pend = strstr (str + k, "__");
9429 k += strlen (bound);
9433 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
9434 bound = bound_buffer;
9435 strncpy (bound_buffer, str + k, pend - (str + k));
9436 bound[pend - (str + k)] = '\0';
9440 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
9441 if (bound_val == NULL)
9444 *px = value_as_long (bound_val);
9450 /* Value of variable named NAME in the current environment. If
9451 no such variable found, then if ERR_MSG is null, returns 0, and
9452 otherwise causes an error with message ERR_MSG. */
9454 static struct value *
9455 get_var_value (char *name, char *err_msg)
9457 struct ada_symbol_info *syms;
9460 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
9465 if (err_msg == NULL)
9468 error (("%s"), err_msg);
9471 return value_of_variable (syms[0].sym, syms[0].block);
9474 /* Value of integer variable named NAME in the current environment. If
9475 no such variable found, returns 0, and sets *FLAG to 0. If
9476 successful, sets *FLAG to 1. */
9479 get_int_var_value (char *name, int *flag)
9481 struct value *var_val = get_var_value (name, 0);
9493 return value_as_long (var_val);
9498 /* Return a range type whose base type is that of the range type named
9499 NAME in the current environment, and whose bounds are calculated
9500 from NAME according to the GNAT range encoding conventions.
9501 Extract discriminant values, if needed, from DVAL. If a new type
9502 must be created, allocate in OBJFILE's space. The bounds
9503 information, in general, is encoded in NAME, the base type given in
9504 the named range type. */
9506 static struct type *
9507 to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
9509 struct type *raw_type = ada_find_any_type (name);
9510 struct type *base_type;
9513 if (raw_type == NULL)
9514 base_type = builtin_type_int32;
9515 else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
9516 base_type = TYPE_TARGET_TYPE (raw_type);
9518 base_type = raw_type;
9520 subtype_info = strstr (name, "___XD");
9521 if (subtype_info == NULL)
9523 LONGEST L = discrete_type_low_bound (raw_type);
9524 LONGEST U = discrete_type_high_bound (raw_type);
9525 if (L < INT_MIN || U > INT_MAX)
9528 return create_range_type (alloc_type (objfile), raw_type,
9529 discrete_type_low_bound (raw_type),
9530 discrete_type_high_bound (raw_type));
9534 static char *name_buf = NULL;
9535 static size_t name_len = 0;
9536 int prefix_len = subtype_info - name;
9542 GROW_VECT (name_buf, name_len, prefix_len + 5);
9543 strncpy (name_buf, name, prefix_len);
9544 name_buf[prefix_len] = '\0';
9547 bounds_str = strchr (subtype_info, '_');
9550 if (*subtype_info == 'L')
9552 if (!ada_scan_number (bounds_str, n, &L, &n)
9553 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
9555 if (bounds_str[n] == '_')
9557 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
9564 strcpy (name_buf + prefix_len, "___L");
9565 L = get_int_var_value (name_buf, &ok);
9568 lim_warning (_("Unknown lower bound, using 1."));
9573 if (*subtype_info == 'U')
9575 if (!ada_scan_number (bounds_str, n, &U, &n)
9576 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
9582 strcpy (name_buf + prefix_len, "___U");
9583 U = get_int_var_value (name_buf, &ok);
9586 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
9591 if (objfile == NULL)
9592 objfile = TYPE_OBJFILE (base_type);
9593 type = create_range_type (alloc_type (objfile), base_type, L, U);
9594 TYPE_NAME (type) = name;
9599 /* True iff NAME is the name of a range type. */
9602 ada_is_range_type_name (const char *name)
9604 return (name != NULL && strstr (name, "___XD"));
9610 /* True iff TYPE is an Ada modular type. */
9613 ada_is_modular_type (struct type *type)
9615 struct type *subranged_type = base_type (type);
9617 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
9618 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
9619 && TYPE_UNSIGNED (subranged_type));
9622 /* Try to determine the lower and upper bounds of the given modular type
9623 using the type name only. Return non-zero and set L and U as the lower
9624 and upper bounds (respectively) if successful. */
9627 ada_modulus_from_name (struct type *type, ULONGEST *modulus)
9629 char *name = ada_type_name (type);
9637 /* Discrete type bounds are encoded using an __XD suffix. In our case,
9638 we are looking for static bounds, which means an __XDLU suffix.
9639 Moreover, we know that the lower bound of modular types is always
9640 zero, so the actual suffix should start with "__XDLU_0__", and
9641 then be followed by the upper bound value. */
9642 suffix = strstr (name, "__XDLU_0__");
9646 if (!ada_scan_number (suffix, k, &U, NULL))
9649 *modulus = (ULONGEST) U + 1;
9653 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9656 ada_modulus (struct type *type)
9660 /* Normally, the modulus of a modular type is equal to the value of
9661 its upper bound + 1. However, the upper bound is currently stored
9662 as an int, which is not always big enough to hold the actual bound
9663 value. To workaround this, try to take advantage of the encoding
9664 that GNAT uses with with discrete types. To avoid some unnecessary
9665 parsing, we do this only when the size of TYPE is greater than
9666 the size of the field holding the bound. */
9667 if (TYPE_LENGTH (type) > sizeof (TYPE_HIGH_BOUND (type))
9668 && ada_modulus_from_name (type, &modulus))
9671 return (ULONGEST) (unsigned int) TYPE_HIGH_BOUND (type) + 1;
9675 /* Ada exception catchpoint support:
9676 ---------------------------------
9678 We support 3 kinds of exception catchpoints:
9679 . catchpoints on Ada exceptions
9680 . catchpoints on unhandled Ada exceptions
9681 . catchpoints on failed assertions
9683 Exceptions raised during failed assertions, or unhandled exceptions
9684 could perfectly be caught with the general catchpoint on Ada exceptions.
9685 However, we can easily differentiate these two special cases, and having
9686 the option to distinguish these two cases from the rest can be useful
9687 to zero-in on certain situations.
9689 Exception catchpoints are a specialized form of breakpoint,
9690 since they rely on inserting breakpoints inside known routines
9691 of the GNAT runtime. The implementation therefore uses a standard
9692 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9695 Support in the runtime for exception catchpoints have been changed
9696 a few times already, and these changes affect the implementation
9697 of these catchpoints. In order to be able to support several
9698 variants of the runtime, we use a sniffer that will determine
9699 the runtime variant used by the program being debugged.
9701 At this time, we do not support the use of conditions on Ada exception
9702 catchpoints. The COND and COND_STRING fields are therefore set
9703 to NULL (most of the time, see below).
9705 Conditions where EXP_STRING, COND, and COND_STRING are used:
9707 When a user specifies the name of a specific exception in the case
9708 of catchpoints on Ada exceptions, we store the name of that exception
9709 in the EXP_STRING. We then translate this request into an actual
9710 condition stored in COND_STRING, and then parse it into an expression
9713 /* The different types of catchpoints that we introduced for catching
9716 enum exception_catchpoint_kind
9719 ex_catch_exception_unhandled,
9723 /* Ada's standard exceptions. */
9725 static char *standard_exc[] = {
9732 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
9734 /* A structure that describes how to support exception catchpoints
9735 for a given executable. */
9737 struct exception_support_info
9739 /* The name of the symbol to break on in order to insert
9740 a catchpoint on exceptions. */
9741 const char *catch_exception_sym;
9743 /* The name of the symbol to break on in order to insert
9744 a catchpoint on unhandled exceptions. */
9745 const char *catch_exception_unhandled_sym;
9747 /* The name of the symbol to break on in order to insert
9748 a catchpoint on failed assertions. */
9749 const char *catch_assert_sym;
9751 /* Assuming that the inferior just triggered an unhandled exception
9752 catchpoint, this function is responsible for returning the address
9753 in inferior memory where the name of that exception is stored.
9754 Return zero if the address could not be computed. */
9755 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
9758 static CORE_ADDR ada_unhandled_exception_name_addr (void);
9759 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
9761 /* The following exception support info structure describes how to
9762 implement exception catchpoints with the latest version of the
9763 Ada runtime (as of 2007-03-06). */
9765 static const struct exception_support_info default_exception_support_info =
9767 "__gnat_debug_raise_exception", /* catch_exception_sym */
9768 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9769 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9770 ada_unhandled_exception_name_addr
9773 /* The following exception support info structure describes how to
9774 implement exception catchpoints with a slightly older version
9775 of the Ada runtime. */
9777 static const struct exception_support_info exception_support_info_fallback =
9779 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9780 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9781 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9782 ada_unhandled_exception_name_addr_from_raise
9785 /* For each executable, we sniff which exception info structure to use
9786 and cache it in the following global variable. */
9788 static const struct exception_support_info *exception_info = NULL;
9790 /* Inspect the Ada runtime and determine which exception info structure
9791 should be used to provide support for exception catchpoints.
9793 This function will always set exception_info, or raise an error. */
9796 ada_exception_support_info_sniffer (void)
9800 /* If the exception info is already known, then no need to recompute it. */
9801 if (exception_info != NULL)
9804 /* Check the latest (default) exception support info. */
9805 sym = standard_lookup (default_exception_support_info.catch_exception_sym,
9809 exception_info = &default_exception_support_info;
9813 /* Try our fallback exception suport info. */
9814 sym = standard_lookup (exception_support_info_fallback.catch_exception_sym,
9818 exception_info = &exception_support_info_fallback;
9822 /* Sometimes, it is normal for us to not be able to find the routine
9823 we are looking for. This happens when the program is linked with
9824 the shared version of the GNAT runtime, and the program has not been
9825 started yet. Inform the user of these two possible causes if
9828 if (ada_update_initial_language (language_unknown, NULL) != language_ada)
9829 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9831 /* If the symbol does not exist, then check that the program is
9832 already started, to make sure that shared libraries have been
9833 loaded. If it is not started, this may mean that the symbol is
9834 in a shared library. */
9836 if (ptid_get_pid (inferior_ptid) == 0)
9837 error (_("Unable to insert catchpoint. Try to start the program first."));
9839 /* At this point, we know that we are debugging an Ada program and
9840 that the inferior has been started, but we still are not able to
9841 find the run-time symbols. That can mean that we are in
9842 configurable run time mode, or that a-except as been optimized
9843 out by the linker... In any case, at this point it is not worth
9844 supporting this feature. */
9846 error (_("Cannot insert catchpoints in this configuration."));
9849 /* An observer of "executable_changed" events.
9850 Its role is to clear certain cached values that need to be recomputed
9851 each time a new executable is loaded by GDB. */
9854 ada_executable_changed_observer (void)
9856 /* If the executable changed, then it is possible that the Ada runtime
9857 is different. So we need to invalidate the exception support info
9859 exception_info = NULL;
9862 /* Return the name of the function at PC, NULL if could not find it.
9863 This function only checks the debugging information, not the symbol
9867 function_name_from_pc (CORE_ADDR pc)
9871 if (!find_pc_partial_function (pc, &func_name, NULL, NULL))
9877 /* True iff FRAME is very likely to be that of a function that is
9878 part of the runtime system. This is all very heuristic, but is
9879 intended to be used as advice as to what frames are uninteresting
9883 is_known_support_routine (struct frame_info *frame)
9885 struct symtab_and_line sal;
9889 /* If this code does not have any debugging information (no symtab),
9890 This cannot be any user code. */
9892 find_frame_sal (frame, &sal);
9893 if (sal.symtab == NULL)
9896 /* If there is a symtab, but the associated source file cannot be
9897 located, then assume this is not user code: Selecting a frame
9898 for which we cannot display the code would not be very helpful
9899 for the user. This should also take care of case such as VxWorks
9900 where the kernel has some debugging info provided for a few units. */
9902 if (symtab_to_fullname (sal.symtab) == NULL)
9905 /* Check the unit filename againt the Ada runtime file naming.
9906 We also check the name of the objfile against the name of some
9907 known system libraries that sometimes come with debugging info
9910 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
9912 re_comp (known_runtime_file_name_patterns[i]);
9913 if (re_exec (sal.symtab->filename))
9915 if (sal.symtab->objfile != NULL
9916 && re_exec (sal.symtab->objfile->name))
9920 /* Check whether the function is a GNAT-generated entity. */
9922 func_name = function_name_from_pc (get_frame_address_in_block (frame));
9923 if (func_name == NULL)
9926 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
9928 re_comp (known_auxiliary_function_name_patterns[i]);
9929 if (re_exec (func_name))
9936 /* Find the first frame that contains debugging information and that is not
9937 part of the Ada run-time, starting from FI and moving upward. */
9940 ada_find_printable_frame (struct frame_info *fi)
9942 for (; fi != NULL; fi = get_prev_frame (fi))
9944 if (!is_known_support_routine (fi))
9953 /* Assuming that the inferior just triggered an unhandled exception
9954 catchpoint, return the address in inferior memory where the name
9955 of the exception is stored.
9957 Return zero if the address could not be computed. */
9960 ada_unhandled_exception_name_addr (void)
9962 return parse_and_eval_address ("e.full_name");
9965 /* Same as ada_unhandled_exception_name_addr, except that this function
9966 should be used when the inferior uses an older version of the runtime,
9967 where the exception name needs to be extracted from a specific frame
9968 several frames up in the callstack. */
9971 ada_unhandled_exception_name_addr_from_raise (void)
9974 struct frame_info *fi;
9976 /* To determine the name of this exception, we need to select
9977 the frame corresponding to RAISE_SYM_NAME. This frame is
9978 at least 3 levels up, so we simply skip the first 3 frames
9979 without checking the name of their associated function. */
9980 fi = get_current_frame ();
9981 for (frame_level = 0; frame_level < 3; frame_level += 1)
9983 fi = get_prev_frame (fi);
9987 const char *func_name =
9988 function_name_from_pc (get_frame_address_in_block (fi));
9989 if (func_name != NULL
9990 && strcmp (func_name, exception_info->catch_exception_sym) == 0)
9991 break; /* We found the frame we were looking for... */
9992 fi = get_prev_frame (fi);
9999 return parse_and_eval_address ("id.full_name");
10002 /* Assuming the inferior just triggered an Ada exception catchpoint
10003 (of any type), return the address in inferior memory where the name
10004 of the exception is stored, if applicable.
10006 Return zero if the address could not be computed, or if not relevant. */
10009 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex,
10010 struct breakpoint *b)
10014 case ex_catch_exception:
10015 return (parse_and_eval_address ("e.full_name"));
10018 case ex_catch_exception_unhandled:
10019 return exception_info->unhandled_exception_name_addr ();
10022 case ex_catch_assert:
10023 return 0; /* Exception name is not relevant in this case. */
10027 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10031 return 0; /* Should never be reached. */
10034 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
10035 any error that ada_exception_name_addr_1 might cause to be thrown.
10036 When an error is intercepted, a warning with the error message is printed,
10037 and zero is returned. */
10040 ada_exception_name_addr (enum exception_catchpoint_kind ex,
10041 struct breakpoint *b)
10043 struct gdb_exception e;
10044 CORE_ADDR result = 0;
10046 TRY_CATCH (e, RETURN_MASK_ERROR)
10048 result = ada_exception_name_addr_1 (ex, b);
10053 warning (_("failed to get exception name: %s"), e.message);
10060 /* Implement the PRINT_IT method in the breakpoint_ops structure
10061 for all exception catchpoint kinds. */
10063 static enum print_stop_action
10064 print_it_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
10066 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
10067 char exception_name[256];
10071 read_memory (addr, exception_name, sizeof (exception_name) - 1);
10072 exception_name [sizeof (exception_name) - 1] = '\0';
10075 ada_find_printable_frame (get_current_frame ());
10077 annotate_catchpoint (b->number);
10080 case ex_catch_exception:
10082 printf_filtered (_("\nCatchpoint %d, %s at "),
10083 b->number, exception_name);
10085 printf_filtered (_("\nCatchpoint %d, exception at "), b->number);
10087 case ex_catch_exception_unhandled:
10089 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10090 b->number, exception_name);
10092 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10095 case ex_catch_assert:
10096 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10101 return PRINT_SRC_AND_LOC;
10104 /* Implement the PRINT_ONE method in the breakpoint_ops structure
10105 for all exception catchpoint kinds. */
10108 print_one_exception (enum exception_catchpoint_kind ex,
10109 struct breakpoint *b, CORE_ADDR *last_addr)
10111 struct value_print_options opts;
10113 get_user_print_options (&opts);
10114 if (opts.addressprint)
10116 annotate_field (4);
10117 ui_out_field_core_addr (uiout, "addr", b->loc->address);
10120 annotate_field (5);
10121 *last_addr = b->loc->address;
10124 case ex_catch_exception:
10125 if (b->exp_string != NULL)
10127 char *msg = xstrprintf (_("`%s' Ada exception"), b->exp_string);
10129 ui_out_field_string (uiout, "what", msg);
10133 ui_out_field_string (uiout, "what", "all Ada exceptions");
10137 case ex_catch_exception_unhandled:
10138 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
10141 case ex_catch_assert:
10142 ui_out_field_string (uiout, "what", "failed Ada assertions");
10146 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10151 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
10152 for all exception catchpoint kinds. */
10155 print_mention_exception (enum exception_catchpoint_kind ex,
10156 struct breakpoint *b)
10160 case ex_catch_exception:
10161 if (b->exp_string != NULL)
10162 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10163 b->number, b->exp_string);
10165 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b->number);
10169 case ex_catch_exception_unhandled:
10170 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10174 case ex_catch_assert:
10175 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b->number);
10179 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10184 /* Virtual table for "catch exception" breakpoints. */
10186 static enum print_stop_action
10187 print_it_catch_exception (struct breakpoint *b)
10189 return print_it_exception (ex_catch_exception, b);
10193 print_one_catch_exception (struct breakpoint *b, CORE_ADDR *last_addr)
10195 print_one_exception (ex_catch_exception, b, last_addr);
10199 print_mention_catch_exception (struct breakpoint *b)
10201 print_mention_exception (ex_catch_exception, b);
10204 static struct breakpoint_ops catch_exception_breakpoint_ops =
10208 NULL, /* breakpoint_hit */
10209 print_it_catch_exception,
10210 print_one_catch_exception,
10211 print_mention_catch_exception
10214 /* Virtual table for "catch exception unhandled" breakpoints. */
10216 static enum print_stop_action
10217 print_it_catch_exception_unhandled (struct breakpoint *b)
10219 return print_it_exception (ex_catch_exception_unhandled, b);
10223 print_one_catch_exception_unhandled (struct breakpoint *b, CORE_ADDR *last_addr)
10225 print_one_exception (ex_catch_exception_unhandled, b, last_addr);
10229 print_mention_catch_exception_unhandled (struct breakpoint *b)
10231 print_mention_exception (ex_catch_exception_unhandled, b);
10234 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops = {
10237 NULL, /* breakpoint_hit */
10238 print_it_catch_exception_unhandled,
10239 print_one_catch_exception_unhandled,
10240 print_mention_catch_exception_unhandled
10243 /* Virtual table for "catch assert" breakpoints. */
10245 static enum print_stop_action
10246 print_it_catch_assert (struct breakpoint *b)
10248 return print_it_exception (ex_catch_assert, b);
10252 print_one_catch_assert (struct breakpoint *b, CORE_ADDR *last_addr)
10254 print_one_exception (ex_catch_assert, b, last_addr);
10258 print_mention_catch_assert (struct breakpoint *b)
10260 print_mention_exception (ex_catch_assert, b);
10263 static struct breakpoint_ops catch_assert_breakpoint_ops = {
10266 NULL, /* breakpoint_hit */
10267 print_it_catch_assert,
10268 print_one_catch_assert,
10269 print_mention_catch_assert
10272 /* Return non-zero if B is an Ada exception catchpoint. */
10275 ada_exception_catchpoint_p (struct breakpoint *b)
10277 return (b->ops == &catch_exception_breakpoint_ops
10278 || b->ops == &catch_exception_unhandled_breakpoint_ops
10279 || b->ops == &catch_assert_breakpoint_ops);
10282 /* Return a newly allocated copy of the first space-separated token
10283 in ARGSP, and then adjust ARGSP to point immediately after that
10286 Return NULL if ARGPS does not contain any more tokens. */
10289 ada_get_next_arg (char **argsp)
10291 char *args = *argsp;
10295 /* Skip any leading white space. */
10297 while (isspace (*args))
10300 if (args[0] == '\0')
10301 return NULL; /* No more arguments. */
10303 /* Find the end of the current argument. */
10306 while (*end != '\0' && !isspace (*end))
10309 /* Adjust ARGSP to point to the start of the next argument. */
10313 /* Make a copy of the current argument and return it. */
10315 result = xmalloc (end - args + 1);
10316 strncpy (result, args, end - args);
10317 result[end - args] = '\0';
10322 /* Split the arguments specified in a "catch exception" command.
10323 Set EX to the appropriate catchpoint type.
10324 Set EXP_STRING to the name of the specific exception if
10325 specified by the user. */
10328 catch_ada_exception_command_split (char *args,
10329 enum exception_catchpoint_kind *ex,
10332 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
10333 char *exception_name;
10335 exception_name = ada_get_next_arg (&args);
10336 make_cleanup (xfree, exception_name);
10338 /* Check that we do not have any more arguments. Anything else
10341 while (isspace (*args))
10344 if (args[0] != '\0')
10345 error (_("Junk at end of expression"));
10347 discard_cleanups (old_chain);
10349 if (exception_name == NULL)
10351 /* Catch all exceptions. */
10352 *ex = ex_catch_exception;
10353 *exp_string = NULL;
10355 else if (strcmp (exception_name, "unhandled") == 0)
10357 /* Catch unhandled exceptions. */
10358 *ex = ex_catch_exception_unhandled;
10359 *exp_string = NULL;
10363 /* Catch a specific exception. */
10364 *ex = ex_catch_exception;
10365 *exp_string = exception_name;
10369 /* Return the name of the symbol on which we should break in order to
10370 implement a catchpoint of the EX kind. */
10372 static const char *
10373 ada_exception_sym_name (enum exception_catchpoint_kind ex)
10375 gdb_assert (exception_info != NULL);
10379 case ex_catch_exception:
10380 return (exception_info->catch_exception_sym);
10382 case ex_catch_exception_unhandled:
10383 return (exception_info->catch_exception_unhandled_sym);
10385 case ex_catch_assert:
10386 return (exception_info->catch_assert_sym);
10389 internal_error (__FILE__, __LINE__,
10390 _("unexpected catchpoint kind (%d)"), ex);
10394 /* Return the breakpoint ops "virtual table" used for catchpoints
10397 static struct breakpoint_ops *
10398 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex)
10402 case ex_catch_exception:
10403 return (&catch_exception_breakpoint_ops);
10405 case ex_catch_exception_unhandled:
10406 return (&catch_exception_unhandled_breakpoint_ops);
10408 case ex_catch_assert:
10409 return (&catch_assert_breakpoint_ops);
10412 internal_error (__FILE__, __LINE__,
10413 _("unexpected catchpoint kind (%d)"), ex);
10417 /* Return the condition that will be used to match the current exception
10418 being raised with the exception that the user wants to catch. This
10419 assumes that this condition is used when the inferior just triggered
10420 an exception catchpoint.
10422 The string returned is a newly allocated string that needs to be
10423 deallocated later. */
10426 ada_exception_catchpoint_cond_string (const char *exp_string)
10430 /* The standard exceptions are a special case. They are defined in
10431 runtime units that have been compiled without debugging info; if
10432 EXP_STRING is the not-fully-qualified name of a standard
10433 exception (e.g. "constraint_error") then, during the evaluation
10434 of the condition expression, the symbol lookup on this name would
10435 *not* return this standard exception. The catchpoint condition
10436 may then be set only on user-defined exceptions which have the
10437 same not-fully-qualified name (e.g. my_package.constraint_error).
10439 To avoid this unexcepted behavior, these standard exceptions are
10440 systematically prefixed by "standard". This means that "catch
10441 exception constraint_error" is rewritten into "catch exception
10442 standard.constraint_error".
10444 If an exception named contraint_error is defined in another package of
10445 the inferior program, then the only way to specify this exception as a
10446 breakpoint condition is to use its fully-qualified named:
10447 e.g. my_package.constraint_error. */
10449 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
10451 if (strcmp (standard_exc [i], exp_string) == 0)
10453 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
10457 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string);
10460 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
10462 static struct expression *
10463 ada_parse_catchpoint_condition (char *cond_string,
10464 struct symtab_and_line sal)
10466 return (parse_exp_1 (&cond_string, block_for_pc (sal.pc), 0));
10469 /* Return the symtab_and_line that should be used to insert an exception
10470 catchpoint of the TYPE kind.
10472 EX_STRING should contain the name of a specific exception
10473 that the catchpoint should catch, or NULL otherwise.
10475 The idea behind all the remaining parameters is that their names match
10476 the name of certain fields in the breakpoint structure that are used to
10477 handle exception catchpoints. This function returns the value to which
10478 these fields should be set, depending on the type of catchpoint we need
10481 If COND and COND_STRING are both non-NULL, any value they might
10482 hold will be free'ed, and then replaced by newly allocated ones.
10483 These parameters are left untouched otherwise. */
10485 static struct symtab_and_line
10486 ada_exception_sal (enum exception_catchpoint_kind ex, char *exp_string,
10487 char **addr_string, char **cond_string,
10488 struct expression **cond, struct breakpoint_ops **ops)
10490 const char *sym_name;
10491 struct symbol *sym;
10492 struct symtab_and_line sal;
10494 /* First, find out which exception support info to use. */
10495 ada_exception_support_info_sniffer ();
10497 /* Then lookup the function on which we will break in order to catch
10498 the Ada exceptions requested by the user. */
10500 sym_name = ada_exception_sym_name (ex);
10501 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
10503 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10504 that should be compiled with debugging information. As a result, we
10505 expect to find that symbol in the symtabs. If we don't find it, then
10506 the target most likely does not support Ada exceptions, or we cannot
10507 insert exception breakpoints yet, because the GNAT runtime hasn't been
10510 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10511 in such a way that no debugging information is produced for the symbol
10512 we are looking for. In this case, we could search the minimal symbols
10513 as a fall-back mechanism. This would still be operating in degraded
10514 mode, however, as we would still be missing the debugging information
10515 that is needed in order to extract the name of the exception being
10516 raised (this name is printed in the catchpoint message, and is also
10517 used when trying to catch a specific exception). We do not handle
10518 this case for now. */
10521 error (_("Unable to break on '%s' in this configuration."), sym_name);
10523 /* Make sure that the symbol we found corresponds to a function. */
10524 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
10525 error (_("Symbol \"%s\" is not a function (class = %d)"),
10526 sym_name, SYMBOL_CLASS (sym));
10528 sal = find_function_start_sal (sym, 1);
10530 /* Set ADDR_STRING. */
10532 *addr_string = xstrdup (sym_name);
10534 /* Set the COND and COND_STRING (if not NULL). */
10536 if (cond_string != NULL && cond != NULL)
10538 if (*cond_string != NULL)
10540 xfree (*cond_string);
10541 *cond_string = NULL;
10548 if (exp_string != NULL)
10550 *cond_string = ada_exception_catchpoint_cond_string (exp_string);
10551 *cond = ada_parse_catchpoint_condition (*cond_string, sal);
10556 *ops = ada_exception_breakpoint_ops (ex);
10561 /* Parse the arguments (ARGS) of the "catch exception" command.
10563 Set TYPE to the appropriate exception catchpoint type.
10564 If the user asked the catchpoint to catch only a specific
10565 exception, then save the exception name in ADDR_STRING.
10567 See ada_exception_sal for a description of all the remaining
10568 function arguments of this function. */
10570 struct symtab_and_line
10571 ada_decode_exception_location (char *args, char **addr_string,
10572 char **exp_string, char **cond_string,
10573 struct expression **cond,
10574 struct breakpoint_ops **ops)
10576 enum exception_catchpoint_kind ex;
10578 catch_ada_exception_command_split (args, &ex, exp_string);
10579 return ada_exception_sal (ex, *exp_string, addr_string, cond_string,
10583 struct symtab_and_line
10584 ada_decode_assert_location (char *args, char **addr_string,
10585 struct breakpoint_ops **ops)
10587 /* Check that no argument where provided at the end of the command. */
10591 while (isspace (*args))
10594 error (_("Junk at end of arguments."));
10597 return ada_exception_sal (ex_catch_assert, NULL, addr_string, NULL, NULL,
10602 /* Information about operators given special treatment in functions
10604 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10606 #define ADA_OPERATORS \
10607 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10608 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10609 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10610 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10611 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10612 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10613 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10614 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10615 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10616 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10617 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10618 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10619 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10620 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10621 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
10622 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10623 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10624 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10625 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
10628 ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp)
10630 switch (exp->elts[pc - 1].opcode)
10633 operator_length_standard (exp, pc, oplenp, argsp);
10636 #define OP_DEFN(op, len, args, binop) \
10637 case op: *oplenp = len; *argsp = args; break;
10643 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
10648 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
10654 ada_op_name (enum exp_opcode opcode)
10659 return op_name_standard (opcode);
10661 #define OP_DEFN(op, len, args, binop) case op: return #op;
10666 return "OP_AGGREGATE";
10668 return "OP_CHOICES";
10674 /* As for operator_length, but assumes PC is pointing at the first
10675 element of the operator, and gives meaningful results only for the
10676 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
10679 ada_forward_operator_length (struct expression *exp, int pc,
10680 int *oplenp, int *argsp)
10682 switch (exp->elts[pc].opcode)
10685 *oplenp = *argsp = 0;
10688 #define OP_DEFN(op, len, args, binop) \
10689 case op: *oplenp = len; *argsp = args; break;
10695 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
10700 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
10706 int len = longest_to_int (exp->elts[pc + 1].longconst);
10707 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
10715 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
10717 enum exp_opcode op = exp->elts[elt].opcode;
10722 ada_forward_operator_length (exp, elt, &oplen, &nargs);
10726 /* Ada attributes ('Foo). */
10729 case OP_ATR_LENGTH:
10733 case OP_ATR_MODULUS:
10740 case UNOP_IN_RANGE:
10742 /* XXX: gdb_sprint_host_address, type_sprint */
10743 fprintf_filtered (stream, _("Type @"));
10744 gdb_print_host_address (exp->elts[pc + 1].type, stream);
10745 fprintf_filtered (stream, " (");
10746 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
10747 fprintf_filtered (stream, ")");
10749 case BINOP_IN_BOUNDS:
10750 fprintf_filtered (stream, " (%d)",
10751 longest_to_int (exp->elts[pc + 2].longconst));
10753 case TERNOP_IN_RANGE:
10758 case OP_DISCRETE_RANGE:
10759 case OP_POSITIONAL:
10766 char *name = &exp->elts[elt + 2].string;
10767 int len = longest_to_int (exp->elts[elt + 1].longconst);
10768 fprintf_filtered (stream, "Text: `%.*s'", len, name);
10773 return dump_subexp_body_standard (exp, stream, elt);
10777 for (i = 0; i < nargs; i += 1)
10778 elt = dump_subexp (exp, stream, elt);
10783 /* The Ada extension of print_subexp (q.v.). */
10786 ada_print_subexp (struct expression *exp, int *pos,
10787 struct ui_file *stream, enum precedence prec)
10789 int oplen, nargs, i;
10791 enum exp_opcode op = exp->elts[pc].opcode;
10793 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10800 print_subexp_standard (exp, pos, stream, prec);
10804 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
10807 case BINOP_IN_BOUNDS:
10808 /* XXX: sprint_subexp */
10809 print_subexp (exp, pos, stream, PREC_SUFFIX);
10810 fputs_filtered (" in ", stream);
10811 print_subexp (exp, pos, stream, PREC_SUFFIX);
10812 fputs_filtered ("'range", stream);
10813 if (exp->elts[pc + 1].longconst > 1)
10814 fprintf_filtered (stream, "(%ld)",
10815 (long) exp->elts[pc + 1].longconst);
10818 case TERNOP_IN_RANGE:
10819 if (prec >= PREC_EQUAL)
10820 fputs_filtered ("(", stream);
10821 /* XXX: sprint_subexp */
10822 print_subexp (exp, pos, stream, PREC_SUFFIX);
10823 fputs_filtered (" in ", stream);
10824 print_subexp (exp, pos, stream, PREC_EQUAL);
10825 fputs_filtered (" .. ", stream);
10826 print_subexp (exp, pos, stream, PREC_EQUAL);
10827 if (prec >= PREC_EQUAL)
10828 fputs_filtered (")", stream);
10833 case OP_ATR_LENGTH:
10837 case OP_ATR_MODULUS:
10842 if (exp->elts[*pos].opcode == OP_TYPE)
10844 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
10845 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
10849 print_subexp (exp, pos, stream, PREC_SUFFIX);
10850 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
10854 for (tem = 1; tem < nargs; tem += 1)
10856 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
10857 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
10859 fputs_filtered (")", stream);
10864 type_print (exp->elts[pc + 1].type, "", stream, 0);
10865 fputs_filtered ("'(", stream);
10866 print_subexp (exp, pos, stream, PREC_PREFIX);
10867 fputs_filtered (")", stream);
10870 case UNOP_IN_RANGE:
10871 /* XXX: sprint_subexp */
10872 print_subexp (exp, pos, stream, PREC_SUFFIX);
10873 fputs_filtered (" in ", stream);
10874 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
10877 case OP_DISCRETE_RANGE:
10878 print_subexp (exp, pos, stream, PREC_SUFFIX);
10879 fputs_filtered ("..", stream);
10880 print_subexp (exp, pos, stream, PREC_SUFFIX);
10884 fputs_filtered ("others => ", stream);
10885 print_subexp (exp, pos, stream, PREC_SUFFIX);
10889 for (i = 0; i < nargs-1; i += 1)
10892 fputs_filtered ("|", stream);
10893 print_subexp (exp, pos, stream, PREC_SUFFIX);
10895 fputs_filtered (" => ", stream);
10896 print_subexp (exp, pos, stream, PREC_SUFFIX);
10899 case OP_POSITIONAL:
10900 print_subexp (exp, pos, stream, PREC_SUFFIX);
10904 fputs_filtered ("(", stream);
10905 for (i = 0; i < nargs; i += 1)
10908 fputs_filtered (", ", stream);
10909 print_subexp (exp, pos, stream, PREC_SUFFIX);
10911 fputs_filtered (")", stream);
10916 /* Table mapping opcodes into strings for printing operators
10917 and precedences of the operators. */
10919 static const struct op_print ada_op_print_tab[] = {
10920 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
10921 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
10922 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
10923 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
10924 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
10925 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
10926 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
10927 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
10928 {"<=", BINOP_LEQ, PREC_ORDER, 0},
10929 {">=", BINOP_GEQ, PREC_ORDER, 0},
10930 {">", BINOP_GTR, PREC_ORDER, 0},
10931 {"<", BINOP_LESS, PREC_ORDER, 0},
10932 {">>", BINOP_RSH, PREC_SHIFT, 0},
10933 {"<<", BINOP_LSH, PREC_SHIFT, 0},
10934 {"+", BINOP_ADD, PREC_ADD, 0},
10935 {"-", BINOP_SUB, PREC_ADD, 0},
10936 {"&", BINOP_CONCAT, PREC_ADD, 0},
10937 {"*", BINOP_MUL, PREC_MUL, 0},
10938 {"/", BINOP_DIV, PREC_MUL, 0},
10939 {"rem", BINOP_REM, PREC_MUL, 0},
10940 {"mod", BINOP_MOD, PREC_MUL, 0},
10941 {"**", BINOP_EXP, PREC_REPEAT, 0},
10942 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
10943 {"-", UNOP_NEG, PREC_PREFIX, 0},
10944 {"+", UNOP_PLUS, PREC_PREFIX, 0},
10945 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
10946 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
10947 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
10948 {".all", UNOP_IND, PREC_SUFFIX, 1},
10949 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
10950 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
10954 enum ada_primitive_types {
10955 ada_primitive_type_int,
10956 ada_primitive_type_long,
10957 ada_primitive_type_short,
10958 ada_primitive_type_char,
10959 ada_primitive_type_float,
10960 ada_primitive_type_double,
10961 ada_primitive_type_void,
10962 ada_primitive_type_long_long,
10963 ada_primitive_type_long_double,
10964 ada_primitive_type_natural,
10965 ada_primitive_type_positive,
10966 ada_primitive_type_system_address,
10967 nr_ada_primitive_types
10971 ada_language_arch_info (struct gdbarch *gdbarch,
10972 struct language_arch_info *lai)
10974 const struct builtin_type *builtin = builtin_type (gdbarch);
10975 lai->primitive_type_vector
10976 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
10978 lai->primitive_type_vector [ada_primitive_type_int] =
10979 init_type (TYPE_CODE_INT,
10980 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
10981 0, "integer", (struct objfile *) NULL);
10982 lai->primitive_type_vector [ada_primitive_type_long] =
10983 init_type (TYPE_CODE_INT,
10984 gdbarch_long_bit (gdbarch) / TARGET_CHAR_BIT,
10985 0, "long_integer", (struct objfile *) NULL);
10986 lai->primitive_type_vector [ada_primitive_type_short] =
10987 init_type (TYPE_CODE_INT,
10988 gdbarch_short_bit (gdbarch) / TARGET_CHAR_BIT,
10989 0, "short_integer", (struct objfile *) NULL);
10990 lai->string_char_type =
10991 lai->primitive_type_vector [ada_primitive_type_char] =
10992 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
10993 0, "character", (struct objfile *) NULL);
10994 lai->primitive_type_vector [ada_primitive_type_float] =
10995 init_type (TYPE_CODE_FLT,
10996 gdbarch_float_bit (gdbarch)/ TARGET_CHAR_BIT,
10997 0, "float", (struct objfile *) NULL);
10998 lai->primitive_type_vector [ada_primitive_type_double] =
10999 init_type (TYPE_CODE_FLT,
11000 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
11001 0, "long_float", (struct objfile *) NULL);
11002 lai->primitive_type_vector [ada_primitive_type_long_long] =
11003 init_type (TYPE_CODE_INT,
11004 gdbarch_long_long_bit (gdbarch) / TARGET_CHAR_BIT,
11005 0, "long_long_integer", (struct objfile *) NULL);
11006 lai->primitive_type_vector [ada_primitive_type_long_double] =
11007 init_type (TYPE_CODE_FLT,
11008 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
11009 0, "long_long_float", (struct objfile *) NULL);
11010 lai->primitive_type_vector [ada_primitive_type_natural] =
11011 init_type (TYPE_CODE_INT,
11012 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
11013 0, "natural", (struct objfile *) NULL);
11014 lai->primitive_type_vector [ada_primitive_type_positive] =
11015 init_type (TYPE_CODE_INT,
11016 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
11017 0, "positive", (struct objfile *) NULL);
11018 lai->primitive_type_vector [ada_primitive_type_void] = builtin->builtin_void;
11020 lai->primitive_type_vector [ada_primitive_type_system_address] =
11021 lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
11022 (struct objfile *) NULL));
11023 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
11024 = "system__address";
11026 lai->bool_type_symbol = NULL;
11027 lai->bool_type_default = builtin->builtin_bool;
11030 /* Language vector */
11032 /* Not really used, but needed in the ada_language_defn. */
11035 emit_char (int c, struct ui_file *stream, int quoter)
11037 ada_emit_char (c, stream, quoter, 1);
11043 warnings_issued = 0;
11044 return ada_parse ();
11047 static const struct exp_descriptor ada_exp_descriptor = {
11049 ada_operator_length,
11051 ada_dump_subexp_body,
11052 ada_evaluate_subexp
11055 const struct language_defn ada_language_defn = {
11056 "ada", /* Language name */
11060 case_sensitive_on, /* Yes, Ada is case-insensitive, but
11061 that's not quite what this means. */
11063 macro_expansion_no,
11064 &ada_exp_descriptor,
11068 ada_printchar, /* Print a character constant */
11069 ada_printstr, /* Function to print string constant */
11070 emit_char, /* Function to print single char (not used) */
11071 ada_print_type, /* Print a type using appropriate syntax */
11072 default_print_typedef, /* Print a typedef using appropriate syntax */
11073 ada_val_print, /* Print a value using appropriate syntax */
11074 ada_value_print, /* Print a top-level value */
11075 NULL, /* Language specific skip_trampoline */
11076 NULL, /* name_of_this */
11077 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
11078 basic_lookup_transparent_type, /* lookup_transparent_type */
11079 ada_la_decode, /* Language specific symbol demangler */
11080 NULL, /* Language specific class_name_from_physname */
11081 ada_op_print_tab, /* expression operators for printing */
11082 0, /* c-style arrays */
11083 1, /* String lower bound */
11084 ada_get_gdb_completer_word_break_characters,
11085 ada_make_symbol_completion_list,
11086 ada_language_arch_info,
11087 ada_print_array_index,
11088 default_pass_by_reference,
11093 /* Provide a prototype to silence -Wmissing-prototypes. */
11094 extern initialize_file_ftype _initialize_ada_language;
11097 _initialize_ada_language (void)
11099 add_language (&ada_language_defn);
11101 varsize_limit = 65536;
11103 obstack_init (&symbol_list_obstack);
11105 decoded_names_store = htab_create_alloc
11106 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
11107 NULL, xcalloc, xfree);
11109 observer_attach_executable_changed (ada_executable_changed_observer);