1 /* Ada language support routines for GDB, the GNU debugger. Copyright (C)
3 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005, 2007
4 Free Software Foundation, Inc.
6 This file is part of GDB.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
24 #include "gdb_string.h"
28 #include "gdb_regex.h"
33 #include "expression.h"
34 #include "parser-defs.h"
40 #include "breakpoint.h"
43 #include "gdb_obstack.h"
45 #include "completer.h"
52 #include "dictionary.h"
53 #include "exceptions.h"
60 /* 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 int format, enum val_prettyprint pretty)
358 LA_VALUE_PRINT (index_value, stream, format, pretty);
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 /* Create a value of type TYPE whose contents come from VALADDR, if it
469 is non-null, and whose memory address (in the inferior) is
473 value_from_contents_and_address (struct type *type,
474 const gdb_byte *valaddr,
477 struct value *v = allocate_value (type);
479 set_value_lazy (v, 1);
481 memcpy (value_contents_raw (v), valaddr, TYPE_LENGTH (type));
482 VALUE_ADDRESS (v) = address;
484 VALUE_LVAL (v) = lval_memory;
488 /* The contents of value VAL, treated as a value of type TYPE. The
489 result is an lval in memory if VAL is. */
491 static struct value *
492 coerce_unspec_val_to_type (struct value *val, struct type *type)
494 type = ada_check_typedef (type);
495 if (value_type (val) == type)
499 struct value *result;
501 /* Make sure that the object size is not unreasonable before
502 trying to allocate some memory for it. */
505 result = allocate_value (type);
506 VALUE_LVAL (result) = VALUE_LVAL (val);
507 set_value_bitsize (result, value_bitsize (val));
508 set_value_bitpos (result, value_bitpos (val));
509 VALUE_ADDRESS (result) = VALUE_ADDRESS (val) + value_offset (val);
511 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
512 set_value_lazy (result, 1);
514 memcpy (value_contents_raw (result), value_contents (val),
520 static const gdb_byte *
521 cond_offset_host (const gdb_byte *valaddr, long offset)
526 return valaddr + offset;
530 cond_offset_target (CORE_ADDR address, long offset)
535 return address + offset;
538 /* Issue a warning (as for the definition of warning in utils.c, but
539 with exactly one argument rather than ...), unless the limit on the
540 number of warnings has passed during the evaluation of the current
543 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
544 provided by "complaint". */
545 static void lim_warning (const char *format, ...) ATTR_FORMAT (printf, 1, 2);
548 lim_warning (const char *format, ...)
551 va_start (args, format);
553 warnings_issued += 1;
554 if (warnings_issued <= warning_limit)
555 vwarning (format, args);
560 /* Issue an error if the size of an object of type T is unreasonable,
561 i.e. if it would be a bad idea to allocate a value of this type in
565 check_size (const struct type *type)
567 if (TYPE_LENGTH (type) > varsize_limit)
568 error (_("object size is larger than varsize-limit"));
572 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
573 gdbtypes.h, but some of the necessary definitions in that file
574 seem to have gone missing. */
576 /* Maximum value of a SIZE-byte signed integer type. */
578 max_of_size (int size)
580 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
581 return top_bit | (top_bit - 1);
584 /* Minimum value of a SIZE-byte signed integer type. */
586 min_of_size (int size)
588 return -max_of_size (size) - 1;
591 /* Maximum value of a SIZE-byte unsigned integer type. */
593 umax_of_size (int size)
595 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
596 return top_bit | (top_bit - 1);
599 /* Maximum value of integral type T, as a signed quantity. */
601 max_of_type (struct type *t)
603 if (TYPE_UNSIGNED (t))
604 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
606 return max_of_size (TYPE_LENGTH (t));
609 /* Minimum value of integral type T, as a signed quantity. */
611 min_of_type (struct type *t)
613 if (TYPE_UNSIGNED (t))
616 return min_of_size (TYPE_LENGTH (t));
619 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
621 discrete_type_high_bound (struct type *type)
623 switch (TYPE_CODE (type))
625 case TYPE_CODE_RANGE:
626 return TYPE_HIGH_BOUND (type);
628 return TYPE_FIELD_BITPOS (type, TYPE_NFIELDS (type) - 1);
633 return max_of_type (type);
635 error (_("Unexpected type in discrete_type_high_bound."));
639 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
641 discrete_type_low_bound (struct type *type)
643 switch (TYPE_CODE (type))
645 case TYPE_CODE_RANGE:
646 return TYPE_LOW_BOUND (type);
648 return TYPE_FIELD_BITPOS (type, 0);
653 return min_of_type (type);
655 error (_("Unexpected type in discrete_type_low_bound."));
659 /* The identity on non-range types. For range types, the underlying
660 non-range scalar type. */
663 base_type (struct type *type)
665 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
667 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
669 type = TYPE_TARGET_TYPE (type);
675 /* Language Selection */
677 /* If the main program is in Ada, return language_ada, otherwise return LANG
678 (the main program is in Ada iif the adainit symbol is found).
680 MAIN_PST is not used. */
683 ada_update_initial_language (enum language lang,
684 struct partial_symtab *main_pst)
686 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
687 (struct objfile *) NULL) != NULL)
693 /* If the main procedure is written in Ada, then return its name.
694 The result is good until the next call. Return NULL if the main
695 procedure doesn't appear to be in Ada. */
700 struct minimal_symbol *msym;
701 CORE_ADDR main_program_name_addr;
702 static char main_program_name[1024];
704 /* For Ada, the name of the main procedure is stored in a specific
705 string constant, generated by the binder. Look for that symbol,
706 extract its address, and then read that string. If we didn't find
707 that string, then most probably the main procedure is not written
709 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
713 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
714 if (main_program_name_addr == 0)
715 error (_("Invalid address for Ada main program name."));
717 extract_string (main_program_name_addr, main_program_name);
718 return main_program_name;
721 /* The main procedure doesn't seem to be in Ada. */
727 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
730 const struct ada_opname_map ada_opname_table[] = {
731 {"Oadd", "\"+\"", BINOP_ADD},
732 {"Osubtract", "\"-\"", BINOP_SUB},
733 {"Omultiply", "\"*\"", BINOP_MUL},
734 {"Odivide", "\"/\"", BINOP_DIV},
735 {"Omod", "\"mod\"", BINOP_MOD},
736 {"Orem", "\"rem\"", BINOP_REM},
737 {"Oexpon", "\"**\"", BINOP_EXP},
738 {"Olt", "\"<\"", BINOP_LESS},
739 {"Ole", "\"<=\"", BINOP_LEQ},
740 {"Ogt", "\">\"", BINOP_GTR},
741 {"Oge", "\">=\"", BINOP_GEQ},
742 {"Oeq", "\"=\"", BINOP_EQUAL},
743 {"One", "\"/=\"", BINOP_NOTEQUAL},
744 {"Oand", "\"and\"", BINOP_BITWISE_AND},
745 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
746 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
747 {"Oconcat", "\"&\"", BINOP_CONCAT},
748 {"Oabs", "\"abs\"", UNOP_ABS},
749 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
750 {"Oadd", "\"+\"", UNOP_PLUS},
751 {"Osubtract", "\"-\"", UNOP_NEG},
755 /* Return non-zero if STR should be suppressed in info listings. */
758 is_suppressed_name (const char *str)
760 if (strncmp (str, "_ada_", 5) == 0)
762 if (str[0] == '_' || str[0] == '\000')
767 const char *suffix = strstr (str, "___");
768 if (suffix != NULL && suffix[3] != 'X')
771 suffix = str + strlen (str);
772 for (p = suffix - 1; p != str; p -= 1)
776 if (p[0] == 'X' && p[-1] != '_')
780 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
781 if (strncmp (ada_opname_table[i].encoded, p,
782 strlen (ada_opname_table[i].encoded)) == 0)
791 /* The "encoded" form of DECODED, according to GNAT conventions.
792 The result is valid until the next call to ada_encode. */
795 ada_encode (const char *decoded)
797 static char *encoding_buffer = NULL;
798 static size_t encoding_buffer_size = 0;
805 GROW_VECT (encoding_buffer, encoding_buffer_size,
806 2 * strlen (decoded) + 10);
809 for (p = decoded; *p != '\0'; p += 1)
813 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
818 const struct ada_opname_map *mapping;
820 for (mapping = ada_opname_table;
821 mapping->encoded != NULL
822 && strncmp (mapping->decoded, p,
823 strlen (mapping->decoded)) != 0; mapping += 1)
825 if (mapping->encoded == NULL)
826 error (_("invalid Ada operator name: %s"), p);
827 strcpy (encoding_buffer + k, mapping->encoded);
828 k += strlen (mapping->encoded);
833 encoding_buffer[k] = *p;
838 encoding_buffer[k] = '\0';
839 return encoding_buffer;
842 /* Return NAME folded to lower case, or, if surrounded by single
843 quotes, unfolded, but with the quotes stripped away. Result good
847 ada_fold_name (const char *name)
849 static char *fold_buffer = NULL;
850 static size_t fold_buffer_size = 0;
852 int len = strlen (name);
853 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
857 strncpy (fold_buffer, name + 1, len - 2);
858 fold_buffer[len - 2] = '\000';
863 for (i = 0; i <= len; i += 1)
864 fold_buffer[i] = tolower (name[i]);
870 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
873 is_lower_alphanum (const char c)
875 return (isdigit (c) || (isalpha (c) && islower (c)));
878 /* Remove either of these suffixes:
883 These are suffixes introduced by the compiler for entities such as
884 nested subprogram for instance, in order to avoid name clashes.
885 They do not serve any purpose for the debugger. */
888 ada_remove_trailing_digits (const char *encoded, int *len)
890 if (*len > 1 && isdigit (encoded[*len - 1]))
893 while (i > 0 && isdigit (encoded[i]))
895 if (i >= 0 && encoded[i] == '.')
897 else if (i >= 0 && encoded[i] == '$')
899 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
901 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
906 /* Remove the suffix introduced by the compiler for protected object
910 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
912 /* Remove trailing N. */
914 /* Protected entry subprograms are broken into two
915 separate subprograms: The first one is unprotected, and has
916 a 'N' suffix; the second is the protected version, and has
917 the 'P' suffix. The second calls the first one after handling
918 the protection. Since the P subprograms are internally generated,
919 we leave these names undecoded, giving the user a clue that this
920 entity is internal. */
923 && encoded[*len - 1] == 'N'
924 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
928 /* If ENCODED follows the GNAT entity encoding conventions, then return
929 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
932 The resulting string is valid until the next call of ada_decode.
933 If the string is unchanged by decoding, the original string pointer
937 ada_decode (const char *encoded)
944 static char *decoding_buffer = NULL;
945 static size_t decoding_buffer_size = 0;
947 /* The name of the Ada main procedure starts with "_ada_".
948 This prefix is not part of the decoded name, so skip this part
949 if we see this prefix. */
950 if (strncmp (encoded, "_ada_", 5) == 0)
953 /* If the name starts with '_', then it is not a properly encoded
954 name, so do not attempt to decode it. Similarly, if the name
955 starts with '<', the name should not be decoded. */
956 if (encoded[0] == '_' || encoded[0] == '<')
959 len0 = strlen (encoded);
961 ada_remove_trailing_digits (encoded, &len0);
962 ada_remove_po_subprogram_suffix (encoded, &len0);
964 /* Remove the ___X.* suffix if present. Do not forget to verify that
965 the suffix is located before the current "end" of ENCODED. We want
966 to avoid re-matching parts of ENCODED that have previously been
967 marked as discarded (by decrementing LEN0). */
968 p = strstr (encoded, "___");
969 if (p != NULL && p - encoded < len0 - 3)
977 /* Remove any trailing TKB suffix. It tells us that this symbol
978 is for the body of a task, but that information does not actually
979 appear in the decoded name. */
981 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
984 /* Remove trailing "B" suffixes. */
985 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
987 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
990 /* Make decoded big enough for possible expansion by operator name. */
992 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
993 decoded = decoding_buffer;
995 /* Remove trailing __{digit}+ or trailing ${digit}+. */
997 if (len0 > 1 && isdigit (encoded[len0 - 1]))
1000 while ((i >= 0 && isdigit (encoded[i]))
1001 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1003 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1005 else if (encoded[i] == '$')
1009 /* The first few characters that are not alphabetic are not part
1010 of any encoding we use, so we can copy them over verbatim. */
1012 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1013 decoded[j] = encoded[i];
1018 /* Is this a symbol function? */
1019 if (at_start_name && encoded[i] == 'O')
1022 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1024 int op_len = strlen (ada_opname_table[k].encoded);
1025 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1027 && !isalnum (encoded[i + op_len]))
1029 strcpy (decoded + j, ada_opname_table[k].decoded);
1032 j += strlen (ada_opname_table[k].decoded);
1036 if (ada_opname_table[k].encoded != NULL)
1041 /* Replace "TK__" with "__", which will eventually be translated
1042 into "." (just below). */
1044 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1047 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1048 be translated into "." (just below). These are internal names
1049 generated for anonymous blocks inside which our symbol is nested. */
1051 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1052 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1053 && isdigit (encoded [i+4]))
1057 while (k < len0 && isdigit (encoded[k]))
1058 k++; /* Skip any extra digit. */
1060 /* Double-check that the "__B_{DIGITS}+" sequence we found
1061 is indeed followed by "__". */
1062 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1066 /* Remove _E{DIGITS}+[sb] */
1068 /* Just as for protected object subprograms, there are 2 categories
1069 of subprograms created by the compiler for each entry. The first
1070 one implements the actual entry code, and has a suffix following
1071 the convention above; the second one implements the barrier and
1072 uses the same convention as above, except that the 'E' is replaced
1075 Just as above, we do not decode the name of barrier functions
1076 to give the user a clue that the code he is debugging has been
1077 internally generated. */
1079 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1080 && isdigit (encoded[i+2]))
1084 while (k < len0 && isdigit (encoded[k]))
1088 && (encoded[k] == 'b' || encoded[k] == 's'))
1091 /* Just as an extra precaution, make sure that if this
1092 suffix is followed by anything else, it is a '_'.
1093 Otherwise, we matched this sequence by accident. */
1095 || (k < len0 && encoded[k] == '_'))
1100 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1101 the GNAT front-end in protected object subprograms. */
1104 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1106 /* Backtrack a bit up until we reach either the begining of
1107 the encoded name, or "__". Make sure that we only find
1108 digits or lowercase characters. */
1109 const char *ptr = encoded + i - 1;
1111 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1114 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1118 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1120 /* This is a X[bn]* sequence not separated from the previous
1121 part of the name with a non-alpha-numeric character (in other
1122 words, immediately following an alpha-numeric character), then
1123 verify that it is placed at the end of the encoded name. If
1124 not, then the encoding is not valid and we should abort the
1125 decoding. Otherwise, just skip it, it is used in body-nested
1129 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1133 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1135 /* Replace '__' by '.'. */
1143 /* It's a character part of the decoded name, so just copy it
1145 decoded[j] = encoded[i];
1150 decoded[j] = '\000';
1152 /* Decoded names should never contain any uppercase character.
1153 Double-check this, and abort the decoding if we find one. */
1155 for (i = 0; decoded[i] != '\0'; i += 1)
1156 if (isupper (decoded[i]) || decoded[i] == ' ')
1159 if (strcmp (decoded, encoded) == 0)
1165 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1166 decoded = decoding_buffer;
1167 if (encoded[0] == '<')
1168 strcpy (decoded, encoded);
1170 sprintf (decoded, "<%s>", encoded);
1175 /* Table for keeping permanent unique copies of decoded names. Once
1176 allocated, names in this table are never released. While this is a
1177 storage leak, it should not be significant unless there are massive
1178 changes in the set of decoded names in successive versions of a
1179 symbol table loaded during a single session. */
1180 static struct htab *decoded_names_store;
1182 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1183 in the language-specific part of GSYMBOL, if it has not been
1184 previously computed. Tries to save the decoded name in the same
1185 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1186 in any case, the decoded symbol has a lifetime at least that of
1188 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1189 const, but nevertheless modified to a semantically equivalent form
1190 when a decoded name is cached in it.
1194 ada_decode_symbol (const struct general_symbol_info *gsymbol)
1197 (char **) &gsymbol->language_specific.cplus_specific.demangled_name;
1198 if (*resultp == NULL)
1200 const char *decoded = ada_decode (gsymbol->name);
1201 if (gsymbol->obj_section != NULL)
1203 struct objfile *objf = gsymbol->obj_section->objfile;
1204 *resultp = obsavestring (decoded, strlen (decoded),
1205 &objf->objfile_obstack);
1207 /* Sometimes, we can't find a corresponding objfile, in which
1208 case, we put the result on the heap. Since we only decode
1209 when needed, we hope this usually does not cause a
1210 significant memory leak (FIXME). */
1211 if (*resultp == NULL)
1213 char **slot = (char **) htab_find_slot (decoded_names_store,
1216 *slot = xstrdup (decoded);
1225 ada_la_decode (const char *encoded, int options)
1227 return xstrdup (ada_decode (encoded));
1230 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1231 suffixes that encode debugging information or leading _ada_ on
1232 SYM_NAME (see is_name_suffix commentary for the debugging
1233 information that is ignored). If WILD, then NAME need only match a
1234 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1235 either argument is NULL. */
1238 ada_match_name (const char *sym_name, const char *name, int wild)
1240 if (sym_name == NULL || name == NULL)
1243 return wild_match (name, strlen (name), sym_name);
1246 int len_name = strlen (name);
1247 return (strncmp (sym_name, name, len_name) == 0
1248 && is_name_suffix (sym_name + len_name))
1249 || (strncmp (sym_name, "_ada_", 5) == 0
1250 && strncmp (sym_name + 5, name, len_name) == 0
1251 && is_name_suffix (sym_name + len_name + 5));
1255 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1256 suppressed in info listings. */
1259 ada_suppress_symbol_printing (struct symbol *sym)
1261 if (SYMBOL_DOMAIN (sym) == STRUCT_DOMAIN)
1264 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym));
1270 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1272 static char *bound_name[] = {
1273 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1274 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1277 /* Maximum number of array dimensions we are prepared to handle. */
1279 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1281 /* Like modify_field, but allows bitpos > wordlength. */
1284 modify_general_field (char *addr, LONGEST fieldval, int bitpos, int bitsize)
1286 modify_field (addr + bitpos / 8, fieldval, bitpos % 8, bitsize);
1290 /* The desc_* routines return primitive portions of array descriptors
1293 /* The descriptor or array type, if any, indicated by TYPE; removes
1294 level of indirection, if needed. */
1296 static struct type *
1297 desc_base_type (struct type *type)
1301 type = ada_check_typedef (type);
1303 && (TYPE_CODE (type) == TYPE_CODE_PTR
1304 || TYPE_CODE (type) == TYPE_CODE_REF))
1305 return ada_check_typedef (TYPE_TARGET_TYPE (type));
1310 /* True iff TYPE indicates a "thin" array pointer type. */
1313 is_thin_pntr (struct type *type)
1316 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1317 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1320 /* The descriptor type for thin pointer type TYPE. */
1322 static struct type *
1323 thin_descriptor_type (struct type *type)
1325 struct type *base_type = desc_base_type (type);
1326 if (base_type == NULL)
1328 if (is_suffix (ada_type_name (base_type), "___XVE"))
1332 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1333 if (alt_type == NULL)
1340 /* A pointer to the array data for thin-pointer value VAL. */
1342 static struct value *
1343 thin_data_pntr (struct value *val)
1345 struct type *type = value_type (val);
1346 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1347 return value_cast (desc_data_type (thin_descriptor_type (type)),
1350 return value_from_longest (desc_data_type (thin_descriptor_type (type)),
1351 VALUE_ADDRESS (val) + value_offset (val));
1354 /* True iff TYPE indicates a "thick" array pointer type. */
1357 is_thick_pntr (struct type *type)
1359 type = desc_base_type (type);
1360 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1361 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1364 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1365 pointer to one, the type of its bounds data; otherwise, NULL. */
1367 static struct type *
1368 desc_bounds_type (struct type *type)
1372 type = desc_base_type (type);
1376 else if (is_thin_pntr (type))
1378 type = thin_descriptor_type (type);
1381 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1383 return ada_check_typedef (r);
1385 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1387 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1389 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1394 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1395 one, a pointer to its bounds data. Otherwise NULL. */
1397 static struct value *
1398 desc_bounds (struct value *arr)
1400 struct type *type = ada_check_typedef (value_type (arr));
1401 if (is_thin_pntr (type))
1403 struct type *bounds_type =
1404 desc_bounds_type (thin_descriptor_type (type));
1407 if (bounds_type == NULL)
1408 error (_("Bad GNAT array descriptor"));
1410 /* NOTE: The following calculation is not really kosher, but
1411 since desc_type is an XVE-encoded type (and shouldn't be),
1412 the correct calculation is a real pain. FIXME (and fix GCC). */
1413 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1414 addr = value_as_long (arr);
1416 addr = VALUE_ADDRESS (arr) + value_offset (arr);
1419 value_from_longest (lookup_pointer_type (bounds_type),
1420 addr - TYPE_LENGTH (bounds_type));
1423 else if (is_thick_pntr (type))
1424 return value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1425 _("Bad GNAT array descriptor"));
1430 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1431 position of the field containing the address of the bounds data. */
1434 fat_pntr_bounds_bitpos (struct type *type)
1436 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1439 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1440 size of the field containing the address of the bounds data. */
1443 fat_pntr_bounds_bitsize (struct type *type)
1445 type = desc_base_type (type);
1447 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1448 return TYPE_FIELD_BITSIZE (type, 1);
1450 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1453 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1454 pointer to one, the type of its array data (a
1455 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1456 ada_type_of_array to get an array type with bounds data. */
1458 static struct type *
1459 desc_data_type (struct type *type)
1461 type = desc_base_type (type);
1463 /* NOTE: The following is bogus; see comment in desc_bounds. */
1464 if (is_thin_pntr (type))
1465 return lookup_pointer_type
1466 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)));
1467 else if (is_thick_pntr (type))
1468 return lookup_struct_elt_type (type, "P_ARRAY", 1);
1473 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1476 static struct value *
1477 desc_data (struct value *arr)
1479 struct type *type = value_type (arr);
1480 if (is_thin_pntr (type))
1481 return thin_data_pntr (arr);
1482 else if (is_thick_pntr (type))
1483 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1484 _("Bad GNAT array descriptor"));
1490 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1491 position of the field containing the address of the data. */
1494 fat_pntr_data_bitpos (struct type *type)
1496 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1499 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1500 size of the field containing the address of the data. */
1503 fat_pntr_data_bitsize (struct type *type)
1505 type = desc_base_type (type);
1507 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1508 return TYPE_FIELD_BITSIZE (type, 0);
1510 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1513 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1514 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1515 bound, if WHICH is 1. The first bound is I=1. */
1517 static struct value *
1518 desc_one_bound (struct value *bounds, int i, int which)
1520 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1521 _("Bad GNAT array descriptor bounds"));
1524 /* If BOUNDS is an array-bounds structure type, return the bit position
1525 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1526 bound, if WHICH is 1. The first bound is I=1. */
1529 desc_bound_bitpos (struct type *type, int i, int which)
1531 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1534 /* If BOUNDS is an array-bounds structure type, return the bit field size
1535 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1536 bound, if WHICH is 1. The first bound is I=1. */
1539 desc_bound_bitsize (struct type *type, int i, int which)
1541 type = desc_base_type (type);
1543 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1544 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1546 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1549 /* If TYPE is the type of an array-bounds structure, the type of its
1550 Ith bound (numbering from 1). Otherwise, NULL. */
1552 static struct type *
1553 desc_index_type (struct type *type, int i)
1555 type = desc_base_type (type);
1557 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1558 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1563 /* The number of index positions in the array-bounds type TYPE.
1564 Return 0 if TYPE is NULL. */
1567 desc_arity (struct type *type)
1569 type = desc_base_type (type);
1572 return TYPE_NFIELDS (type) / 2;
1576 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1577 an array descriptor type (representing an unconstrained array
1581 ada_is_direct_array_type (struct type *type)
1585 type = ada_check_typedef (type);
1586 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1587 || ada_is_array_descriptor_type (type));
1590 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1594 ada_is_array_type (struct type *type)
1597 && (TYPE_CODE (type) == TYPE_CODE_PTR
1598 || TYPE_CODE (type) == TYPE_CODE_REF))
1599 type = TYPE_TARGET_TYPE (type);
1600 return ada_is_direct_array_type (type);
1603 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1606 ada_is_simple_array_type (struct type *type)
1610 type = ada_check_typedef (type);
1611 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1612 || (TYPE_CODE (type) == TYPE_CODE_PTR
1613 && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY));
1616 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1619 ada_is_array_descriptor_type (struct type *type)
1621 struct type *data_type = desc_data_type (type);
1625 type = ada_check_typedef (type);
1628 && ((TYPE_CODE (data_type) == TYPE_CODE_PTR
1629 && TYPE_TARGET_TYPE (data_type) != NULL
1630 && TYPE_CODE (TYPE_TARGET_TYPE (data_type)) == TYPE_CODE_ARRAY)
1631 || TYPE_CODE (data_type) == TYPE_CODE_ARRAY)
1632 && desc_arity (desc_bounds_type (type)) > 0;
1635 /* Non-zero iff type is a partially mal-formed GNAT array
1636 descriptor. FIXME: This is to compensate for some problems with
1637 debugging output from GNAT. Re-examine periodically to see if it
1641 ada_is_bogus_array_descriptor (struct type *type)
1645 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1646 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1647 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1648 && !ada_is_array_descriptor_type (type);
1652 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1653 (fat pointer) returns the type of the array data described---specifically,
1654 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1655 in from the descriptor; otherwise, they are left unspecified. If
1656 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1657 returns NULL. The result is simply the type of ARR if ARR is not
1660 ada_type_of_array (struct value *arr, int bounds)
1662 if (ada_is_packed_array_type (value_type (arr)))
1663 return decode_packed_array_type (value_type (arr));
1665 if (!ada_is_array_descriptor_type (value_type (arr)))
1666 return value_type (arr);
1670 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr))));
1673 struct type *elt_type;
1675 struct value *descriptor;
1676 struct objfile *objf = TYPE_OBJFILE (value_type (arr));
1678 elt_type = ada_array_element_type (value_type (arr), -1);
1679 arity = ada_array_arity (value_type (arr));
1681 if (elt_type == NULL || arity == 0)
1682 return ada_check_typedef (value_type (arr));
1684 descriptor = desc_bounds (arr);
1685 if (value_as_long (descriptor) == 0)
1689 struct type *range_type = alloc_type (objf);
1690 struct type *array_type = alloc_type (objf);
1691 struct value *low = desc_one_bound (descriptor, arity, 0);
1692 struct value *high = desc_one_bound (descriptor, arity, 1);
1695 create_range_type (range_type, value_type (low),
1696 longest_to_int (value_as_long (low)),
1697 longest_to_int (value_as_long (high)));
1698 elt_type = create_array_type (array_type, elt_type, range_type);
1701 return lookup_pointer_type (elt_type);
1705 /* If ARR does not represent an array, returns ARR unchanged.
1706 Otherwise, returns either a standard GDB array with bounds set
1707 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1708 GDB array. Returns NULL if ARR is a null fat pointer. */
1711 ada_coerce_to_simple_array_ptr (struct value *arr)
1713 if (ada_is_array_descriptor_type (value_type (arr)))
1715 struct type *arrType = ada_type_of_array (arr, 1);
1716 if (arrType == NULL)
1718 return value_cast (arrType, value_copy (desc_data (arr)));
1720 else if (ada_is_packed_array_type (value_type (arr)))
1721 return decode_packed_array (arr);
1726 /* If ARR does not represent an array, returns ARR unchanged.
1727 Otherwise, returns a standard GDB array describing ARR (which may
1728 be ARR itself if it already is in the proper form). */
1730 static struct value *
1731 ada_coerce_to_simple_array (struct value *arr)
1733 if (ada_is_array_descriptor_type (value_type (arr)))
1735 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1737 error (_("Bounds unavailable for null array pointer."));
1738 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
1739 return value_ind (arrVal);
1741 else if (ada_is_packed_array_type (value_type (arr)))
1742 return decode_packed_array (arr);
1747 /* If TYPE represents a GNAT array type, return it translated to an
1748 ordinary GDB array type (possibly with BITSIZE fields indicating
1749 packing). For other types, is the identity. */
1752 ada_coerce_to_simple_array_type (struct type *type)
1754 struct value *mark = value_mark ();
1755 struct value *dummy = value_from_longest (builtin_type_int32, 0);
1756 struct type *result;
1757 deprecated_set_value_type (dummy, type);
1758 result = ada_type_of_array (dummy, 0);
1759 value_free_to_mark (mark);
1763 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1766 ada_is_packed_array_type (struct type *type)
1770 type = desc_base_type (type);
1771 type = ada_check_typedef (type);
1773 ada_type_name (type) != NULL
1774 && strstr (ada_type_name (type), "___XP") != NULL;
1777 /* Given that TYPE is a standard GDB array type with all bounds filled
1778 in, and that the element size of its ultimate scalar constituents
1779 (that is, either its elements, or, if it is an array of arrays, its
1780 elements' elements, etc.) is *ELT_BITS, return an identical type,
1781 but with the bit sizes of its elements (and those of any
1782 constituent arrays) recorded in the BITSIZE components of its
1783 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1786 static struct type *
1787 packed_array_type (struct type *type, long *elt_bits)
1789 struct type *new_elt_type;
1790 struct type *new_type;
1791 LONGEST low_bound, high_bound;
1793 type = ada_check_typedef (type);
1794 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1797 new_type = alloc_type (TYPE_OBJFILE (type));
1798 new_elt_type = packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
1800 create_array_type (new_type, new_elt_type, TYPE_FIELD_TYPE (type, 0));
1801 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
1802 TYPE_NAME (new_type) = ada_type_name (type);
1804 if (get_discrete_bounds (TYPE_FIELD_TYPE (type, 0),
1805 &low_bound, &high_bound) < 0)
1806 low_bound = high_bound = 0;
1807 if (high_bound < low_bound)
1808 *elt_bits = TYPE_LENGTH (new_type) = 0;
1811 *elt_bits *= (high_bound - low_bound + 1);
1812 TYPE_LENGTH (new_type) =
1813 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
1816 TYPE_FIXED_INSTANCE (new_type) = 1;
1820 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1822 static struct type *
1823 decode_packed_array_type (struct type *type)
1826 struct block **blocks;
1827 char *raw_name = ada_type_name (ada_check_typedef (type));
1830 struct type *shadow_type;
1835 raw_name = ada_type_name (desc_base_type (type));
1840 name = (char *) alloca (strlen (raw_name) + 1);
1841 tail = strstr (raw_name, "___XP");
1842 type = desc_base_type (type);
1844 memcpy (name, raw_name, tail - raw_name);
1845 name[tail - raw_name] = '\000';
1847 sym = standard_lookup (name, get_selected_block (0), VAR_DOMAIN);
1848 if (sym == NULL || SYMBOL_TYPE (sym) == NULL)
1850 lim_warning (_("could not find bounds information on packed array"));
1853 shadow_type = SYMBOL_TYPE (sym);
1855 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
1857 lim_warning (_("could not understand bounds information on packed array"));
1861 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1864 (_("could not understand bit size information on packed array"));
1868 return packed_array_type (shadow_type, &bits);
1871 /* Given that ARR is a struct value *indicating a GNAT packed array,
1872 returns a simple array that denotes that array. Its type is a
1873 standard GDB array type except that the BITSIZEs of the array
1874 target types are set to the number of bits in each element, and the
1875 type length is set appropriately. */
1877 static struct value *
1878 decode_packed_array (struct value *arr)
1882 arr = ada_coerce_ref (arr);
1883 if (TYPE_CODE (value_type (arr)) == TYPE_CODE_PTR)
1884 arr = ada_value_ind (arr);
1886 type = decode_packed_array_type (value_type (arr));
1889 error (_("can't unpack array"));
1893 if (gdbarch_bits_big_endian (current_gdbarch)
1894 && ada_is_modular_type (value_type (arr)))
1896 /* This is a (right-justified) modular type representing a packed
1897 array with no wrapper. In order to interpret the value through
1898 the (left-justified) packed array type we just built, we must
1899 first left-justify it. */
1900 int bit_size, bit_pos;
1903 mod = ada_modulus (value_type (arr)) - 1;
1910 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
1911 arr = ada_value_primitive_packed_val (arr, NULL,
1912 bit_pos / HOST_CHAR_BIT,
1913 bit_pos % HOST_CHAR_BIT,
1918 return coerce_unspec_val_to_type (arr, type);
1922 /* The value of the element of packed array ARR at the ARITY indices
1923 given in IND. ARR must be a simple array. */
1925 static struct value *
1926 value_subscript_packed (struct value *arr, int arity, struct value **ind)
1929 int bits, elt_off, bit_off;
1930 long elt_total_bit_offset;
1931 struct type *elt_type;
1935 elt_total_bit_offset = 0;
1936 elt_type = ada_check_typedef (value_type (arr));
1937 for (i = 0; i < arity; i += 1)
1939 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
1940 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
1942 (_("attempt to do packed indexing of something other than a packed array"));
1945 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
1946 LONGEST lowerbound, upperbound;
1949 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
1951 lim_warning (_("don't know bounds of array"));
1952 lowerbound = upperbound = 0;
1955 idx = pos_atr (ind[i]);
1956 if (idx < lowerbound || idx > upperbound)
1957 lim_warning (_("packed array index %ld out of bounds"), (long) idx);
1958 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
1959 elt_total_bit_offset += (idx - lowerbound) * bits;
1960 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
1963 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
1964 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
1966 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
1971 /* Non-zero iff TYPE includes negative integer values. */
1974 has_negatives (struct type *type)
1976 switch (TYPE_CODE (type))
1981 return !TYPE_UNSIGNED (type);
1982 case TYPE_CODE_RANGE:
1983 return TYPE_LOW_BOUND (type) < 0;
1988 /* Create a new value of type TYPE from the contents of OBJ starting
1989 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1990 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1991 assigning through the result will set the field fetched from.
1992 VALADDR is ignored unless OBJ is NULL, in which case,
1993 VALADDR+OFFSET must address the start of storage containing the
1994 packed value. The value returned in this case is never an lval.
1995 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1998 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
1999 long offset, int bit_offset, int bit_size,
2003 int src, /* Index into the source area */
2004 targ, /* Index into the target area */
2005 srcBitsLeft, /* Number of source bits left to move */
2006 nsrc, ntarg, /* Number of source and target bytes */
2007 unusedLS, /* Number of bits in next significant
2008 byte of source that are unused */
2009 accumSize; /* Number of meaningful bits in accum */
2010 unsigned char *bytes; /* First byte containing data to unpack */
2011 unsigned char *unpacked;
2012 unsigned long accum; /* Staging area for bits being transferred */
2014 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2015 /* Transmit bytes from least to most significant; delta is the direction
2016 the indices move. */
2017 int delta = gdbarch_bits_big_endian (current_gdbarch) ? -1 : 1;
2019 type = ada_check_typedef (type);
2023 v = allocate_value (type);
2024 bytes = (unsigned char *) (valaddr + offset);
2026 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2029 VALUE_ADDRESS (obj) + value_offset (obj) + offset);
2030 bytes = (unsigned char *) alloca (len);
2031 read_memory (VALUE_ADDRESS (v), bytes, len);
2035 v = allocate_value (type);
2036 bytes = (unsigned char *) value_contents (obj) + offset;
2041 VALUE_LVAL (v) = VALUE_LVAL (obj);
2042 if (VALUE_LVAL (obj) == lval_internalvar)
2043 VALUE_LVAL (v) = lval_internalvar_component;
2044 VALUE_ADDRESS (v) = VALUE_ADDRESS (obj) + value_offset (obj) + offset;
2045 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2046 set_value_bitsize (v, bit_size);
2047 if (value_bitpos (v) >= HOST_CHAR_BIT)
2049 VALUE_ADDRESS (v) += 1;
2050 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2054 set_value_bitsize (v, bit_size);
2055 unpacked = (unsigned char *) value_contents (v);
2057 srcBitsLeft = bit_size;
2059 ntarg = TYPE_LENGTH (type);
2063 memset (unpacked, 0, TYPE_LENGTH (type));
2066 else if (gdbarch_bits_big_endian (current_gdbarch))
2069 if (has_negatives (type)
2070 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2074 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2077 switch (TYPE_CODE (type))
2079 case TYPE_CODE_ARRAY:
2080 case TYPE_CODE_UNION:
2081 case TYPE_CODE_STRUCT:
2082 /* Non-scalar values must be aligned at a byte boundary... */
2084 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2085 /* ... And are placed at the beginning (most-significant) bytes
2087 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2091 targ = TYPE_LENGTH (type) - 1;
2097 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2100 unusedLS = bit_offset;
2103 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
2110 /* Mask for removing bits of the next source byte that are not
2111 part of the value. */
2112 unsigned int unusedMSMask =
2113 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2115 /* Sign-extend bits for this byte. */
2116 unsigned int signMask = sign & ~unusedMSMask;
2118 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2119 accumSize += HOST_CHAR_BIT - unusedLS;
2120 if (accumSize >= HOST_CHAR_BIT)
2122 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2123 accumSize -= HOST_CHAR_BIT;
2124 accum >>= HOST_CHAR_BIT;
2128 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2135 accum |= sign << accumSize;
2136 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2137 accumSize -= HOST_CHAR_BIT;
2138 accum >>= HOST_CHAR_BIT;
2146 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2147 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2150 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2151 int src_offset, int n)
2153 unsigned int accum, mask;
2154 int accum_bits, chunk_size;
2156 target += targ_offset / HOST_CHAR_BIT;
2157 targ_offset %= HOST_CHAR_BIT;
2158 source += src_offset / HOST_CHAR_BIT;
2159 src_offset %= HOST_CHAR_BIT;
2160 if (gdbarch_bits_big_endian (current_gdbarch))
2162 accum = (unsigned char) *source;
2164 accum_bits = HOST_CHAR_BIT - src_offset;
2169 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2170 accum_bits += HOST_CHAR_BIT;
2172 chunk_size = HOST_CHAR_BIT - targ_offset;
2175 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2176 mask = ((1 << chunk_size) - 1) << unused_right;
2179 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2181 accum_bits -= chunk_size;
2188 accum = (unsigned char) *source >> src_offset;
2190 accum_bits = HOST_CHAR_BIT - src_offset;
2194 accum = accum + ((unsigned char) *source << accum_bits);
2195 accum_bits += HOST_CHAR_BIT;
2197 chunk_size = HOST_CHAR_BIT - targ_offset;
2200 mask = ((1 << chunk_size) - 1) << targ_offset;
2201 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2203 accum_bits -= chunk_size;
2204 accum >>= chunk_size;
2211 /* Store the contents of FROMVAL into the location of TOVAL.
2212 Return a new value with the location of TOVAL and contents of
2213 FROMVAL. Handles assignment into packed fields that have
2214 floating-point or non-scalar types. */
2216 static struct value *
2217 ada_value_assign (struct value *toval, struct value *fromval)
2219 struct type *type = value_type (toval);
2220 int bits = value_bitsize (toval);
2222 toval = ada_coerce_ref (toval);
2223 fromval = ada_coerce_ref (fromval);
2225 if (ada_is_direct_array_type (value_type (toval)))
2226 toval = ada_coerce_to_simple_array (toval);
2227 if (ada_is_direct_array_type (value_type (fromval)))
2228 fromval = ada_coerce_to_simple_array (fromval);
2230 if (!deprecated_value_modifiable (toval))
2231 error (_("Left operand of assignment is not a modifiable lvalue."));
2233 if (VALUE_LVAL (toval) == lval_memory
2235 && (TYPE_CODE (type) == TYPE_CODE_FLT
2236 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2238 int len = (value_bitpos (toval)
2239 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2241 char *buffer = (char *) alloca (len);
2243 CORE_ADDR to_addr = VALUE_ADDRESS (toval) + value_offset (toval);
2245 if (TYPE_CODE (type) == TYPE_CODE_FLT)
2246 fromval = value_cast (type, fromval);
2248 read_memory (to_addr, buffer, len);
2249 from_size = value_bitsize (fromval);
2251 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2252 if (gdbarch_bits_big_endian (current_gdbarch))
2253 move_bits (buffer, value_bitpos (toval),
2254 value_contents (fromval), from_size - bits, bits);
2256 move_bits (buffer, value_bitpos (toval), value_contents (fromval),
2258 write_memory (to_addr, buffer, len);
2259 if (deprecated_memory_changed_hook)
2260 deprecated_memory_changed_hook (to_addr, len);
2262 val = value_copy (toval);
2263 memcpy (value_contents_raw (val), value_contents (fromval),
2264 TYPE_LENGTH (type));
2265 deprecated_set_value_type (val, type);
2270 return value_assign (toval, fromval);
2274 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2275 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2276 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2277 * COMPONENT, and not the inferior's memory. The current contents
2278 * of COMPONENT are ignored. */
2280 value_assign_to_component (struct value *container, struct value *component,
2283 LONGEST offset_in_container =
2284 (LONGEST) (VALUE_ADDRESS (component) + value_offset (component)
2285 - VALUE_ADDRESS (container) - value_offset (container));
2286 int bit_offset_in_container =
2287 value_bitpos (component) - value_bitpos (container);
2290 val = value_cast (value_type (component), val);
2292 if (value_bitsize (component) == 0)
2293 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2295 bits = value_bitsize (component);
2297 if (gdbarch_bits_big_endian (current_gdbarch))
2298 move_bits (value_contents_writeable (container) + offset_in_container,
2299 value_bitpos (container) + bit_offset_in_container,
2300 value_contents (val),
2301 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2304 move_bits (value_contents_writeable (container) + offset_in_container,
2305 value_bitpos (container) + bit_offset_in_container,
2306 value_contents (val), 0, bits);
2309 /* The value of the element of array ARR at the ARITY indices given in IND.
2310 ARR may be either a simple array, GNAT array descriptor, or pointer
2314 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2318 struct type *elt_type;
2320 elt = ada_coerce_to_simple_array (arr);
2322 elt_type = ada_check_typedef (value_type (elt));
2323 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2324 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2325 return value_subscript_packed (elt, arity, ind);
2327 for (k = 0; k < arity; k += 1)
2329 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2330 error (_("too many subscripts (%d expected)"), k);
2331 elt = value_subscript (elt, value_pos_atr (builtin_type_int32, ind[k]));
2336 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2337 value of the element of *ARR at the ARITY indices given in
2338 IND. Does not read the entire array into memory. */
2341 ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
2346 for (k = 0; k < arity; k += 1)
2351 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2352 error (_("too many subscripts (%d expected)"), k);
2353 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2355 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2356 idx = value_pos_atr (builtin_type_int32, ind[k]);
2358 idx = value_binop (idx, value_from_longest (value_type (idx), lwb),
2361 arr = value_ptradd (arr, idx);
2362 type = TYPE_TARGET_TYPE (type);
2365 return value_ind (arr);
2368 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2369 actual type of ARRAY_PTR is ignored), returns a reference to
2370 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2371 bound of this array is LOW, as per Ada rules. */
2372 static struct value *
2373 ada_value_slice_ptr (struct value *array_ptr, struct type *type,
2376 CORE_ADDR base = value_as_address (array_ptr)
2377 + ((low - TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type)))
2378 * TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
2379 struct type *index_type =
2380 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)),
2382 struct type *slice_type =
2383 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2384 return value_from_pointer (lookup_reference_type (slice_type), base);
2388 static struct value *
2389 ada_value_slice (struct value *array, int low, int high)
2391 struct type *type = value_type (array);
2392 struct type *index_type =
2393 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2394 struct type *slice_type =
2395 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2396 return value_cast (slice_type, value_slice (array, low, high - low + 1));
2399 /* If type is a record type in the form of a standard GNAT array
2400 descriptor, returns the number of dimensions for type. If arr is a
2401 simple array, returns the number of "array of"s that prefix its
2402 type designation. Otherwise, returns 0. */
2405 ada_array_arity (struct type *type)
2412 type = desc_base_type (type);
2415 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2416 return desc_arity (desc_bounds_type (type));
2418 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2421 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2427 /* If TYPE is a record type in the form of a standard GNAT array
2428 descriptor or a simple array type, returns the element type for
2429 TYPE after indexing by NINDICES indices, or by all indices if
2430 NINDICES is -1. Otherwise, returns NULL. */
2433 ada_array_element_type (struct type *type, int nindices)
2435 type = desc_base_type (type);
2437 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2440 struct type *p_array_type;
2442 p_array_type = desc_data_type (type);
2444 k = ada_array_arity (type);
2448 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2449 if (nindices >= 0 && k > nindices)
2451 p_array_type = TYPE_TARGET_TYPE (p_array_type);
2452 while (k > 0 && p_array_type != NULL)
2454 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2457 return p_array_type;
2459 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2461 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
2463 type = TYPE_TARGET_TYPE (type);
2472 /* The type of nth index in arrays of given type (n numbering from 1).
2473 Does not examine memory. */
2476 ada_index_type (struct type *type, int n)
2478 struct type *result_type;
2480 type = desc_base_type (type);
2482 if (n > ada_array_arity (type))
2485 if (ada_is_simple_array_type (type))
2489 for (i = 1; i < n; i += 1)
2490 type = TYPE_TARGET_TYPE (type);
2491 result_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 0));
2492 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2493 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2494 perhaps stabsread.c would make more sense. */
2495 if (result_type == NULL || TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2496 result_type = builtin_type_int32;
2501 return desc_index_type (desc_bounds_type (type), n);
2504 /* Given that arr is an array type, returns the lower bound of the
2505 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2506 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2507 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2508 bounds type. It works for other arrays with bounds supplied by
2509 run-time quantities other than discriminants. */
2512 ada_array_bound_from_type (struct type * arr_type, int n, int which,
2513 struct type ** typep)
2516 struct type *index_type_desc;
2518 if (ada_is_packed_array_type (arr_type))
2519 arr_type = decode_packed_array_type (arr_type);
2521 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2524 *typep = builtin_type_int32;
2525 return (LONGEST) - which;
2528 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2529 type = TYPE_TARGET_TYPE (arr_type);
2533 index_type_desc = ada_find_parallel_type (type, "___XA");
2534 if (index_type_desc == NULL)
2536 struct type *index_type;
2540 type = TYPE_TARGET_TYPE (type);
2544 index_type = TYPE_INDEX_TYPE (type);
2546 *typep = index_type;
2548 /* The index type is either a range type or an enumerated type.
2549 For the range type, we have some macros that allow us to
2550 extract the value of the low and high bounds. But they
2551 do now work for enumerated types. The expressions used
2552 below work for both range and enum types. */
2554 (LONGEST) (which == 0
2555 ? TYPE_FIELD_BITPOS (index_type, 0)
2556 : TYPE_FIELD_BITPOS (index_type,
2557 TYPE_NFIELDS (index_type) - 1));
2561 struct type *index_type =
2562 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n - 1),
2563 NULL, TYPE_OBJFILE (arr_type));
2566 *typep = index_type;
2569 (LONGEST) (which == 0
2570 ? TYPE_LOW_BOUND (index_type)
2571 : TYPE_HIGH_BOUND (index_type));
2575 /* Given that arr is an array value, returns the lower bound of the
2576 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2577 WHICH is 1. This routine will also work for arrays with bounds
2578 supplied by run-time quantities other than discriminants. */
2581 ada_array_bound (struct value *arr, int n, int which)
2583 struct type *arr_type = value_type (arr);
2585 if (ada_is_packed_array_type (arr_type))
2586 return ada_array_bound (decode_packed_array (arr), n, which);
2587 else if (ada_is_simple_array_type (arr_type))
2590 LONGEST v = ada_array_bound_from_type (arr_type, n, which, &type);
2591 return value_from_longest (type, v);
2594 return desc_one_bound (desc_bounds (arr), n, which);
2597 /* Given that arr is an array value, returns the length of the
2598 nth index. This routine will also work for arrays with bounds
2599 supplied by run-time quantities other than discriminants.
2600 Does not work for arrays indexed by enumeration types with representation
2601 clauses at the moment. */
2604 ada_array_length (struct value *arr, int n)
2606 struct type *arr_type = ada_check_typedef (value_type (arr));
2608 if (ada_is_packed_array_type (arr_type))
2609 return ada_array_length (decode_packed_array (arr), n);
2611 if (ada_is_simple_array_type (arr_type))
2615 ada_array_bound_from_type (arr_type, n, 1, &type) -
2616 ada_array_bound_from_type (arr_type, n, 0, NULL) + 1;
2617 return value_from_longest (type, v);
2621 value_from_longest (builtin_type_int32,
2622 value_as_long (desc_one_bound (desc_bounds (arr),
2624 - value_as_long (desc_one_bound (desc_bounds (arr),
2628 /* An empty array whose type is that of ARR_TYPE (an array type),
2629 with bounds LOW to LOW-1. */
2631 static struct value *
2632 empty_array (struct type *arr_type, int low)
2634 struct type *index_type =
2635 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type)),
2637 struct type *elt_type = ada_array_element_type (arr_type, 1);
2638 return allocate_value (create_array_type (NULL, elt_type, index_type));
2642 /* Name resolution */
2644 /* The "decoded" name for the user-definable Ada operator corresponding
2648 ada_decoded_op_name (enum exp_opcode op)
2652 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
2654 if (ada_opname_table[i].op == op)
2655 return ada_opname_table[i].decoded;
2657 error (_("Could not find operator name for opcode"));
2661 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2662 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2663 undefined namespace) and converts operators that are
2664 user-defined into appropriate function calls. If CONTEXT_TYPE is
2665 non-null, it provides a preferred result type [at the moment, only
2666 type void has any effect---causing procedures to be preferred over
2667 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2668 return type is preferred. May change (expand) *EXP. */
2671 resolve (struct expression **expp, int void_context_p)
2675 resolve_subexp (expp, &pc, 1, void_context_p ? builtin_type_void : NULL);
2678 /* Resolve the operator of the subexpression beginning at
2679 position *POS of *EXPP. "Resolving" consists of replacing
2680 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2681 with their resolutions, replacing built-in operators with
2682 function calls to user-defined operators, where appropriate, and,
2683 when DEPROCEDURE_P is non-zero, converting function-valued variables
2684 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2685 are as in ada_resolve, above. */
2687 static struct value *
2688 resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
2689 struct type *context_type)
2693 struct expression *exp; /* Convenience: == *expp. */
2694 enum exp_opcode op = (*expp)->elts[pc].opcode;
2695 struct value **argvec; /* Vector of operand types (alloca'ed). */
2696 int nargs; /* Number of operands. */
2703 /* Pass one: resolve operands, saving their types and updating *pos,
2708 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2709 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2714 resolve_subexp (expp, pos, 0, NULL);
2716 nargs = longest_to_int (exp->elts[pc + 1].longconst);
2721 resolve_subexp (expp, pos, 0, NULL);
2726 resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2729 case OP_ATR_MODULUS:
2739 case TERNOP_IN_RANGE:
2740 case BINOP_IN_BOUNDS:
2746 case OP_DISCRETE_RANGE:
2748 ada_forward_operator_length (exp, pc, &oplen, &nargs);
2757 arg1 = resolve_subexp (expp, pos, 0, NULL);
2759 resolve_subexp (expp, pos, 1, NULL);
2761 resolve_subexp (expp, pos, 1, value_type (arg1));
2778 case BINOP_LOGICAL_AND:
2779 case BINOP_LOGICAL_OR:
2780 case BINOP_BITWISE_AND:
2781 case BINOP_BITWISE_IOR:
2782 case BINOP_BITWISE_XOR:
2785 case BINOP_NOTEQUAL:
2792 case BINOP_SUBSCRIPT:
2800 case UNOP_LOGICAL_NOT:
2816 case OP_INTERNALVAR:
2826 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2829 case STRUCTOP_STRUCT:
2830 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2843 error (_("Unexpected operator during name resolution"));
2846 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
2847 for (i = 0; i < nargs; i += 1)
2848 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
2852 /* Pass two: perform any resolution on principal operator. */
2859 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
2861 struct ada_symbol_info *candidates;
2865 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2866 (exp->elts[pc + 2].symbol),
2867 exp->elts[pc + 1].block, VAR_DOMAIN,
2870 if (n_candidates > 1)
2872 /* Types tend to get re-introduced locally, so if there
2873 are any local symbols that are not types, first filter
2876 for (j = 0; j < n_candidates; j += 1)
2877 switch (SYMBOL_CLASS (candidates[j].sym))
2882 case LOC_REGPARM_ADDR:
2890 if (j < n_candidates)
2893 while (j < n_candidates)
2895 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
2897 candidates[j] = candidates[n_candidates - 1];
2906 if (n_candidates == 0)
2907 error (_("No definition found for %s"),
2908 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2909 else if (n_candidates == 1)
2911 else if (deprocedure_p
2912 && !is_nonfunction (candidates, n_candidates))
2914 i = ada_resolve_function
2915 (candidates, n_candidates, NULL, 0,
2916 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
2919 error (_("Could not find a match for %s"),
2920 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2924 printf_filtered (_("Multiple matches for %s\n"),
2925 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2926 user_select_syms (candidates, n_candidates, 1);
2930 exp->elts[pc + 1].block = candidates[i].block;
2931 exp->elts[pc + 2].symbol = candidates[i].sym;
2932 if (innermost_block == NULL
2933 || contained_in (candidates[i].block, innermost_block))
2934 innermost_block = candidates[i].block;
2938 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
2941 replace_operator_with_call (expp, pc, 0, 0,
2942 exp->elts[pc + 2].symbol,
2943 exp->elts[pc + 1].block);
2950 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2951 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2953 struct ada_symbol_info *candidates;
2957 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2958 (exp->elts[pc + 5].symbol),
2959 exp->elts[pc + 4].block, VAR_DOMAIN,
2961 if (n_candidates == 1)
2965 i = ada_resolve_function
2966 (candidates, n_candidates,
2968 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
2971 error (_("Could not find a match for %s"),
2972 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
2975 exp->elts[pc + 4].block = candidates[i].block;
2976 exp->elts[pc + 5].symbol = candidates[i].sym;
2977 if (innermost_block == NULL
2978 || contained_in (candidates[i].block, innermost_block))
2979 innermost_block = candidates[i].block;
2990 case BINOP_BITWISE_AND:
2991 case BINOP_BITWISE_IOR:
2992 case BINOP_BITWISE_XOR:
2994 case BINOP_NOTEQUAL:
3002 case UNOP_LOGICAL_NOT:
3004 if (possible_user_operator_p (op, argvec))
3006 struct ada_symbol_info *candidates;
3010 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
3011 (struct block *) NULL, VAR_DOMAIN,
3013 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
3014 ada_decoded_op_name (op), NULL);
3018 replace_operator_with_call (expp, pc, nargs, 1,
3019 candidates[i].sym, candidates[i].block);
3030 return evaluate_subexp_type (exp, pos);
3033 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3034 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3035 a non-pointer. A type of 'void' (which is never a valid expression type)
3036 by convention matches anything. */
3037 /* The term "match" here is rather loose. The match is heuristic and
3038 liberal. FIXME: TOO liberal, in fact. */
3041 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3043 ftype = ada_check_typedef (ftype);
3044 atype = ada_check_typedef (atype);
3046 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3047 ftype = TYPE_TARGET_TYPE (ftype);
3048 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3049 atype = TYPE_TARGET_TYPE (atype);
3051 if (TYPE_CODE (ftype) == TYPE_CODE_VOID
3052 || TYPE_CODE (atype) == TYPE_CODE_VOID)
3055 switch (TYPE_CODE (ftype))
3060 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3061 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3062 TYPE_TARGET_TYPE (atype), 0);
3065 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3067 case TYPE_CODE_ENUM:
3068 case TYPE_CODE_RANGE:
3069 switch (TYPE_CODE (atype))
3072 case TYPE_CODE_ENUM:
3073 case TYPE_CODE_RANGE:
3079 case TYPE_CODE_ARRAY:
3080 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3081 || ada_is_array_descriptor_type (atype));
3083 case TYPE_CODE_STRUCT:
3084 if (ada_is_array_descriptor_type (ftype))
3085 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3086 || ada_is_array_descriptor_type (atype));
3088 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3089 && !ada_is_array_descriptor_type (atype));
3091 case TYPE_CODE_UNION:
3093 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3097 /* Return non-zero if the formals of FUNC "sufficiently match" the
3098 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3099 may also be an enumeral, in which case it is treated as a 0-
3100 argument function. */
3103 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3106 struct type *func_type = SYMBOL_TYPE (func);
3108 if (SYMBOL_CLASS (func) == LOC_CONST
3109 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3110 return (n_actuals == 0);
3111 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3114 if (TYPE_NFIELDS (func_type) != n_actuals)
3117 for (i = 0; i < n_actuals; i += 1)
3119 if (actuals[i] == NULL)
3123 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type, i));
3124 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3126 if (!ada_type_match (ftype, atype, 1))
3133 /* False iff function type FUNC_TYPE definitely does not produce a value
3134 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3135 FUNC_TYPE is not a valid function type with a non-null return type
3136 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3139 return_match (struct type *func_type, struct type *context_type)
3141 struct type *return_type;
3143 if (func_type == NULL)
3146 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3147 return_type = base_type (TYPE_TARGET_TYPE (func_type));
3149 return_type = base_type (func_type);
3150 if (return_type == NULL)
3153 context_type = base_type (context_type);
3155 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3156 return context_type == NULL || return_type == context_type;
3157 else if (context_type == NULL)
3158 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3160 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3164 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3165 function (if any) that matches the types of the NARGS arguments in
3166 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3167 that returns that type, then eliminate matches that don't. If
3168 CONTEXT_TYPE is void and there is at least one match that does not
3169 return void, eliminate all matches that do.
3171 Asks the user if there is more than one match remaining. Returns -1
3172 if there is no such symbol or none is selected. NAME is used
3173 solely for messages. May re-arrange and modify SYMS in
3174 the process; the index returned is for the modified vector. */
3177 ada_resolve_function (struct ada_symbol_info syms[],
3178 int nsyms, struct value **args, int nargs,
3179 const char *name, struct type *context_type)
3182 int m; /* Number of hits */
3183 struct type *fallback;
3184 struct type *return_type;
3186 return_type = context_type;
3187 if (context_type == NULL)
3188 fallback = builtin_type_void;
3195 for (k = 0; k < nsyms; k += 1)
3197 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
3199 if (ada_args_match (syms[k].sym, args, nargs)
3200 && return_match (type, return_type))
3206 if (m > 0 || return_type == fallback)
3209 return_type = fallback;
3216 printf_filtered (_("Multiple matches for %s\n"), name);
3217 user_select_syms (syms, m, 1);
3223 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3224 in a listing of choices during disambiguation (see sort_choices, below).
3225 The idea is that overloadings of a subprogram name from the
3226 same package should sort in their source order. We settle for ordering
3227 such symbols by their trailing number (__N or $N). */
3230 encoded_ordered_before (char *N0, char *N1)
3234 else if (N0 == NULL)
3239 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3241 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3243 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3244 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3248 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3251 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3253 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3254 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3256 return (strcmp (N0, N1) < 0);
3260 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3264 sort_choices (struct ada_symbol_info syms[], int nsyms)
3267 for (i = 1; i < nsyms; i += 1)
3269 struct ada_symbol_info sym = syms[i];
3272 for (j = i - 1; j >= 0; j -= 1)
3274 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3275 SYMBOL_LINKAGE_NAME (sym.sym)))
3277 syms[j + 1] = syms[j];
3283 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3284 by asking the user (if necessary), returning the number selected,
3285 and setting the first elements of SYMS items. Error if no symbols
3288 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3289 to be re-integrated one of these days. */
3292 user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
3295 int *chosen = (int *) alloca (sizeof (int) * nsyms);
3297 int first_choice = (max_results == 1) ? 1 : 2;
3298 const char *select_mode = multiple_symbols_select_mode ();
3300 if (max_results < 1)
3301 error (_("Request to select 0 symbols!"));
3305 if (select_mode == multiple_symbols_cancel)
3307 canceled because the command is ambiguous\n\
3308 See set/show multiple-symbol."));
3310 /* If select_mode is "all", then return all possible symbols.
3311 Only do that if more than one symbol can be selected, of course.
3312 Otherwise, display the menu as usual. */
3313 if (select_mode == multiple_symbols_all && max_results > 1)
3316 printf_unfiltered (_("[0] cancel\n"));
3317 if (max_results > 1)
3318 printf_unfiltered (_("[1] all\n"));
3320 sort_choices (syms, nsyms);
3322 for (i = 0; i < nsyms; i += 1)
3324 if (syms[i].sym == NULL)
3327 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3329 struct symtab_and_line sal =
3330 find_function_start_sal (syms[i].sym, 1);
3331 if (sal.symtab == NULL)
3332 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3334 SYMBOL_PRINT_NAME (syms[i].sym),
3337 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3338 SYMBOL_PRINT_NAME (syms[i].sym),
3339 sal.symtab->filename, sal.line);
3345 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3346 && SYMBOL_TYPE (syms[i].sym) != NULL
3347 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
3348 struct symtab *symtab = symtab_for_sym (syms[i].sym);
3350 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
3351 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3353 SYMBOL_PRINT_NAME (syms[i].sym),
3354 symtab->filename, SYMBOL_LINE (syms[i].sym));
3355 else if (is_enumeral
3356 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
3358 printf_unfiltered (("[%d] "), i + first_choice);
3359 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
3361 printf_unfiltered (_("'(%s) (enumeral)\n"),
3362 SYMBOL_PRINT_NAME (syms[i].sym));
3364 else if (symtab != NULL)
3365 printf_unfiltered (is_enumeral
3366 ? _("[%d] %s in %s (enumeral)\n")
3367 : _("[%d] %s at %s:?\n"),
3369 SYMBOL_PRINT_NAME (syms[i].sym),
3372 printf_unfiltered (is_enumeral
3373 ? _("[%d] %s (enumeral)\n")
3374 : _("[%d] %s at ?\n"),
3376 SYMBOL_PRINT_NAME (syms[i].sym));
3380 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3383 for (i = 0; i < n_chosen; i += 1)
3384 syms[i] = syms[chosen[i]];
3389 /* Read and validate a set of numeric choices from the user in the
3390 range 0 .. N_CHOICES-1. Place the results in increasing
3391 order in CHOICES[0 .. N-1], and return N.
3393 The user types choices as a sequence of numbers on one line
3394 separated by blanks, encoding them as follows:
3396 + A choice of 0 means to cancel the selection, throwing an error.
3397 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3398 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3400 The user is not allowed to choose more than MAX_RESULTS values.
3402 ANNOTATION_SUFFIX, if present, is used to annotate the input
3403 prompts (for use with the -f switch). */
3406 get_selections (int *choices, int n_choices, int max_results,
3407 int is_all_choice, char *annotation_suffix)
3412 int first_choice = is_all_choice ? 2 : 1;
3414 prompt = getenv ("PS2");
3418 args = command_line_input (prompt, 0, annotation_suffix);
3421 error_no_arg (_("one or more choice numbers"));
3425 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3426 order, as given in args. Choices are validated. */
3432 while (isspace (*args))
3434 if (*args == '\0' && n_chosen == 0)
3435 error_no_arg (_("one or more choice numbers"));
3436 else if (*args == '\0')
3439 choice = strtol (args, &args2, 10);
3440 if (args == args2 || choice < 0
3441 || choice > n_choices + first_choice - 1)
3442 error (_("Argument must be choice number"));
3446 error (_("cancelled"));
3448 if (choice < first_choice)
3450 n_chosen = n_choices;
3451 for (j = 0; j < n_choices; j += 1)
3455 choice -= first_choice;
3457 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3461 if (j < 0 || choice != choices[j])
3464 for (k = n_chosen - 1; k > j; k -= 1)
3465 choices[k + 1] = choices[k];
3466 choices[j + 1] = choice;
3471 if (n_chosen > max_results)
3472 error (_("Select no more than %d of the above"), max_results);
3477 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3478 on the function identified by SYM and BLOCK, and taking NARGS
3479 arguments. Update *EXPP as needed to hold more space. */
3482 replace_operator_with_call (struct expression **expp, int pc, int nargs,
3483 int oplen, struct symbol *sym,
3484 struct block *block)
3486 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3487 symbol, -oplen for operator being replaced). */
3488 struct expression *newexp = (struct expression *)
3489 xmalloc (sizeof (struct expression)
3490 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
3491 struct expression *exp = *expp;
3493 newexp->nelts = exp->nelts + 7 - oplen;
3494 newexp->language_defn = exp->language_defn;
3495 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
3496 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
3497 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
3499 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3500 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3502 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3503 newexp->elts[pc + 4].block = block;
3504 newexp->elts[pc + 5].symbol = sym;
3510 /* Type-class predicates */
3512 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3516 numeric_type_p (struct type *type)
3522 switch (TYPE_CODE (type))
3527 case TYPE_CODE_RANGE:
3528 return (type == TYPE_TARGET_TYPE (type)
3529 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3536 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3539 integer_type_p (struct type *type)
3545 switch (TYPE_CODE (type))
3549 case TYPE_CODE_RANGE:
3550 return (type == TYPE_TARGET_TYPE (type)
3551 || integer_type_p (TYPE_TARGET_TYPE (type)));
3558 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3561 scalar_type_p (struct type *type)
3567 switch (TYPE_CODE (type))
3570 case TYPE_CODE_RANGE:
3571 case TYPE_CODE_ENUM:
3580 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3583 discrete_type_p (struct type *type)
3589 switch (TYPE_CODE (type))
3592 case TYPE_CODE_RANGE:
3593 case TYPE_CODE_ENUM:
3601 /* Returns non-zero if OP with operands in the vector ARGS could be
3602 a user-defined function. Errs on the side of pre-defined operators
3603 (i.e., result 0). */
3606 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3608 struct type *type0 =
3609 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3610 struct type *type1 =
3611 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3625 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3629 case BINOP_BITWISE_AND:
3630 case BINOP_BITWISE_IOR:
3631 case BINOP_BITWISE_XOR:
3632 return (!(integer_type_p (type0) && integer_type_p (type1)));
3635 case BINOP_NOTEQUAL:
3640 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3643 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
3646 return (!(numeric_type_p (type0) && integer_type_p (type1)));
3650 case UNOP_LOGICAL_NOT:
3652 return (!numeric_type_p (type0));
3661 1. In the following, we assume that a renaming type's name may
3662 have an ___XD suffix. It would be nice if this went away at some
3664 2. We handle both the (old) purely type-based representation of
3665 renamings and the (new) variable-based encoding. At some point,
3666 it is devoutly to be hoped that the former goes away
3667 (FIXME: hilfinger-2007-07-09).
3668 3. Subprogram renamings are not implemented, although the XRS
3669 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3671 /* If SYM encodes a renaming,
3673 <renaming> renames <renamed entity>,
3675 sets *LEN to the length of the renamed entity's name,
3676 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3677 the string describing the subcomponent selected from the renamed
3678 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3679 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3680 are undefined). Otherwise, returns a value indicating the category
3681 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3682 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3683 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3684 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3685 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3686 may be NULL, in which case they are not assigned.
3688 [Currently, however, GCC does not generate subprogram renamings.] */
3690 enum ada_renaming_category
3691 ada_parse_renaming (struct symbol *sym,
3692 const char **renamed_entity, int *len,
3693 const char **renaming_expr)
3695 enum ada_renaming_category kind;
3700 return ADA_NOT_RENAMING;
3701 switch (SYMBOL_CLASS (sym))
3704 return ADA_NOT_RENAMING;
3706 return parse_old_style_renaming (SYMBOL_TYPE (sym),
3707 renamed_entity, len, renaming_expr);
3711 case LOC_OPTIMIZED_OUT:
3712 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
3714 return ADA_NOT_RENAMING;
3718 kind = ADA_OBJECT_RENAMING;
3722 kind = ADA_EXCEPTION_RENAMING;
3726 kind = ADA_PACKAGE_RENAMING;
3730 kind = ADA_SUBPROGRAM_RENAMING;
3734 return ADA_NOT_RENAMING;
3738 if (renamed_entity != NULL)
3739 *renamed_entity = info;
3740 suffix = strstr (info, "___XE");
3741 if (suffix == NULL || suffix == info)
3742 return ADA_NOT_RENAMING;
3744 *len = strlen (info) - strlen (suffix);
3746 if (renaming_expr != NULL)
3747 *renaming_expr = suffix;
3751 /* Assuming TYPE encodes a renaming according to the old encoding in
3752 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3753 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3754 ADA_NOT_RENAMING otherwise. */
3755 static enum ada_renaming_category
3756 parse_old_style_renaming (struct type *type,
3757 const char **renamed_entity, int *len,
3758 const char **renaming_expr)
3760 enum ada_renaming_category kind;
3765 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
3766 || TYPE_NFIELDS (type) != 1)
3767 return ADA_NOT_RENAMING;
3769 name = type_name_no_tag (type);
3771 return ADA_NOT_RENAMING;
3773 name = strstr (name, "___XR");
3775 return ADA_NOT_RENAMING;
3780 kind = ADA_OBJECT_RENAMING;
3783 kind = ADA_EXCEPTION_RENAMING;
3786 kind = ADA_PACKAGE_RENAMING;
3789 kind = ADA_SUBPROGRAM_RENAMING;
3792 return ADA_NOT_RENAMING;
3795 info = TYPE_FIELD_NAME (type, 0);
3797 return ADA_NOT_RENAMING;
3798 if (renamed_entity != NULL)
3799 *renamed_entity = info;
3800 suffix = strstr (info, "___XE");
3801 if (renaming_expr != NULL)
3802 *renaming_expr = suffix + 5;
3803 if (suffix == NULL || suffix == info)
3804 return ADA_NOT_RENAMING;
3806 *len = suffix - info;
3812 /* Evaluation: Function Calls */
3814 /* Return an lvalue containing the value VAL. This is the identity on
3815 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3816 on the stack, using and updating *SP as the stack pointer, and
3817 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3819 static struct value *
3820 ensure_lval (struct value *val, CORE_ADDR *sp)
3822 if (! VALUE_LVAL (val))
3824 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
3826 /* The following is taken from the structure-return code in
3827 call_function_by_hand. FIXME: Therefore, some refactoring seems
3829 if (gdbarch_inner_than (current_gdbarch, 1, 2))
3831 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3832 reserving sufficient space. */
3834 if (gdbarch_frame_align_p (current_gdbarch))
3835 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3836 VALUE_ADDRESS (val) = *sp;
3840 /* Stack grows upward. Align the frame, allocate space, and
3841 then again, re-align the frame. */
3842 if (gdbarch_frame_align_p (current_gdbarch))
3843 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3844 VALUE_ADDRESS (val) = *sp;
3846 if (gdbarch_frame_align_p (current_gdbarch))
3847 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3849 VALUE_LVAL (val) = lval_memory;
3851 write_memory (VALUE_ADDRESS (val), value_contents_raw (val), len);
3857 /* Return the value ACTUAL, converted to be an appropriate value for a
3858 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3859 allocating any necessary descriptors (fat pointers), or copies of
3860 values not residing in memory, updating it as needed. */
3863 ada_convert_actual (struct value *actual, struct type *formal_type0,
3866 struct type *actual_type = ada_check_typedef (value_type (actual));
3867 struct type *formal_type = ada_check_typedef (formal_type0);
3868 struct type *formal_target =
3869 TYPE_CODE (formal_type) == TYPE_CODE_PTR
3870 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
3871 struct type *actual_target =
3872 TYPE_CODE (actual_type) == TYPE_CODE_PTR
3873 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
3875 if (ada_is_array_descriptor_type (formal_target)
3876 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
3877 return make_array_descriptor (formal_type, actual, sp);
3878 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
3879 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
3881 struct value *result;
3882 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
3883 && ada_is_array_descriptor_type (actual_target))
3884 result = desc_data (actual);
3885 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
3887 if (VALUE_LVAL (actual) != lval_memory)
3890 actual_type = ada_check_typedef (value_type (actual));
3891 val = allocate_value (actual_type);
3892 memcpy ((char *) value_contents_raw (val),
3893 (char *) value_contents (actual),
3894 TYPE_LENGTH (actual_type));
3895 actual = ensure_lval (val, sp);
3897 result = value_addr (actual);
3901 return value_cast_pointers (formal_type, result);
3903 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
3904 return ada_value_ind (actual);
3910 /* Push a descriptor of type TYPE for array value ARR on the stack at
3911 *SP, updating *SP to reflect the new descriptor. Return either
3912 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3913 to-descriptor type rather than a descriptor type), a struct value *
3914 representing a pointer to this descriptor. */
3916 static struct value *
3917 make_array_descriptor (struct type *type, struct value *arr, CORE_ADDR *sp)
3919 struct type *bounds_type = desc_bounds_type (type);
3920 struct type *desc_type = desc_base_type (type);
3921 struct value *descriptor = allocate_value (desc_type);
3922 struct value *bounds = allocate_value (bounds_type);
3925 for (i = ada_array_arity (ada_check_typedef (value_type (arr))); i > 0; i -= 1)
3927 modify_general_field (value_contents_writeable (bounds),
3928 value_as_long (ada_array_bound (arr, i, 0)),
3929 desc_bound_bitpos (bounds_type, i, 0),
3930 desc_bound_bitsize (bounds_type, i, 0));
3931 modify_general_field (value_contents_writeable (bounds),
3932 value_as_long (ada_array_bound (arr, i, 1)),
3933 desc_bound_bitpos (bounds_type, i, 1),
3934 desc_bound_bitsize (bounds_type, i, 1));
3937 bounds = ensure_lval (bounds, sp);
3939 modify_general_field (value_contents_writeable (descriptor),
3940 VALUE_ADDRESS (ensure_lval (arr, sp)),
3941 fat_pntr_data_bitpos (desc_type),
3942 fat_pntr_data_bitsize (desc_type));
3944 modify_general_field (value_contents_writeable (descriptor),
3945 VALUE_ADDRESS (bounds),
3946 fat_pntr_bounds_bitpos (desc_type),
3947 fat_pntr_bounds_bitsize (desc_type));
3949 descriptor = ensure_lval (descriptor, sp);
3951 if (TYPE_CODE (type) == TYPE_CODE_PTR)
3952 return value_addr (descriptor);
3957 /* Dummy definitions for an experimental caching module that is not
3958 * used in the public sources. */
3961 lookup_cached_symbol (const char *name, domain_enum namespace,
3962 struct symbol **sym, struct block **block)
3968 cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
3969 struct block *block)
3975 /* Return the result of a standard (literal, C-like) lookup of NAME in
3976 given DOMAIN, visible from lexical block BLOCK. */
3978 static struct symbol *
3979 standard_lookup (const char *name, const struct block *block,
3984 if (lookup_cached_symbol (name, domain, &sym, NULL))
3986 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
3987 cache_symbol (name, domain, sym, block_found);
3992 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3993 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3994 since they contend in overloading in the same way. */
3996 is_nonfunction (struct ada_symbol_info syms[], int n)
4000 for (i = 0; i < n; i += 1)
4001 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4002 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4003 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
4009 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4010 struct types. Otherwise, they may not. */
4013 equiv_types (struct type *type0, struct type *type1)
4017 if (type0 == NULL || type1 == NULL
4018 || TYPE_CODE (type0) != TYPE_CODE (type1))
4020 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4021 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4022 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4023 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4029 /* True iff SYM0 represents the same entity as SYM1, or one that is
4030 no more defined than that of SYM1. */
4033 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4037 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4038 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4041 switch (SYMBOL_CLASS (sym0))
4047 struct type *type0 = SYMBOL_TYPE (sym0);
4048 struct type *type1 = SYMBOL_TYPE (sym1);
4049 char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4050 char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4051 int len0 = strlen (name0);
4053 TYPE_CODE (type0) == TYPE_CODE (type1)
4054 && (equiv_types (type0, type1)
4055 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4056 && strncmp (name1 + len0, "___XV", 5) == 0));
4059 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4060 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4066 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4067 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4070 add_defn_to_vec (struct obstack *obstackp,
4072 struct block *block)
4076 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
4078 /* Do not try to complete stub types, as the debugger is probably
4079 already scanning all symbols matching a certain name at the
4080 time when this function is called. Trying to replace the stub
4081 type by its associated full type will cause us to restart a scan
4082 which may lead to an infinite recursion. Instead, the client
4083 collecting the matching symbols will end up collecting several
4084 matches, with at least one of them complete. It can then filter
4085 out the stub ones if needed. */
4087 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4089 if (lesseq_defined_than (sym, prevDefns[i].sym))
4091 else if (lesseq_defined_than (prevDefns[i].sym, sym))
4093 prevDefns[i].sym = sym;
4094 prevDefns[i].block = block;
4100 struct ada_symbol_info info;
4104 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4108 /* Number of ada_symbol_info structures currently collected in
4109 current vector in *OBSTACKP. */
4112 num_defns_collected (struct obstack *obstackp)
4114 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4117 /* Vector of ada_symbol_info structures currently collected in current
4118 vector in *OBSTACKP. If FINISH, close off the vector and return
4119 its final address. */
4121 static struct ada_symbol_info *
4122 defns_collected (struct obstack *obstackp, int finish)
4125 return obstack_finish (obstackp);
4127 return (struct ada_symbol_info *) obstack_base (obstackp);
4130 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
4131 Check the global symbols if GLOBAL, the static symbols if not.
4132 Do wild-card match if WILD. */
4134 static struct partial_symbol *
4135 ada_lookup_partial_symbol (struct partial_symtab *pst, const char *name,
4136 int global, domain_enum namespace, int wild)
4138 struct partial_symbol **start;
4139 int name_len = strlen (name);
4140 int length = (global ? pst->n_global_syms : pst->n_static_syms);
4149 pst->objfile->global_psymbols.list + pst->globals_offset :
4150 pst->objfile->static_psymbols.list + pst->statics_offset);
4154 for (i = 0; i < length; i += 1)
4156 struct partial_symbol *psym = start[i];
4158 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
4159 SYMBOL_DOMAIN (psym), namespace)
4160 && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (psym)))
4174 int M = (U + i) >> 1;
4175 struct partial_symbol *psym = start[M];
4176 if (SYMBOL_LINKAGE_NAME (psym)[0] < name[0])
4178 else if (SYMBOL_LINKAGE_NAME (psym)[0] > name[0])
4180 else if (strcmp (SYMBOL_LINKAGE_NAME (psym), name) < 0)
4191 struct partial_symbol *psym = start[i];
4193 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
4194 SYMBOL_DOMAIN (psym), namespace))
4196 int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym), name_len);
4204 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)
4218 int M = (U + i) >> 1;
4219 struct partial_symbol *psym = start[M];
4220 if (SYMBOL_LINKAGE_NAME (psym)[0] < '_')
4222 else if (SYMBOL_LINKAGE_NAME (psym)[0] > '_')
4224 else if (strcmp (SYMBOL_LINKAGE_NAME (psym), "_ada_") < 0)
4235 struct partial_symbol *psym = start[i];
4237 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym),
4238 SYMBOL_DOMAIN (psym), namespace))
4242 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym)[0];
4245 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym), 5);
4247 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym) + 5,
4257 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)
4267 /* Find a symbol table containing symbol SYM or NULL if none. */
4269 static struct symtab *
4270 symtab_for_sym (struct symbol *sym)
4273 struct objfile *objfile;
4275 struct symbol *tmp_sym;
4276 struct dict_iterator iter;
4279 ALL_PRIMARY_SYMTABS (objfile, s)
4281 switch (SYMBOL_CLASS (sym))
4289 case LOC_CONST_BYTES:
4290 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
4291 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4293 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
4294 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4300 switch (SYMBOL_CLASS (sym))
4305 case LOC_REGPARM_ADDR:
4309 for (j = FIRST_LOCAL_BLOCK;
4310 j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s)); j += 1)
4312 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), j);
4313 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4324 /* Return a minimal symbol matching NAME according to Ada decoding
4325 rules. Returns NULL if there is no such minimal symbol. Names
4326 prefixed with "standard__" are handled specially: "standard__" is
4327 first stripped off, and only static and global symbols are searched. */
4329 struct minimal_symbol *
4330 ada_lookup_simple_minsym (const char *name)
4332 struct objfile *objfile;
4333 struct minimal_symbol *msymbol;
4336 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
4338 name += sizeof ("standard__") - 1;
4342 wild_match = (strstr (name, "__") == NULL);
4344 ALL_MSYMBOLS (objfile, msymbol)
4346 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match)
4347 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4354 /* For all subprograms that statically enclose the subprogram of the
4355 selected frame, add symbols matching identifier NAME in DOMAIN
4356 and their blocks to the list of data in OBSTACKP, as for
4357 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4361 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4362 const char *name, domain_enum namespace,
4367 /* True if TYPE is definitely an artificial type supplied to a symbol
4368 for which no debugging information was given in the symbol file. */
4371 is_nondebugging_type (struct type *type)
4373 char *name = ada_type_name (type);
4374 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4377 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4378 duplicate other symbols in the list (The only case I know of where
4379 this happens is when object files containing stabs-in-ecoff are
4380 linked with files containing ordinary ecoff debugging symbols (or no
4381 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4382 Returns the number of items in the modified list. */
4385 remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4394 /* If two symbols have the same name and one of them is a stub type,
4395 the get rid of the stub. */
4397 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4398 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4400 for (j = 0; j < nsyms; j++)
4403 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4404 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4405 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4406 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
4411 /* Two symbols with the same name, same class and same address
4412 should be identical. */
4414 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
4415 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4416 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4418 for (j = 0; j < nsyms; j += 1)
4421 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4422 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4423 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
4424 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4425 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4426 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
4433 for (j = i + 1; j < nsyms; j += 1)
4434 syms[j - 1] = syms[j];
4443 /* Given a type that corresponds to a renaming entity, use the type name
4444 to extract the scope (package name or function name, fully qualified,
4445 and following the GNAT encoding convention) where this renaming has been
4446 defined. The string returned needs to be deallocated after use. */
4449 xget_renaming_scope (struct type *renaming_type)
4451 /* The renaming types adhere to the following convention:
4452 <scope>__<rename>___<XR extension>.
4453 So, to extract the scope, we search for the "___XR" extension,
4454 and then backtrack until we find the first "__". */
4456 const char *name = type_name_no_tag (renaming_type);
4457 char *suffix = strstr (name, "___XR");
4462 /* Now, backtrack a bit until we find the first "__". Start looking
4463 at suffix - 3, as the <rename> part is at least one character long. */
4465 for (last = suffix - 3; last > name; last--)
4466 if (last[0] == '_' && last[1] == '_')
4469 /* Make a copy of scope and return it. */
4471 scope_len = last - name;
4472 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
4474 strncpy (scope, name, scope_len);
4475 scope[scope_len] = '\0';
4480 /* Return nonzero if NAME corresponds to a package name. */
4483 is_package_name (const char *name)
4485 /* Here, We take advantage of the fact that no symbols are generated
4486 for packages, while symbols are generated for each function.
4487 So the condition for NAME represent a package becomes equivalent
4488 to NAME not existing in our list of symbols. There is only one
4489 small complication with library-level functions (see below). */
4493 /* If it is a function that has not been defined at library level,
4494 then we should be able to look it up in the symbols. */
4495 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4498 /* Library-level function names start with "_ada_". See if function
4499 "_ada_" followed by NAME can be found. */
4501 /* Do a quick check that NAME does not contain "__", since library-level
4502 functions names cannot contain "__" in them. */
4503 if (strstr (name, "__") != NULL)
4506 fun_name = xstrprintf ("_ada_%s", name);
4508 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4511 /* Return nonzero if SYM corresponds to a renaming entity that is
4512 not visible from FUNCTION_NAME. */
4515 old_renaming_is_invisible (const struct symbol *sym, char *function_name)
4519 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
4522 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
4524 make_cleanup (xfree, scope);
4526 /* If the rename has been defined in a package, then it is visible. */
4527 if (is_package_name (scope))
4530 /* Check that the rename is in the current function scope by checking
4531 that its name starts with SCOPE. */
4533 /* If the function name starts with "_ada_", it means that it is
4534 a library-level function. Strip this prefix before doing the
4535 comparison, as the encoding for the renaming does not contain
4537 if (strncmp (function_name, "_ada_", 5) == 0)
4540 return (strncmp (function_name, scope, strlen (scope)) != 0);
4543 /* Remove entries from SYMS that corresponds to a renaming entity that
4544 is not visible from the function associated with CURRENT_BLOCK or
4545 that is superfluous due to the presence of more specific renaming
4546 information. Places surviving symbols in the initial entries of
4547 SYMS and returns the number of surviving symbols.
4550 First, in cases where an object renaming is implemented as a
4551 reference variable, GNAT may produce both the actual reference
4552 variable and the renaming encoding. In this case, we discard the
4555 Second, GNAT emits a type following a specified encoding for each renaming
4556 entity. Unfortunately, STABS currently does not support the definition
4557 of types that are local to a given lexical block, so all renamings types
4558 are emitted at library level. As a consequence, if an application
4559 contains two renaming entities using the same name, and a user tries to
4560 print the value of one of these entities, the result of the ada symbol
4561 lookup will also contain the wrong renaming type.
4563 This function partially covers for this limitation by attempting to
4564 remove from the SYMS list renaming symbols that should be visible
4565 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4566 method with the current information available. The implementation
4567 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4569 - When the user tries to print a rename in a function while there
4570 is another rename entity defined in a package: Normally, the
4571 rename in the function has precedence over the rename in the
4572 package, so the latter should be removed from the list. This is
4573 currently not the case.
4575 - This function will incorrectly remove valid renames if
4576 the CURRENT_BLOCK corresponds to a function which symbol name
4577 has been changed by an "Export" pragma. As a consequence,
4578 the user will be unable to print such rename entities. */
4581 remove_irrelevant_renamings (struct ada_symbol_info *syms,
4582 int nsyms, const struct block *current_block)
4584 struct symbol *current_function;
4585 char *current_function_name;
4587 int is_new_style_renaming;
4589 /* If there is both a renaming foo___XR... encoded as a variable and
4590 a simple variable foo in the same block, discard the latter.
4591 First, zero out such symbols, then compress. */
4592 is_new_style_renaming = 0;
4593 for (i = 0; i < nsyms; i += 1)
4595 struct symbol *sym = syms[i].sym;
4596 struct block *block = syms[i].block;
4600 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
4602 name = SYMBOL_LINKAGE_NAME (sym);
4603 suffix = strstr (name, "___XR");
4607 int name_len = suffix - name;
4609 is_new_style_renaming = 1;
4610 for (j = 0; j < nsyms; j += 1)
4611 if (i != j && syms[j].sym != NULL
4612 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
4614 && block == syms[j].block)
4618 if (is_new_style_renaming)
4622 for (j = k = 0; j < nsyms; j += 1)
4623 if (syms[j].sym != NULL)
4631 /* Extract the function name associated to CURRENT_BLOCK.
4632 Abort if unable to do so. */
4634 if (current_block == NULL)
4637 current_function = block_linkage_function (current_block);
4638 if (current_function == NULL)
4641 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4642 if (current_function_name == NULL)
4645 /* Check each of the symbols, and remove it from the list if it is
4646 a type corresponding to a renaming that is out of the scope of
4647 the current block. */
4652 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
4653 == ADA_OBJECT_RENAMING
4654 && old_renaming_is_invisible (syms[i].sym, current_function_name))
4657 for (j = i + 1; j < nsyms; j += 1)
4658 syms[j - 1] = syms[j];
4668 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4669 whose name and domain match NAME and DOMAIN respectively.
4670 If no match was found, then extend the search to "enclosing"
4671 routines (in other words, if we're inside a nested function,
4672 search the symbols defined inside the enclosing functions).
4674 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4677 ada_add_local_symbols (struct obstack *obstackp, const char *name,
4678 struct block *block, domain_enum domain,
4681 int block_depth = 0;
4683 while (block != NULL)
4686 ada_add_block_symbols (obstackp, block, name, domain, NULL, wild_match);
4688 /* If we found a non-function match, assume that's the one. */
4689 if (is_nonfunction (defns_collected (obstackp, 0),
4690 num_defns_collected (obstackp)))
4693 block = BLOCK_SUPERBLOCK (block);
4696 /* If no luck so far, try to find NAME as a local symbol in some lexically
4697 enclosing subprogram. */
4698 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
4699 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match);
4702 /* Add to OBSTACKP all non-local symbols whose name and domain match
4703 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
4704 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
4707 ada_add_non_local_symbols (struct obstack *obstackp, const char *name,
4708 domain_enum domain, int global,
4711 struct objfile *objfile;
4712 struct partial_symtab *ps;
4714 ALL_PSYMTABS (objfile, ps)
4718 || ada_lookup_partial_symbol (ps, name, global, domain, wild_match))
4720 struct symtab *s = PSYMTAB_TO_SYMTAB (ps);
4721 const int block_kind = global ? GLOBAL_BLOCK : STATIC_BLOCK;
4723 if (s == NULL || !s->primary)
4725 ada_add_block_symbols (obstackp,
4726 BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), block_kind),
4727 name, domain, objfile, wild_match);
4732 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4733 scope and in global scopes, returning the number of matches. Sets
4734 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4735 indicating the symbols found and the blocks and symbol tables (if
4736 any) in which they were found. This vector are transient---good only to
4737 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4738 symbol match within the nest of blocks whose innermost member is BLOCK0,
4739 is the one match returned (no other matches in that or
4740 enclosing blocks is returned). If there are any matches in or
4741 surrounding BLOCK0, then these alone are returned. Otherwise, the
4742 search extends to global and file-scope (static) symbol tables.
4743 Names prefixed with "standard__" are handled specially: "standard__"
4744 is first stripped off, and only static and global symbols are searched. */
4747 ada_lookup_symbol_list (const char *name0, const struct block *block0,
4748 domain_enum namespace,
4749 struct ada_symbol_info **results)
4752 struct block *block;
4758 obstack_free (&symbol_list_obstack, NULL);
4759 obstack_init (&symbol_list_obstack);
4763 /* Search specified block and its superiors. */
4765 wild_match = (strstr (name0, "__") == NULL);
4767 block = (struct block *) block0; /* FIXME: No cast ought to be
4768 needed, but adding const will
4769 have a cascade effect. */
4771 /* Special case: If the user specifies a symbol name inside package
4772 Standard, do a non-wild matching of the symbol name without
4773 the "standard__" prefix. This was primarily introduced in order
4774 to allow the user to specifically access the standard exceptions
4775 using, for instance, Standard.Constraint_Error when Constraint_Error
4776 is ambiguous (due to the user defining its own Constraint_Error
4777 entity inside its program). */
4778 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
4782 name = name0 + sizeof ("standard__") - 1;
4785 /* Check the non-global symbols. If we have ANY match, then we're done. */
4787 ada_add_local_symbols (&symbol_list_obstack, name, block, namespace,
4789 if (num_defns_collected (&symbol_list_obstack) > 0)
4792 /* No non-global symbols found. Check our cache to see if we have
4793 already performed this search before. If we have, then return
4797 if (lookup_cached_symbol (name0, namespace, &sym, &block))
4800 add_defn_to_vec (&symbol_list_obstack, sym, block);
4804 /* Search symbols from all global blocks. */
4806 ada_add_non_local_symbols (&symbol_list_obstack, name, namespace, 1,
4809 /* Now add symbols from all per-file blocks if we've gotten no hits
4810 (not strictly correct, but perhaps better than an error). */
4812 if (num_defns_collected (&symbol_list_obstack) == 0)
4813 ada_add_non_local_symbols (&symbol_list_obstack, name, namespace, 0,
4817 ndefns = num_defns_collected (&symbol_list_obstack);
4818 *results = defns_collected (&symbol_list_obstack, 1);
4820 ndefns = remove_extra_symbols (*results, ndefns);
4823 cache_symbol (name0, namespace, NULL, NULL);
4825 if (ndefns == 1 && cacheIfUnique)
4826 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block);
4828 ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
4834 ada_lookup_encoded_symbol (const char *name, const struct block *block0,
4835 domain_enum namespace, struct block **block_found)
4837 struct ada_symbol_info *candidates;
4840 n_candidates = ada_lookup_symbol_list (name, block0, namespace, &candidates);
4842 if (n_candidates == 0)
4845 if (block_found != NULL)
4846 *block_found = candidates[0].block;
4848 return fixup_symbol_section (candidates[0].sym, NULL);
4851 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4852 scope and in global scopes, or NULL if none. NAME is folded and
4853 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4854 choosing the first symbol if there are multiple choices.
4855 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4856 table in which the symbol was found (in both cases, these
4857 assignments occur only if the pointers are non-null). */
4859 ada_lookup_symbol (const char *name, const struct block *block0,
4860 domain_enum namespace, int *is_a_field_of_this)
4862 if (is_a_field_of_this != NULL)
4863 *is_a_field_of_this = 0;
4866 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)),
4867 block0, namespace, NULL);
4870 static struct symbol *
4871 ada_lookup_symbol_nonlocal (const char *name,
4872 const char *linkage_name,
4873 const struct block *block,
4874 const domain_enum domain)
4876 if (linkage_name == NULL)
4877 linkage_name = name;
4878 return ada_lookup_symbol (linkage_name, block_static_block (block), domain,
4883 /* True iff STR is a possible encoded suffix of a normal Ada name
4884 that is to be ignored for matching purposes. Suffixes of parallel
4885 names (e.g., XVE) are not included here. Currently, the possible suffixes
4886 are given by any of the regular expressions:
4888 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
4889 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4890 _E[0-9]+[bs]$ [protected object entry suffixes]
4891 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4893 Also, any leading "__[0-9]+" sequence is skipped before the suffix
4894 match is performed. This sequence is used to differentiate homonyms,
4895 is an optional part of a valid name suffix. */
4898 is_name_suffix (const char *str)
4901 const char *matching;
4902 const int len = strlen (str);
4904 /* Skip optional leading __[0-9]+. */
4906 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
4909 while (isdigit (str[0]))
4915 if (str[0] == '.' || str[0] == '$')
4918 while (isdigit (matching[0]))
4920 if (matching[0] == '\0')
4926 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
4929 while (isdigit (matching[0]))
4931 if (matching[0] == '\0')
4936 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4937 with a N at the end. Unfortunately, the compiler uses the same
4938 convention for other internal types it creates. So treating
4939 all entity names that end with an "N" as a name suffix causes
4940 some regressions. For instance, consider the case of an enumerated
4941 type. To support the 'Image attribute, it creates an array whose
4943 Having a single character like this as a suffix carrying some
4944 information is a bit risky. Perhaps we should change the encoding
4945 to be something like "_N" instead. In the meantime, do not do
4946 the following check. */
4947 /* Protected Object Subprograms */
4948 if (len == 1 && str [0] == 'N')
4953 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
4956 while (isdigit (matching[0]))
4958 if ((matching[0] == 'b' || matching[0] == 's')
4959 && matching [1] == '\0')
4963 /* ??? We should not modify STR directly, as we are doing below. This
4964 is fine in this case, but may become problematic later if we find
4965 that this alternative did not work, and want to try matching
4966 another one from the begining of STR. Since we modified it, we
4967 won't be able to find the begining of the string anymore! */
4971 while (str[0] != '_' && str[0] != '\0')
4973 if (str[0] != 'n' && str[0] != 'b')
4979 if (str[0] == '\000')
4984 if (str[1] != '_' || str[2] == '\000')
4988 if (strcmp (str + 3, "JM") == 0)
4990 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4991 the LJM suffix in favor of the JM one. But we will
4992 still accept LJM as a valid suffix for a reasonable
4993 amount of time, just to allow ourselves to debug programs
4994 compiled using an older version of GNAT. */
4995 if (strcmp (str + 3, "LJM") == 0)
4999 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5000 || str[4] == 'U' || str[4] == 'P')
5002 if (str[4] == 'R' && str[5] != 'T')
5006 if (!isdigit (str[2]))
5008 for (k = 3; str[k] != '\0'; k += 1)
5009 if (!isdigit (str[k]) && str[k] != '_')
5013 if (str[0] == '$' && isdigit (str[1]))
5015 for (k = 2; str[k] != '\0'; k += 1)
5016 if (!isdigit (str[k]) && str[k] != '_')
5023 /* Return non-zero if the string starting at NAME and ending before
5024 NAME_END contains no capital letters. */
5027 is_valid_name_for_wild_match (const char *name0)
5029 const char *decoded_name = ada_decode (name0);
5032 /* If the decoded name starts with an angle bracket, it means that
5033 NAME0 does not follow the GNAT encoding format. It should then
5034 not be allowed as a possible wild match. */
5035 if (decoded_name[0] == '<')
5038 for (i=0; decoded_name[i] != '\0'; i++)
5039 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5045 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
5046 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
5047 informational suffixes of NAME (i.e., for which is_name_suffix is
5051 wild_match (const char *patn0, int patn_len, const char *name0)
5058 match = strstr (start, patn0);
5063 || (match > name0 + 1 && match[-1] == '_' && match[-2] == '_')
5064 || (match == name0 + 5 && strncmp ("_ada_", name0, 5) == 0))
5065 && is_name_suffix (match + patn_len))
5066 return (match == name0 || is_valid_name_for_wild_match (name0));
5072 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5073 vector *defn_symbols, updating the list of symbols in OBSTACKP
5074 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5075 OBJFILE is the section containing BLOCK.
5076 SYMTAB is recorded with each symbol added. */
5079 ada_add_block_symbols (struct obstack *obstackp,
5080 struct block *block, const char *name,
5081 domain_enum domain, struct objfile *objfile,
5084 struct dict_iterator iter;
5085 int name_len = strlen (name);
5086 /* A matching argument symbol, if any. */
5087 struct symbol *arg_sym;
5088 /* Set true when we find a matching non-argument symbol. */
5097 ALL_BLOCK_SYMBOLS (block, iter, sym)
5099 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5100 SYMBOL_DOMAIN (sym), domain)
5101 && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (sym)))
5103 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5105 else if (SYMBOL_IS_ARGUMENT (sym))
5110 add_defn_to_vec (obstackp,
5111 fixup_symbol_section (sym, objfile),
5119 ALL_BLOCK_SYMBOLS (block, iter, sym)
5121 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5122 SYMBOL_DOMAIN (sym), domain))
5124 int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym), name_len);
5126 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len))
5128 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5130 if (SYMBOL_IS_ARGUMENT (sym))
5135 add_defn_to_vec (obstackp,
5136 fixup_symbol_section (sym, objfile),
5145 if (!found_sym && arg_sym != NULL)
5147 add_defn_to_vec (obstackp,
5148 fixup_symbol_section (arg_sym, objfile),
5157 ALL_BLOCK_SYMBOLS (block, iter, sym)
5159 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
5160 SYMBOL_DOMAIN (sym), domain))
5164 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5167 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5169 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5174 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5176 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
5178 if (SYMBOL_IS_ARGUMENT (sym))
5183 add_defn_to_vec (obstackp,
5184 fixup_symbol_section (sym, objfile),
5192 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5193 They aren't parameters, right? */
5194 if (!found_sym && arg_sym != NULL)
5196 add_defn_to_vec (obstackp,
5197 fixup_symbol_section (arg_sym, objfile),
5204 /* Symbol Completion */
5206 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5207 name in a form that's appropriate for the completion. The result
5208 does not need to be deallocated, but is only good until the next call.
5210 TEXT_LEN is equal to the length of TEXT.
5211 Perform a wild match if WILD_MATCH is set.
5212 ENCODED should be set if TEXT represents the start of a symbol name
5213 in its encoded form. */
5216 symbol_completion_match (const char *sym_name,
5217 const char *text, int text_len,
5218 int wild_match, int encoded)
5221 const int verbatim_match = (text[0] == '<');
5226 /* Strip the leading angle bracket. */
5231 /* First, test against the fully qualified name of the symbol. */
5233 if (strncmp (sym_name, text, text_len) == 0)
5236 if (match && !encoded)
5238 /* One needed check before declaring a positive match is to verify
5239 that iff we are doing a verbatim match, the decoded version
5240 of the symbol name starts with '<'. Otherwise, this symbol name
5241 is not a suitable completion. */
5242 const char *sym_name_copy = sym_name;
5243 int has_angle_bracket;
5245 sym_name = ada_decode (sym_name);
5246 has_angle_bracket = (sym_name[0] == '<');
5247 match = (has_angle_bracket == verbatim_match);
5248 sym_name = sym_name_copy;
5251 if (match && !verbatim_match)
5253 /* When doing non-verbatim match, another check that needs to
5254 be done is to verify that the potentially matching symbol name
5255 does not include capital letters, because the ada-mode would
5256 not be able to understand these symbol names without the
5257 angle bracket notation. */
5260 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5265 /* Second: Try wild matching... */
5267 if (!match && wild_match)
5269 /* Since we are doing wild matching, this means that TEXT
5270 may represent an unqualified symbol name. We therefore must
5271 also compare TEXT against the unqualified name of the symbol. */
5272 sym_name = ada_unqualified_name (ada_decode (sym_name));
5274 if (strncmp (sym_name, text, text_len) == 0)
5278 /* Finally: If we found a mach, prepare the result to return. */
5284 sym_name = add_angle_brackets (sym_name);
5287 sym_name = ada_decode (sym_name);
5292 typedef char *char_ptr;
5293 DEF_VEC_P (char_ptr);
5295 /* A companion function to ada_make_symbol_completion_list().
5296 Check if SYM_NAME represents a symbol which name would be suitable
5297 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5298 it is appended at the end of the given string vector SV.
5300 ORIG_TEXT is the string original string from the user command
5301 that needs to be completed. WORD is the entire command on which
5302 completion should be performed. These two parameters are used to
5303 determine which part of the symbol name should be added to the
5305 if WILD_MATCH is set, then wild matching is performed.
5306 ENCODED should be set if TEXT represents a symbol name in its
5307 encoded formed (in which case the completion should also be
5311 symbol_completion_add (VEC(char_ptr) **sv,
5312 const char *sym_name,
5313 const char *text, int text_len,
5314 const char *orig_text, const char *word,
5315 int wild_match, int encoded)
5317 const char *match = symbol_completion_match (sym_name, text, text_len,
5318 wild_match, encoded);
5324 /* We found a match, so add the appropriate completion to the given
5327 if (word == orig_text)
5329 completion = xmalloc (strlen (match) + 5);
5330 strcpy (completion, match);
5332 else if (word > orig_text)
5334 /* Return some portion of sym_name. */
5335 completion = xmalloc (strlen (match) + 5);
5336 strcpy (completion, match + (word - orig_text));
5340 /* Return some of ORIG_TEXT plus sym_name. */
5341 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
5342 strncpy (completion, word, orig_text - word);
5343 completion[orig_text - word] = '\0';
5344 strcat (completion, match);
5347 VEC_safe_push (char_ptr, *sv, completion);
5350 /* Return a list of possible symbol names completing TEXT0. The list
5351 is NULL terminated. WORD is the entire command on which completion
5355 ada_make_symbol_completion_list (char *text0, char *word)
5361 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
5364 struct partial_symtab *ps;
5365 struct minimal_symbol *msymbol;
5366 struct objfile *objfile;
5367 struct block *b, *surrounding_static_block = 0;
5369 struct dict_iterator iter;
5371 if (text0[0] == '<')
5373 text = xstrdup (text0);
5374 make_cleanup (xfree, text);
5375 text_len = strlen (text);
5381 text = xstrdup (ada_encode (text0));
5382 make_cleanup (xfree, text);
5383 text_len = strlen (text);
5384 for (i = 0; i < text_len; i++)
5385 text[i] = tolower (text[i]);
5387 encoded = (strstr (text0, "__") != NULL);
5388 /* If the name contains a ".", then the user is entering a fully
5389 qualified entity name, and the match must not be done in wild
5390 mode. Similarly, if the user wants to complete what looks like
5391 an encoded name, the match must not be done in wild mode. */
5392 wild_match = (strchr (text0, '.') == NULL && !encoded);
5395 /* First, look at the partial symtab symbols. */
5396 ALL_PSYMTABS (objfile, ps)
5398 struct partial_symbol **psym;
5400 /* If the psymtab's been read in we'll get it when we search
5401 through the blockvector. */
5405 for (psym = objfile->global_psymbols.list + ps->globals_offset;
5406 psym < (objfile->global_psymbols.list + ps->globals_offset
5407 + ps->n_global_syms); psym++)
5410 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (*psym),
5411 text, text_len, text0, word,
5412 wild_match, encoded);
5415 for (psym = objfile->static_psymbols.list + ps->statics_offset;
5416 psym < (objfile->static_psymbols.list + ps->statics_offset
5417 + ps->n_static_syms); psym++)
5420 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (*psym),
5421 text, text_len, text0, word,
5422 wild_match, encoded);
5426 /* At this point scan through the misc symbol vectors and add each
5427 symbol you find to the list. Eventually we want to ignore
5428 anything that isn't a text symbol (everything else will be
5429 handled by the psymtab code above). */
5431 ALL_MSYMBOLS (objfile, msymbol)
5434 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (msymbol),
5435 text, text_len, text0, word, wild_match, encoded);
5438 /* Search upwards from currently selected frame (so that we can
5439 complete on local vars. */
5441 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
5443 if (!BLOCK_SUPERBLOCK (b))
5444 surrounding_static_block = b; /* For elmin of dups */
5446 ALL_BLOCK_SYMBOLS (b, iter, sym)
5448 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5449 text, text_len, text0, word,
5450 wild_match, encoded);
5454 /* Go through the symtabs and check the externs and statics for
5455 symbols which match. */
5457 ALL_SYMTABS (objfile, s)
5460 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5461 ALL_BLOCK_SYMBOLS (b, iter, sym)
5463 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5464 text, text_len, text0, word,
5465 wild_match, encoded);
5469 ALL_SYMTABS (objfile, s)
5472 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
5473 /* Don't do this block twice. */
5474 if (b == surrounding_static_block)
5476 ALL_BLOCK_SYMBOLS (b, iter, sym)
5478 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
5479 text, text_len, text0, word,
5480 wild_match, encoded);
5484 /* Append the closing NULL entry. */
5485 VEC_safe_push (char_ptr, completions, NULL);
5487 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5488 return the copy. It's unfortunate that we have to make a copy
5489 of an array that we're about to destroy, but there is nothing much
5490 we can do about it. Fortunately, it's typically not a very large
5493 const size_t completions_size =
5494 VEC_length (char_ptr, completions) * sizeof (char *);
5495 char **result = malloc (completions_size);
5497 memcpy (result, VEC_address (char_ptr, completions), completions_size);
5499 VEC_free (char_ptr, completions);
5506 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5507 for tagged types. */
5510 ada_is_dispatch_table_ptr_type (struct type *type)
5514 if (TYPE_CODE (type) != TYPE_CODE_PTR)
5517 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
5521 return (strcmp (name, "ada__tags__dispatch_table") == 0);
5524 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5525 to be invisible to users. */
5528 ada_is_ignored_field (struct type *type, int field_num)
5530 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5533 /* Check the name of that field. */
5535 const char *name = TYPE_FIELD_NAME (type, field_num);
5537 /* Anonymous field names should not be printed.
5538 brobecker/2007-02-20: I don't think this can actually happen
5539 but we don't want to print the value of annonymous fields anyway. */
5543 /* A field named "_parent" is internally generated by GNAT for
5544 tagged types, and should not be printed either. */
5545 if (name[0] == '_' && strncmp (name, "_parent", 7) != 0)
5549 /* If this is the dispatch table of a tagged type, then ignore. */
5550 if (ada_is_tagged_type (type, 1)
5551 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num)))
5554 /* Not a special field, so it should not be ignored. */
5558 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5559 pointer or reference type whose ultimate target has a tag field. */
5562 ada_is_tagged_type (struct type *type, int refok)
5564 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
5567 /* True iff TYPE represents the type of X'Tag */
5570 ada_is_tag_type (struct type *type)
5572 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
5576 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5577 return (name != NULL
5578 && strcmp (name, "ada__tags__dispatch_table") == 0);
5582 /* The type of the tag on VAL. */
5585 ada_tag_type (struct value *val)
5587 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
5590 /* The value of the tag on VAL. */
5593 ada_value_tag (struct value *val)
5595 return ada_value_struct_elt (val, "_tag", 0);
5598 /* The value of the tag on the object of type TYPE whose contents are
5599 saved at VALADDR, if it is non-null, or is at memory address
5602 static struct value *
5603 value_tag_from_contents_and_address (struct type *type,
5604 const gdb_byte *valaddr,
5607 int tag_byte_offset, dummy1, dummy2;
5608 struct type *tag_type;
5609 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
5612 const gdb_byte *valaddr1 = ((valaddr == NULL)
5614 : valaddr + tag_byte_offset);
5615 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
5617 return value_from_contents_and_address (tag_type, valaddr1, address1);
5622 static struct type *
5623 type_from_tag (struct value *tag)
5625 const char *type_name = ada_tag_name (tag);
5626 if (type_name != NULL)
5627 return ada_find_any_type (ada_encode (type_name));
5638 static int ada_tag_name_1 (void *);
5639 static int ada_tag_name_2 (struct tag_args *);
5641 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5642 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5643 The value stored in ARGS->name is valid until the next call to
5647 ada_tag_name_1 (void *args0)
5649 struct tag_args *args = (struct tag_args *) args0;
5650 static char name[1024];
5654 val = ada_value_struct_elt (args->tag, "tsd", 1);
5656 return ada_tag_name_2 (args);
5657 val = ada_value_struct_elt (val, "expanded_name", 1);
5660 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5661 for (p = name; *p != '\0'; p += 1)
5668 /* Utility function for ada_tag_name_1 that tries the second
5669 representation for the dispatch table (in which there is no
5670 explicit 'tsd' field in the referent of the tag pointer, and instead
5671 the tsd pointer is stored just before the dispatch table. */
5674 ada_tag_name_2 (struct tag_args *args)
5676 struct type *info_type;
5677 static char name[1024];
5679 struct value *val, *valp;
5682 info_type = ada_find_any_type ("ada__tags__type_specific_data");
5683 if (info_type == NULL)
5685 info_type = lookup_pointer_type (lookup_pointer_type (info_type));
5686 valp = value_cast (info_type, args->tag);
5689 val = value_ind (value_ptradd (valp,
5690 value_from_longest (builtin_type_int8, -1)));
5693 val = ada_value_struct_elt (val, "expanded_name", 1);
5696 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5697 for (p = name; *p != '\0'; p += 1)
5704 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5708 ada_tag_name (struct value *tag)
5710 struct tag_args args;
5711 if (!ada_is_tag_type (value_type (tag)))
5715 catch_errors (ada_tag_name_1, &args, NULL, RETURN_MASK_ALL);
5719 /* The parent type of TYPE, or NULL if none. */
5722 ada_parent_type (struct type *type)
5726 type = ada_check_typedef (type);
5728 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5731 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5732 if (ada_is_parent_field (type, i))
5734 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
5736 /* If the _parent field is a pointer, then dereference it. */
5737 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
5738 parent_type = TYPE_TARGET_TYPE (parent_type);
5739 /* If there is a parallel XVS type, get the actual base type. */
5740 parent_type = ada_get_base_type (parent_type);
5742 return ada_check_typedef (parent_type);
5748 /* True iff field number FIELD_NUM of structure type TYPE contains the
5749 parent-type (inherited) fields of a derived type. Assumes TYPE is
5750 a structure type with at least FIELD_NUM+1 fields. */
5753 ada_is_parent_field (struct type *type, int field_num)
5755 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5756 return (name != NULL
5757 && (strncmp (name, "PARENT", 6) == 0
5758 || strncmp (name, "_parent", 7) == 0));
5761 /* True iff field number FIELD_NUM of structure type TYPE is a
5762 transparent wrapper field (which should be silently traversed when doing
5763 field selection and flattened when printing). Assumes TYPE is a
5764 structure type with at least FIELD_NUM+1 fields. Such fields are always
5768 ada_is_wrapper_field (struct type *type, int field_num)
5770 const char *name = TYPE_FIELD_NAME (type, field_num);
5771 return (name != NULL
5772 && (strncmp (name, "PARENT", 6) == 0
5773 || strcmp (name, "REP") == 0
5774 || strncmp (name, "_parent", 7) == 0
5775 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
5778 /* True iff field number FIELD_NUM of structure or union type TYPE
5779 is a variant wrapper. Assumes TYPE is a structure type with at least
5780 FIELD_NUM+1 fields. */
5783 ada_is_variant_part (struct type *type, int field_num)
5785 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5786 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
5787 || (is_dynamic_field (type, field_num)
5788 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
5789 == TYPE_CODE_UNION)));
5792 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5793 whose discriminants are contained in the record type OUTER_TYPE,
5794 returns the type of the controlling discriminant for the variant. */
5797 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
5799 char *name = ada_variant_discrim_name (var_type);
5801 ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
5803 return builtin_type_int32;
5808 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5809 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5810 represents a 'when others' clause; otherwise 0. */
5813 ada_is_others_clause (struct type *type, int field_num)
5815 const char *name = TYPE_FIELD_NAME (type, field_num);
5816 return (name != NULL && name[0] == 'O');
5819 /* Assuming that TYPE0 is the type of the variant part of a record,
5820 returns the name of the discriminant controlling the variant.
5821 The value is valid until the next call to ada_variant_discrim_name. */
5824 ada_variant_discrim_name (struct type *type0)
5826 static char *result = NULL;
5827 static size_t result_len = 0;
5830 const char *discrim_end;
5831 const char *discrim_start;
5833 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
5834 type = TYPE_TARGET_TYPE (type0);
5838 name = ada_type_name (type);
5840 if (name == NULL || name[0] == '\000')
5843 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
5846 if (strncmp (discrim_end, "___XVN", 6) == 0)
5849 if (discrim_end == name)
5852 for (discrim_start = discrim_end; discrim_start != name + 3;
5855 if (discrim_start == name + 1)
5857 if ((discrim_start > name + 3
5858 && strncmp (discrim_start - 3, "___", 3) == 0)
5859 || discrim_start[-1] == '.')
5863 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
5864 strncpy (result, discrim_start, discrim_end - discrim_start);
5865 result[discrim_end - discrim_start] = '\0';
5869 /* Scan STR for a subtype-encoded number, beginning at position K.
5870 Put the position of the character just past the number scanned in
5871 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5872 Return 1 if there was a valid number at the given position, and 0
5873 otherwise. A "subtype-encoded" number consists of the absolute value
5874 in decimal, followed by the letter 'm' to indicate a negative number.
5875 Assumes 0m does not occur. */
5878 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
5882 if (!isdigit (str[k]))
5885 /* Do it the hard way so as not to make any assumption about
5886 the relationship of unsigned long (%lu scan format code) and
5889 while (isdigit (str[k]))
5891 RU = RU * 10 + (str[k] - '0');
5898 *R = (-(LONGEST) (RU - 1)) - 1;
5904 /* NOTE on the above: Technically, C does not say what the results of
5905 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5906 number representable as a LONGEST (although either would probably work
5907 in most implementations). When RU>0, the locution in the then branch
5908 above is always equivalent to the negative of RU. */
5915 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5916 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5917 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5920 ada_in_variant (LONGEST val, struct type *type, int field_num)
5922 const char *name = TYPE_FIELD_NAME (type, field_num);
5935 if (!ada_scan_number (name, p + 1, &W, &p))
5944 if (!ada_scan_number (name, p + 1, &L, &p)
5945 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
5947 if (val >= L && val <= U)
5959 /* FIXME: Lots of redundancy below. Try to consolidate. */
5961 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5962 ARG_TYPE, extract and return the value of one of its (non-static)
5963 fields. FIELDNO says which field. Differs from value_primitive_field
5964 only in that it can handle packed values of arbitrary type. */
5966 static struct value *
5967 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
5968 struct type *arg_type)
5972 arg_type = ada_check_typedef (arg_type);
5973 type = TYPE_FIELD_TYPE (arg_type, fieldno);
5975 /* Handle packed fields. */
5977 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
5979 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
5980 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
5982 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
5983 offset + bit_pos / 8,
5984 bit_pos % 8, bit_size, type);
5987 return value_primitive_field (arg1, offset, fieldno, arg_type);
5990 /* Find field with name NAME in object of type TYPE. If found,
5991 set the following for each argument that is non-null:
5992 - *FIELD_TYPE_P to the field's type;
5993 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
5994 an object of that type;
5995 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
5996 - *BIT_SIZE_P to its size in bits if the field is packed, and
5998 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
5999 fields up to but not including the desired field, or by the total
6000 number of fields if not found. A NULL value of NAME never
6001 matches; the function just counts visible fields in this case.
6003 Returns 1 if found, 0 otherwise. */
6006 find_struct_field (char *name, struct type *type, int offset,
6007 struct type **field_type_p,
6008 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
6013 type = ada_check_typedef (type);
6015 if (field_type_p != NULL)
6016 *field_type_p = NULL;
6017 if (byte_offset_p != NULL)
6019 if (bit_offset_p != NULL)
6021 if (bit_size_p != NULL)
6024 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6026 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6027 int fld_offset = offset + bit_pos / 8;
6028 char *t_field_name = TYPE_FIELD_NAME (type, i);
6030 if (t_field_name == NULL)
6033 else if (name != NULL && field_name_match (t_field_name, name))
6035 int bit_size = TYPE_FIELD_BITSIZE (type, i);
6036 if (field_type_p != NULL)
6037 *field_type_p = TYPE_FIELD_TYPE (type, i);
6038 if (byte_offset_p != NULL)
6039 *byte_offset_p = fld_offset;
6040 if (bit_offset_p != NULL)
6041 *bit_offset_p = bit_pos % 8;
6042 if (bit_size_p != NULL)
6043 *bit_size_p = bit_size;
6046 else if (ada_is_wrapper_field (type, i))
6048 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6049 field_type_p, byte_offset_p, bit_offset_p,
6050 bit_size_p, index_p))
6053 else if (ada_is_variant_part (type, i))
6055 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6058 struct type *field_type
6059 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6061 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
6063 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6065 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6066 field_type_p, byte_offset_p,
6067 bit_offset_p, bit_size_p, index_p))
6071 else if (index_p != NULL)
6077 /* Number of user-visible fields in record type TYPE. */
6080 num_visible_fields (struct type *type)
6084 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
6088 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6089 and search in it assuming it has (class) type TYPE.
6090 If found, return value, else return NULL.
6092 Searches recursively through wrapper fields (e.g., '_parent'). */
6094 static struct value *
6095 ada_search_struct_field (char *name, struct value *arg, int offset,
6099 type = ada_check_typedef (type);
6101 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6103 char *t_field_name = TYPE_FIELD_NAME (type, i);
6105 if (t_field_name == NULL)
6108 else if (field_name_match (t_field_name, name))
6109 return ada_value_primitive_field (arg, offset, i, type);
6111 else if (ada_is_wrapper_field (type, i))
6113 struct value *v = /* Do not let indent join lines here. */
6114 ada_search_struct_field (name, arg,
6115 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6116 TYPE_FIELD_TYPE (type, i));
6121 else if (ada_is_variant_part (type, i))
6123 /* PNH: Do we ever get here? See find_struct_field. */
6125 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6126 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
6128 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
6130 struct value *v = ada_search_struct_field /* Force line break. */
6132 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
6133 TYPE_FIELD_TYPE (field_type, j));
6142 static struct value *ada_index_struct_field_1 (int *, struct value *,
6143 int, struct type *);
6146 /* Return field #INDEX in ARG, where the index is that returned by
6147 * find_struct_field through its INDEX_P argument. Adjust the address
6148 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6149 * If found, return value, else return NULL. */
6151 static struct value *
6152 ada_index_struct_field (int index, struct value *arg, int offset,
6155 return ada_index_struct_field_1 (&index, arg, offset, type);
6159 /* Auxiliary function for ada_index_struct_field. Like
6160 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6163 static struct value *
6164 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
6168 type = ada_check_typedef (type);
6170 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6172 if (TYPE_FIELD_NAME (type, i) == NULL)
6174 else if (ada_is_wrapper_field (type, i))
6176 struct value *v = /* Do not let indent join lines here. */
6177 ada_index_struct_field_1 (index_p, arg,
6178 offset + TYPE_FIELD_BITPOS (type, i) / 8,
6179 TYPE_FIELD_TYPE (type, i));
6184 else if (ada_is_variant_part (type, i))
6186 /* PNH: Do we ever get here? See ada_search_struct_field,
6187 find_struct_field. */
6188 error (_("Cannot assign this kind of variant record"));
6190 else if (*index_p == 0)
6191 return ada_value_primitive_field (arg, offset, i, type);
6198 /* Given ARG, a value of type (pointer or reference to a)*
6199 structure/union, extract the component named NAME from the ultimate
6200 target structure/union and return it as a value with its
6201 appropriate type. If ARG is a pointer or reference and the field
6202 is not packed, returns a reference to the field, otherwise the
6203 value of the field (an lvalue if ARG is an lvalue).
6205 The routine searches for NAME among all members of the structure itself
6206 and (recursively) among all members of any wrapper members
6209 If NO_ERR, then simply return NULL in case of error, rather than
6213 ada_value_struct_elt (struct value *arg, char *name, int no_err)
6215 struct type *t, *t1;
6219 t1 = t = ada_check_typedef (value_type (arg));
6220 if (TYPE_CODE (t) == TYPE_CODE_REF)
6222 t1 = TYPE_TARGET_TYPE (t);
6225 t1 = ada_check_typedef (t1);
6226 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
6228 arg = coerce_ref (arg);
6233 while (TYPE_CODE (t) == TYPE_CODE_PTR)
6235 t1 = TYPE_TARGET_TYPE (t);
6238 t1 = ada_check_typedef (t1);
6239 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
6241 arg = value_ind (arg);
6248 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
6252 v = ada_search_struct_field (name, arg, 0, t);
6255 int bit_offset, bit_size, byte_offset;
6256 struct type *field_type;
6259 if (TYPE_CODE (t) == TYPE_CODE_PTR)
6260 address = value_as_address (arg);
6262 address = unpack_pointer (t, value_contents (arg));
6264 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
6265 if (find_struct_field (name, t1, 0,
6266 &field_type, &byte_offset, &bit_offset,
6271 if (TYPE_CODE (t) == TYPE_CODE_REF)
6272 arg = ada_coerce_ref (arg);
6274 arg = ada_value_ind (arg);
6275 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
6276 bit_offset, bit_size,
6280 v = value_from_pointer (lookup_reference_type (field_type),
6281 address + byte_offset);
6285 if (v != NULL || no_err)
6288 error (_("There is no member named %s."), name);
6294 error (_("Attempt to extract a component of a value that is not a record."));
6297 /* Given a type TYPE, look up the type of the component of type named NAME.
6298 If DISPP is non-null, add its byte displacement from the beginning of a
6299 structure (pointed to by a value) of type TYPE to *DISPP (does not
6300 work for packed fields).
6302 Matches any field whose name has NAME as a prefix, possibly
6305 TYPE can be either a struct or union. If REFOK, TYPE may also
6306 be a (pointer or reference)+ to a struct or union, and the
6307 ultimate target type will be searched.
6309 Looks recursively into variant clauses and parent types.
6311 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6312 TYPE is not a type of the right kind. */
6314 static struct type *
6315 ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
6316 int noerr, int *dispp)
6323 if (refok && type != NULL)
6326 type = ada_check_typedef (type);
6327 if (TYPE_CODE (type) != TYPE_CODE_PTR
6328 && TYPE_CODE (type) != TYPE_CODE_REF)
6330 type = TYPE_TARGET_TYPE (type);
6334 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
6335 && TYPE_CODE (type) != TYPE_CODE_UNION))
6341 target_terminal_ours ();
6342 gdb_flush (gdb_stdout);
6344 error (_("Type (null) is not a structure or union type"));
6347 /* XXX: type_sprint */
6348 fprintf_unfiltered (gdb_stderr, _("Type "));
6349 type_print (type, "", gdb_stderr, -1);
6350 error (_(" is not a structure or union type"));
6355 type = to_static_fixed_type (type);
6357 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6359 char *t_field_name = TYPE_FIELD_NAME (type, i);
6363 if (t_field_name == NULL)
6366 else if (field_name_match (t_field_name, name))
6369 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
6370 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6373 else if (ada_is_wrapper_field (type, i))
6376 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
6381 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6386 else if (ada_is_variant_part (type, i))
6389 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6391 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
6393 /* FIXME pnh 2008/01/26: We check for a field that is
6394 NOT wrapped in a struct, since the compiler sometimes
6395 generates these for unchecked variant types. Revisit
6396 if the compiler changes this practice. */
6397 char *v_field_name = TYPE_FIELD_NAME (field_type, j);
6399 if (v_field_name != NULL
6400 && field_name_match (v_field_name, name))
6401 t = ada_check_typedef (TYPE_FIELD_TYPE (field_type, j));
6403 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
6409 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6420 target_terminal_ours ();
6421 gdb_flush (gdb_stdout);
6424 /* XXX: type_sprint */
6425 fprintf_unfiltered (gdb_stderr, _("Type "));
6426 type_print (type, "", gdb_stderr, -1);
6427 error (_(" has no component named <null>"));
6431 /* XXX: type_sprint */
6432 fprintf_unfiltered (gdb_stderr, _("Type "));
6433 type_print (type, "", gdb_stderr, -1);
6434 error (_(" has no component named %s"), name);
6441 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6442 within a value of type OUTER_TYPE, return true iff VAR_TYPE
6443 represents an unchecked union (that is, the variant part of a
6444 record that is named in an Unchecked_Union pragma). */
6447 is_unchecked_variant (struct type *var_type, struct type *outer_type)
6449 char *discrim_name = ada_variant_discrim_name (var_type);
6450 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
6455 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6456 within a value of type OUTER_TYPE that is stored in GDB at
6457 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6458 numbering from 0) is applicable. Returns -1 if none are. */
6461 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
6462 const gdb_byte *outer_valaddr)
6466 char *discrim_name = ada_variant_discrim_name (var_type);
6467 struct value *outer;
6468 struct value *discrim;
6469 LONGEST discrim_val;
6471 outer = value_from_contents_and_address (outer_type, outer_valaddr, 0);
6472 discrim = ada_value_struct_elt (outer, discrim_name, 1);
6473 if (discrim == NULL)
6475 discrim_val = value_as_long (discrim);
6478 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
6480 if (ada_is_others_clause (var_type, i))
6482 else if (ada_in_variant (discrim_val, var_type, i))
6486 return others_clause;
6491 /* Dynamic-Sized Records */
6493 /* Strategy: The type ostensibly attached to a value with dynamic size
6494 (i.e., a size that is not statically recorded in the debugging
6495 data) does not accurately reflect the size or layout of the value.
6496 Our strategy is to convert these values to values with accurate,
6497 conventional types that are constructed on the fly. */
6499 /* There is a subtle and tricky problem here. In general, we cannot
6500 determine the size of dynamic records without its data. However,
6501 the 'struct value' data structure, which GDB uses to represent
6502 quantities in the inferior process (the target), requires the size
6503 of the type at the time of its allocation in order to reserve space
6504 for GDB's internal copy of the data. That's why the
6505 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6506 rather than struct value*s.
6508 However, GDB's internal history variables ($1, $2, etc.) are
6509 struct value*s containing internal copies of the data that are not, in
6510 general, the same as the data at their corresponding addresses in
6511 the target. Fortunately, the types we give to these values are all
6512 conventional, fixed-size types (as per the strategy described
6513 above), so that we don't usually have to perform the
6514 'to_fixed_xxx_type' conversions to look at their values.
6515 Unfortunately, there is one exception: if one of the internal
6516 history variables is an array whose elements are unconstrained
6517 records, then we will need to create distinct fixed types for each
6518 element selected. */
6520 /* The upshot of all of this is that many routines take a (type, host
6521 address, target address) triple as arguments to represent a value.
6522 The host address, if non-null, is supposed to contain an internal
6523 copy of the relevant data; otherwise, the program is to consult the
6524 target at the target address. */
6526 /* Assuming that VAL0 represents a pointer value, the result of
6527 dereferencing it. Differs from value_ind in its treatment of
6528 dynamic-sized types. */
6531 ada_value_ind (struct value *val0)
6533 struct value *val = unwrap_value (value_ind (val0));
6534 return ada_to_fixed_value (val);
6537 /* The value resulting from dereferencing any "reference to"
6538 qualifiers on VAL0. */
6540 static struct value *
6541 ada_coerce_ref (struct value *val0)
6543 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
6545 struct value *val = val0;
6546 val = coerce_ref (val);
6547 val = unwrap_value (val);
6548 return ada_to_fixed_value (val);
6554 /* Return OFF rounded upward if necessary to a multiple of
6555 ALIGNMENT (a power of 2). */
6558 align_value (unsigned int off, unsigned int alignment)
6560 return (off + alignment - 1) & ~(alignment - 1);
6563 /* Return the bit alignment required for field #F of template type TYPE. */
6566 field_alignment (struct type *type, int f)
6568 const char *name = TYPE_FIELD_NAME (type, f);
6572 /* The field name should never be null, unless the debugging information
6573 is somehow malformed. In this case, we assume the field does not
6574 require any alignment. */
6578 len = strlen (name);
6580 if (!isdigit (name[len - 1]))
6583 if (isdigit (name[len - 2]))
6584 align_offset = len - 2;
6586 align_offset = len - 1;
6588 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
6589 return TARGET_CHAR_BIT;
6591 return atoi (name + align_offset) * TARGET_CHAR_BIT;
6594 /* Find a symbol named NAME. Ignores ambiguity. */
6597 ada_find_any_symbol (const char *name)
6601 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
6602 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
6605 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
6609 /* Find a type named NAME. Ignores ambiguity. */
6612 ada_find_any_type (const char *name)
6614 struct symbol *sym = ada_find_any_symbol (name);
6617 return SYMBOL_TYPE (sym);
6622 /* Given NAME and an associated BLOCK, search all symbols for
6623 NAME suffixed with "___XR", which is the ``renaming'' symbol
6624 associated to NAME. Return this symbol if found, return
6628 ada_find_renaming_symbol (const char *name, struct block *block)
6632 sym = find_old_style_renaming_symbol (name, block);
6637 /* Not right yet. FIXME pnh 7/20/2007. */
6638 sym = ada_find_any_symbol (name);
6639 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
6645 static struct symbol *
6646 find_old_style_renaming_symbol (const char *name, struct block *block)
6648 const struct symbol *function_sym = block_linkage_function (block);
6651 if (function_sym != NULL)
6653 /* If the symbol is defined inside a function, NAME is not fully
6654 qualified. This means we need to prepend the function name
6655 as well as adding the ``___XR'' suffix to build the name of
6656 the associated renaming symbol. */
6657 char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
6658 /* Function names sometimes contain suffixes used
6659 for instance to qualify nested subprograms. When building
6660 the XR type name, we need to make sure that this suffix is
6661 not included. So do not include any suffix in the function
6662 name length below. */
6663 const int function_name_len = ada_name_prefix_len (function_name);
6664 const int rename_len = function_name_len + 2 /* "__" */
6665 + strlen (name) + 6 /* "___XR\0" */ ;
6667 /* Strip the suffix if necessary. */
6668 function_name[function_name_len] = '\0';
6670 /* Library-level functions are a special case, as GNAT adds
6671 a ``_ada_'' prefix to the function name to avoid namespace
6672 pollution. However, the renaming symbols themselves do not
6673 have this prefix, so we need to skip this prefix if present. */
6674 if (function_name_len > 5 /* "_ada_" */
6675 && strstr (function_name, "_ada_") == function_name)
6676 function_name = function_name + 5;
6678 rename = (char *) alloca (rename_len * sizeof (char));
6679 sprintf (rename, "%s__%s___XR", function_name, name);
6683 const int rename_len = strlen (name) + 6;
6684 rename = (char *) alloca (rename_len * sizeof (char));
6685 sprintf (rename, "%s___XR", name);
6688 return ada_find_any_symbol (rename);
6691 /* Because of GNAT encoding conventions, several GDB symbols may match a
6692 given type name. If the type denoted by TYPE0 is to be preferred to
6693 that of TYPE1 for purposes of type printing, return non-zero;
6694 otherwise return 0. */
6697 ada_prefer_type (struct type *type0, struct type *type1)
6701 else if (type0 == NULL)
6703 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
6705 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
6707 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
6709 else if (ada_is_packed_array_type (type0))
6711 else if (ada_is_array_descriptor_type (type0)
6712 && !ada_is_array_descriptor_type (type1))
6716 const char *type0_name = type_name_no_tag (type0);
6717 const char *type1_name = type_name_no_tag (type1);
6719 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
6720 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
6726 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6727 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6730 ada_type_name (struct type *type)
6734 else if (TYPE_NAME (type) != NULL)
6735 return TYPE_NAME (type);
6737 return TYPE_TAG_NAME (type);
6740 /* Find a parallel type to TYPE whose name is formed by appending
6741 SUFFIX to the name of TYPE. */
6744 ada_find_parallel_type (struct type *type, const char *suffix)
6747 static size_t name_len = 0;
6749 char *typename = ada_type_name (type);
6751 if (typename == NULL)
6754 len = strlen (typename);
6756 GROW_VECT (name, name_len, len + strlen (suffix) + 1);
6758 strcpy (name, typename);
6759 strcpy (name + len, suffix);
6761 return ada_find_any_type (name);
6765 /* If TYPE is a variable-size record type, return the corresponding template
6766 type describing its fields. Otherwise, return NULL. */
6768 static struct type *
6769 dynamic_template_type (struct type *type)
6771 type = ada_check_typedef (type);
6773 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
6774 || ada_type_name (type) == NULL)
6778 int len = strlen (ada_type_name (type));
6779 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
6782 return ada_find_parallel_type (type, "___XVE");
6786 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6787 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6790 is_dynamic_field (struct type *templ_type, int field_num)
6792 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
6794 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
6795 && strstr (name, "___XVL") != NULL;
6798 /* The index of the variant field of TYPE, or -1 if TYPE does not
6799 represent a variant record type. */
6802 variant_field_index (struct type *type)
6806 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6809 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
6811 if (ada_is_variant_part (type, f))
6817 /* A record type with no fields. */
6819 static struct type *
6820 empty_record (struct objfile *objfile)
6822 struct type *type = alloc_type (objfile);
6823 TYPE_CODE (type) = TYPE_CODE_STRUCT;
6824 TYPE_NFIELDS (type) = 0;
6825 TYPE_FIELDS (type) = NULL;
6826 INIT_CPLUS_SPECIFIC (type);
6827 TYPE_NAME (type) = "<empty>";
6828 TYPE_TAG_NAME (type) = NULL;
6829 TYPE_LENGTH (type) = 0;
6833 /* An ordinary record type (with fixed-length fields) that describes
6834 the value of type TYPE at VALADDR or ADDRESS (see comments at
6835 the beginning of this section) VAL according to GNAT conventions.
6836 DVAL0 should describe the (portion of a) record that contains any
6837 necessary discriminants. It should be NULL if value_type (VAL) is
6838 an outer-level type (i.e., as opposed to a branch of a variant.) A
6839 variant field (unless unchecked) is replaced by a particular branch
6842 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6843 length are not statically known are discarded. As a consequence,
6844 VALADDR, ADDRESS and DVAL0 are ignored.
6846 NOTE: Limitations: For now, we assume that dynamic fields and
6847 variants occupy whole numbers of bytes. However, they need not be
6851 ada_template_to_fixed_record_type_1 (struct type *type,
6852 const gdb_byte *valaddr,
6853 CORE_ADDR address, struct value *dval0,
6854 int keep_dynamic_fields)
6856 struct value *mark = value_mark ();
6859 int nfields, bit_len;
6862 int fld_bit_len, bit_incr;
6865 /* Compute the number of fields in this record type that are going
6866 to be processed: unless keep_dynamic_fields, this includes only
6867 fields whose position and length are static will be processed. */
6868 if (keep_dynamic_fields)
6869 nfields = TYPE_NFIELDS (type);
6873 while (nfields < TYPE_NFIELDS (type)
6874 && !ada_is_variant_part (type, nfields)
6875 && !is_dynamic_field (type, nfields))
6879 rtype = alloc_type (TYPE_OBJFILE (type));
6880 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6881 INIT_CPLUS_SPECIFIC (rtype);
6882 TYPE_NFIELDS (rtype) = nfields;
6883 TYPE_FIELDS (rtype) = (struct field *)
6884 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6885 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
6886 TYPE_NAME (rtype) = ada_type_name (type);
6887 TYPE_TAG_NAME (rtype) = NULL;
6888 TYPE_FIXED_INSTANCE (rtype) = 1;
6894 for (f = 0; f < nfields; f += 1)
6896 off = align_value (off, field_alignment (type, f))
6897 + TYPE_FIELD_BITPOS (type, f);
6898 TYPE_FIELD_BITPOS (rtype, f) = off;
6899 TYPE_FIELD_BITSIZE (rtype, f) = 0;
6901 if (ada_is_variant_part (type, f))
6904 fld_bit_len = bit_incr = 0;
6906 else if (is_dynamic_field (type, f))
6909 dval = value_from_contents_and_address (rtype, valaddr, address);
6913 /* Get the fixed type of the field. Note that, in this case, we
6914 do not want to get the real type out of the tag: if the current
6915 field is the parent part of a tagged record, we will get the
6916 tag of the object. Clearly wrong: the real type of the parent
6917 is not the real type of the child. We would end up in an infinite
6919 TYPE_FIELD_TYPE (rtype, f) =
6922 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
6923 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6924 cond_offset_target (address, off / TARGET_CHAR_BIT), dval, 0);
6925 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6926 bit_incr = fld_bit_len =
6927 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6931 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
6932 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6933 if (TYPE_FIELD_BITSIZE (type, f) > 0)
6934 bit_incr = fld_bit_len =
6935 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
6937 bit_incr = fld_bit_len =
6938 TYPE_LENGTH (TYPE_FIELD_TYPE (type, f)) * TARGET_CHAR_BIT;
6940 if (off + fld_bit_len > bit_len)
6941 bit_len = off + fld_bit_len;
6943 TYPE_LENGTH (rtype) =
6944 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
6947 /* We handle the variant part, if any, at the end because of certain
6948 odd cases in which it is re-ordered so as NOT to be the last field of
6949 the record. This can happen in the presence of representation
6951 if (variant_field >= 0)
6953 struct type *branch_type;
6955 off = TYPE_FIELD_BITPOS (rtype, variant_field);
6958 dval = value_from_contents_and_address (rtype, valaddr, address);
6963 to_fixed_variant_branch_type
6964 (TYPE_FIELD_TYPE (type, variant_field),
6965 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6966 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
6967 if (branch_type == NULL)
6969 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
6970 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
6971 TYPE_NFIELDS (rtype) -= 1;
6975 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
6976 TYPE_FIELD_NAME (rtype, variant_field) = "S";
6978 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
6980 if (off + fld_bit_len > bit_len)
6981 bit_len = off + fld_bit_len;
6982 TYPE_LENGTH (rtype) =
6983 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
6987 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6988 should contain the alignment of that record, which should be a strictly
6989 positive value. If null or negative, then something is wrong, most
6990 probably in the debug info. In that case, we don't round up the size
6991 of the resulting type. If this record is not part of another structure,
6992 the current RTYPE length might be good enough for our purposes. */
6993 if (TYPE_LENGTH (type) <= 0)
6995 if (TYPE_NAME (rtype))
6996 warning (_("Invalid type size for `%s' detected: %d."),
6997 TYPE_NAME (rtype), TYPE_LENGTH (type));
6999 warning (_("Invalid type size for <unnamed> detected: %d."),
7000 TYPE_LENGTH (type));
7004 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
7005 TYPE_LENGTH (type));
7008 value_free_to_mark (mark);
7009 if (TYPE_LENGTH (rtype) > varsize_limit)
7010 error (_("record type with dynamic size is larger than varsize-limit"));
7014 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7017 static struct type *
7018 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
7019 CORE_ADDR address, struct value *dval0)
7021 return ada_template_to_fixed_record_type_1 (type, valaddr,
7025 /* An ordinary record type in which ___XVL-convention fields and
7026 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7027 static approximations, containing all possible fields. Uses
7028 no runtime values. Useless for use in values, but that's OK,
7029 since the results are used only for type determinations. Works on both
7030 structs and unions. Representation note: to save space, we memorize
7031 the result of this function in the TYPE_TARGET_TYPE of the
7034 static struct type *
7035 template_to_static_fixed_type (struct type *type0)
7041 if (TYPE_TARGET_TYPE (type0) != NULL)
7042 return TYPE_TARGET_TYPE (type0);
7044 nfields = TYPE_NFIELDS (type0);
7047 for (f = 0; f < nfields; f += 1)
7049 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
7050 struct type *new_type;
7052 if (is_dynamic_field (type0, f))
7053 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
7055 new_type = static_unwrap_type (field_type);
7056 if (type == type0 && new_type != field_type)
7058 TYPE_TARGET_TYPE (type0) = type = alloc_type (TYPE_OBJFILE (type0));
7059 TYPE_CODE (type) = TYPE_CODE (type0);
7060 INIT_CPLUS_SPECIFIC (type);
7061 TYPE_NFIELDS (type) = nfields;
7062 TYPE_FIELDS (type) = (struct field *)
7063 TYPE_ALLOC (type, nfields * sizeof (struct field));
7064 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7065 sizeof (struct field) * nfields);
7066 TYPE_NAME (type) = ada_type_name (type0);
7067 TYPE_TAG_NAME (type) = NULL;
7068 TYPE_FIXED_INSTANCE (type) = 1;
7069 TYPE_LENGTH (type) = 0;
7071 TYPE_FIELD_TYPE (type, f) = new_type;
7072 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
7077 /* Given an object of type TYPE whose contents are at VALADDR and
7078 whose address in memory is ADDRESS, returns a revision of TYPE,
7079 which should be a non-dynamic-sized record, in which the variant
7080 part, if any, is replaced with the appropriate branch. Looks
7081 for discriminant values in DVAL0, which can be NULL if the record
7082 contains the necessary discriminant values. */
7084 static struct type *
7085 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
7086 CORE_ADDR address, struct value *dval0)
7088 struct value *mark = value_mark ();
7091 struct type *branch_type;
7092 int nfields = TYPE_NFIELDS (type);
7093 int variant_field = variant_field_index (type);
7095 if (variant_field == -1)
7099 dval = value_from_contents_and_address (type, valaddr, address);
7103 rtype = alloc_type (TYPE_OBJFILE (type));
7104 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7105 INIT_CPLUS_SPECIFIC (rtype);
7106 TYPE_NFIELDS (rtype) = nfields;
7107 TYPE_FIELDS (rtype) =
7108 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7109 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
7110 sizeof (struct field) * nfields);
7111 TYPE_NAME (rtype) = ada_type_name (type);
7112 TYPE_TAG_NAME (rtype) = NULL;
7113 TYPE_FIXED_INSTANCE (rtype) = 1;
7114 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7116 branch_type = to_fixed_variant_branch_type
7117 (TYPE_FIELD_TYPE (type, variant_field),
7118 cond_offset_host (valaddr,
7119 TYPE_FIELD_BITPOS (type, variant_field)
7121 cond_offset_target (address,
7122 TYPE_FIELD_BITPOS (type, variant_field)
7123 / TARGET_CHAR_BIT), dval);
7124 if (branch_type == NULL)
7127 for (f = variant_field + 1; f < nfields; f += 1)
7128 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7129 TYPE_NFIELDS (rtype) -= 1;
7133 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7134 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7135 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
7136 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
7138 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
7140 value_free_to_mark (mark);
7144 /* An ordinary record type (with fixed-length fields) that describes
7145 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7146 beginning of this section]. Any necessary discriminants' values
7147 should be in DVAL, a record value; it may be NULL if the object
7148 at ADDR itself contains any necessary discriminant values.
7149 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7150 values from the record are needed. Except in the case that DVAL,
7151 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7152 unchecked) is replaced by a particular branch of the variant.
7154 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7155 is questionable and may be removed. It can arise during the
7156 processing of an unconstrained-array-of-record type where all the
7157 variant branches have exactly the same size. This is because in
7158 such cases, the compiler does not bother to use the XVS convention
7159 when encoding the record. I am currently dubious of this
7160 shortcut and suspect the compiler should be altered. FIXME. */
7162 static struct type *
7163 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
7164 CORE_ADDR address, struct value *dval)
7166 struct type *templ_type;
7168 if (TYPE_FIXED_INSTANCE (type0))
7171 templ_type = dynamic_template_type (type0);
7173 if (templ_type != NULL)
7174 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
7175 else if (variant_field_index (type0) >= 0)
7177 if (dval == NULL && valaddr == NULL && address == 0)
7179 return to_record_with_fixed_variant_part (type0, valaddr, address,
7184 TYPE_FIXED_INSTANCE (type0) = 1;
7190 /* An ordinary record type (with fixed-length fields) that describes
7191 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7192 union type. Any necessary discriminants' values should be in DVAL,
7193 a record value. That is, this routine selects the appropriate
7194 branch of the union at ADDR according to the discriminant value
7195 indicated in the union's type name. Returns VAR_TYPE0 itself if
7196 it represents a variant subject to a pragma Unchecked_Union. */
7198 static struct type *
7199 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
7200 CORE_ADDR address, struct value *dval)
7203 struct type *templ_type;
7204 struct type *var_type;
7206 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
7207 var_type = TYPE_TARGET_TYPE (var_type0);
7209 var_type = var_type0;
7211 templ_type = ada_find_parallel_type (var_type, "___XVU");
7213 if (templ_type != NULL)
7214 var_type = templ_type;
7216 if (is_unchecked_variant (var_type, value_type (dval)))
7219 ada_which_variant_applies (var_type,
7220 value_type (dval), value_contents (dval));
7223 return empty_record (TYPE_OBJFILE (var_type));
7224 else if (is_dynamic_field (var_type, which))
7225 return to_fixed_record_type
7226 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
7227 valaddr, address, dval);
7228 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
7230 to_fixed_record_type
7231 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
7233 return TYPE_FIELD_TYPE (var_type, which);
7236 /* Assuming that TYPE0 is an array type describing the type of a value
7237 at ADDR, and that DVAL describes a record containing any
7238 discriminants used in TYPE0, returns a type for the value that
7239 contains no dynamic components (that is, no components whose sizes
7240 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7241 true, gives an error message if the resulting type's size is over
7244 static struct type *
7245 to_fixed_array_type (struct type *type0, struct value *dval,
7248 struct type *index_type_desc;
7249 struct type *result;
7251 if (ada_is_packed_array_type (type0) /* revisit? */
7252 || TYPE_FIXED_INSTANCE (type0))
7255 index_type_desc = ada_find_parallel_type (type0, "___XA");
7256 if (index_type_desc == NULL)
7258 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
7259 /* NOTE: elt_type---the fixed version of elt_type0---should never
7260 depend on the contents of the array in properly constructed
7262 /* Create a fixed version of the array element type.
7263 We're not providing the address of an element here,
7264 and thus the actual object value cannot be inspected to do
7265 the conversion. This should not be a problem, since arrays of
7266 unconstrained objects are not allowed. In particular, all
7267 the elements of an array of a tagged type should all be of
7268 the same type specified in the debugging info. No need to
7269 consult the object tag. */
7270 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
7272 if (elt_type0 == elt_type)
7275 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
7276 elt_type, TYPE_INDEX_TYPE (type0));
7281 struct type *elt_type0;
7284 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
7285 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
7287 /* NOTE: result---the fixed version of elt_type0---should never
7288 depend on the contents of the array in properly constructed
7290 /* Create a fixed version of the array element type.
7291 We're not providing the address of an element here,
7292 and thus the actual object value cannot be inspected to do
7293 the conversion. This should not be a problem, since arrays of
7294 unconstrained objects are not allowed. In particular, all
7295 the elements of an array of a tagged type should all be of
7296 the same type specified in the debugging info. No need to
7297 consult the object tag. */
7299 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
7300 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
7302 struct type *range_type =
7303 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i),
7304 dval, TYPE_OBJFILE (type0));
7305 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
7306 result, range_type);
7308 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
7309 error (_("array type with dynamic size is larger than varsize-limit"));
7312 TYPE_FIXED_INSTANCE (result) = 1;
7317 /* A standard type (containing no dynamically sized components)
7318 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7319 DVAL describes a record containing any discriminants used in TYPE0,
7320 and may be NULL if there are none, or if the object of type TYPE at
7321 ADDRESS or in VALADDR contains these discriminants.
7323 If CHECK_TAG is not null, in the case of tagged types, this function
7324 attempts to locate the object's tag and use it to compute the actual
7325 type. However, when ADDRESS is null, we cannot use it to determine the
7326 location of the tag, and therefore compute the tagged type's actual type.
7327 So we return the tagged type without consulting the tag. */
7329 static struct type *
7330 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
7331 CORE_ADDR address, struct value *dval, int check_tag)
7333 type = ada_check_typedef (type);
7334 switch (TYPE_CODE (type))
7338 case TYPE_CODE_STRUCT:
7340 struct type *static_type = to_static_fixed_type (type);
7341 struct type *fixed_record_type =
7342 to_fixed_record_type (type, valaddr, address, NULL);
7343 /* If STATIC_TYPE is a tagged type and we know the object's address,
7344 then we can determine its tag, and compute the object's actual
7345 type from there. Note that we have to use the fixed record
7346 type (the parent part of the record may have dynamic fields
7347 and the way the location of _tag is expressed may depend on
7350 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
7352 struct type *real_type =
7353 type_from_tag (value_tag_from_contents_and_address
7357 if (real_type != NULL)
7358 return to_fixed_record_type (real_type, valaddr, address, NULL);
7361 /* Check to see if there is a parallel ___XVZ variable.
7362 If there is, then it provides the actual size of our type. */
7363 else if (ada_type_name (fixed_record_type) != NULL)
7365 char *name = ada_type_name (fixed_record_type);
7366 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
7370 sprintf (xvz_name, "%s___XVZ", name);
7371 size = get_int_var_value (xvz_name, &xvz_found);
7372 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
7374 fixed_record_type = copy_type (fixed_record_type);
7375 TYPE_LENGTH (fixed_record_type) = size;
7377 /* The FIXED_RECORD_TYPE may have be a stub. We have
7378 observed this when the debugging info is STABS, and
7379 apparently it is something that is hard to fix.
7381 In practice, we don't need the actual type definition
7382 at all, because the presence of the XVZ variable allows us
7383 to assume that there must be a XVS type as well, which we
7384 should be able to use later, when we need the actual type
7387 In the meantime, pretend that the "fixed" type we are
7388 returning is NOT a stub, because this can cause trouble
7389 when using this type to create new types targeting it.
7390 Indeed, the associated creation routines often check
7391 whether the target type is a stub and will try to replace
7392 it, thus using a type with the wrong size. This, in turn,
7393 might cause the new type to have the wrong size too.
7394 Consider the case of an array, for instance, where the size
7395 of the array is computed from the number of elements in
7396 our array multiplied by the size of its element. */
7397 TYPE_STUB (fixed_record_type) = 0;
7400 return fixed_record_type;
7402 case TYPE_CODE_ARRAY:
7403 return to_fixed_array_type (type, dval, 1);
7404 case TYPE_CODE_UNION:
7408 return to_fixed_variant_branch_type (type, valaddr, address, dval);
7412 /* The same as ada_to_fixed_type_1, except that it preserves the type
7413 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7414 ada_to_fixed_type_1 would return the type referenced by TYPE. */
7417 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
7418 CORE_ADDR address, struct value *dval, int check_tag)
7421 struct type *fixed_type =
7422 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
7424 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
7425 && TYPE_TARGET_TYPE (type) == fixed_type)
7431 /* A standard (static-sized) type corresponding as well as possible to
7432 TYPE0, but based on no runtime data. */
7434 static struct type *
7435 to_static_fixed_type (struct type *type0)
7442 if (TYPE_FIXED_INSTANCE (type0))
7445 type0 = ada_check_typedef (type0);
7447 switch (TYPE_CODE (type0))
7451 case TYPE_CODE_STRUCT:
7452 type = dynamic_template_type (type0);
7454 return template_to_static_fixed_type (type);
7456 return template_to_static_fixed_type (type0);
7457 case TYPE_CODE_UNION:
7458 type = ada_find_parallel_type (type0, "___XVU");
7460 return template_to_static_fixed_type (type);
7462 return template_to_static_fixed_type (type0);
7466 /* A static approximation of TYPE with all type wrappers removed. */
7468 static struct type *
7469 static_unwrap_type (struct type *type)
7471 if (ada_is_aligner_type (type))
7473 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
7474 if (ada_type_name (type1) == NULL)
7475 TYPE_NAME (type1) = ada_type_name (type);
7477 return static_unwrap_type (type1);
7481 struct type *raw_real_type = ada_get_base_type (type);
7482 if (raw_real_type == type)
7485 return to_static_fixed_type (raw_real_type);
7489 /* In some cases, incomplete and private types require
7490 cross-references that are not resolved as records (for example,
7492 type FooP is access Foo;
7494 type Foo is array ...;
7495 ). In these cases, since there is no mechanism for producing
7496 cross-references to such types, we instead substitute for FooP a
7497 stub enumeration type that is nowhere resolved, and whose tag is
7498 the name of the actual type. Call these types "non-record stubs". */
7500 /* A type equivalent to TYPE that is not a non-record stub, if one
7501 exists, otherwise TYPE. */
7504 ada_check_typedef (struct type *type)
7509 CHECK_TYPEDEF (type);
7510 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
7511 || !TYPE_STUB (type)
7512 || TYPE_TAG_NAME (type) == NULL)
7516 char *name = TYPE_TAG_NAME (type);
7517 struct type *type1 = ada_find_any_type (name);
7518 return (type1 == NULL) ? type : type1;
7522 /* A value representing the data at VALADDR/ADDRESS as described by
7523 type TYPE0, but with a standard (static-sized) type that correctly
7524 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7525 type, then return VAL0 [this feature is simply to avoid redundant
7526 creation of struct values]. */
7528 static struct value *
7529 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
7532 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
7533 if (type == type0 && val0 != NULL)
7536 return value_from_contents_and_address (type, 0, address);
7539 /* A value representing VAL, but with a standard (static-sized) type
7540 that correctly describes it. Does not necessarily create a new
7543 static struct value *
7544 ada_to_fixed_value (struct value *val)
7546 return ada_to_fixed_value_create (value_type (val),
7547 VALUE_ADDRESS (val) + value_offset (val),
7551 /* A value representing VAL, but with a standard (static-sized) type
7552 chosen to approximate the real type of VAL as well as possible, but
7553 without consulting any runtime values. For Ada dynamic-sized
7554 types, therefore, the type of the result is likely to be inaccurate. */
7557 ada_to_static_fixed_value (struct value *val)
7560 to_static_fixed_type (static_unwrap_type (value_type (val)));
7561 if (type == value_type (val))
7564 return coerce_unspec_val_to_type (val, type);
7570 /* Table mapping attribute numbers to names.
7571 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7573 static const char *attribute_names[] = {
7591 ada_attribute_name (enum exp_opcode n)
7593 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
7594 return attribute_names[n - OP_ATR_FIRST + 1];
7596 return attribute_names[0];
7599 /* Evaluate the 'POS attribute applied to ARG. */
7602 pos_atr (struct value *arg)
7604 struct value *val = coerce_ref (arg);
7605 struct type *type = value_type (val);
7607 if (!discrete_type_p (type))
7608 error (_("'POS only defined on discrete types"));
7610 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7613 LONGEST v = value_as_long (val);
7615 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7617 if (v == TYPE_FIELD_BITPOS (type, i))
7620 error (_("enumeration value is invalid: can't find 'POS"));
7623 return value_as_long (val);
7626 static struct value *
7627 value_pos_atr (struct type *type, struct value *arg)
7629 return value_from_longest (type, pos_atr (arg));
7632 /* Evaluate the TYPE'VAL attribute applied to ARG. */
7634 static struct value *
7635 value_val_atr (struct type *type, struct value *arg)
7637 if (!discrete_type_p (type))
7638 error (_("'VAL only defined on discrete types"));
7639 if (!integer_type_p (value_type (arg)))
7640 error (_("'VAL requires integral argument"));
7642 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7644 long pos = value_as_long (arg);
7645 if (pos < 0 || pos >= TYPE_NFIELDS (type))
7646 error (_("argument to 'VAL out of range"));
7647 return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
7650 return value_from_longest (type, value_as_long (arg));
7656 /* True if TYPE appears to be an Ada character type.
7657 [At the moment, this is true only for Character and Wide_Character;
7658 It is a heuristic test that could stand improvement]. */
7661 ada_is_character_type (struct type *type)
7665 /* If the type code says it's a character, then assume it really is,
7666 and don't check any further. */
7667 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
7670 /* Otherwise, assume it's a character type iff it is a discrete type
7671 with a known character type name. */
7672 name = ada_type_name (type);
7673 return (name != NULL
7674 && (TYPE_CODE (type) == TYPE_CODE_INT
7675 || TYPE_CODE (type) == TYPE_CODE_RANGE)
7676 && (strcmp (name, "character") == 0
7677 || strcmp (name, "wide_character") == 0
7678 || strcmp (name, "wide_wide_character") == 0
7679 || strcmp (name, "unsigned char") == 0));
7682 /* True if TYPE appears to be an Ada string type. */
7685 ada_is_string_type (struct type *type)
7687 type = ada_check_typedef (type);
7689 && TYPE_CODE (type) != TYPE_CODE_PTR
7690 && (ada_is_simple_array_type (type)
7691 || ada_is_array_descriptor_type (type))
7692 && ada_array_arity (type) == 1)
7694 struct type *elttype = ada_array_element_type (type, 1);
7696 return ada_is_character_type (elttype);
7703 /* True if TYPE is a struct type introduced by the compiler to force the
7704 alignment of a value. Such types have a single field with a
7705 distinctive name. */
7708 ada_is_aligner_type (struct type *type)
7710 type = ada_check_typedef (type);
7712 /* If we can find a parallel XVS type, then the XVS type should
7713 be used instead of this type. And hence, this is not an aligner
7715 if (ada_find_parallel_type (type, "___XVS") != NULL)
7718 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
7719 && TYPE_NFIELDS (type) == 1
7720 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
7723 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7724 the parallel type. */
7727 ada_get_base_type (struct type *raw_type)
7729 struct type *real_type_namer;
7730 struct type *raw_real_type;
7732 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
7735 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
7736 if (real_type_namer == NULL
7737 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
7738 || TYPE_NFIELDS (real_type_namer) != 1)
7741 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
7742 if (raw_real_type == NULL)
7745 return raw_real_type;
7748 /* The type of value designated by TYPE, with all aligners removed. */
7751 ada_aligned_type (struct type *type)
7753 if (ada_is_aligner_type (type))
7754 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
7756 return ada_get_base_type (type);
7760 /* The address of the aligned value in an object at address VALADDR
7761 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7764 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
7766 if (ada_is_aligner_type (type))
7767 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
7769 TYPE_FIELD_BITPOS (type,
7770 0) / TARGET_CHAR_BIT);
7777 /* The printed representation of an enumeration literal with encoded
7778 name NAME. The value is good to the next call of ada_enum_name. */
7780 ada_enum_name (const char *name)
7782 static char *result;
7783 static size_t result_len = 0;
7786 /* First, unqualify the enumeration name:
7787 1. Search for the last '.' character. If we find one, then skip
7788 all the preceeding characters, the unqualified name starts
7789 right after that dot.
7790 2. Otherwise, we may be debugging on a target where the compiler
7791 translates dots into "__". Search forward for double underscores,
7792 but stop searching when we hit an overloading suffix, which is
7793 of the form "__" followed by digits. */
7795 tmp = strrchr (name, '.');
7800 while ((tmp = strstr (name, "__")) != NULL)
7802 if (isdigit (tmp[2]))
7812 if (name[1] == 'U' || name[1] == 'W')
7814 if (sscanf (name + 2, "%x", &v) != 1)
7820 GROW_VECT (result, result_len, 16);
7821 if (isascii (v) && isprint (v))
7822 sprintf (result, "'%c'", v);
7823 else if (name[1] == 'U')
7824 sprintf (result, "[\"%02x\"]", v);
7826 sprintf (result, "[\"%04x\"]", v);
7832 tmp = strstr (name, "__");
7834 tmp = strstr (name, "$");
7837 GROW_VECT (result, result_len, tmp - name + 1);
7838 strncpy (result, name, tmp - name);
7839 result[tmp - name] = '\0';
7847 static struct value *
7848 evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos,
7851 return (*exp->language_defn->la_exp_desc->evaluate_exp)
7852 (expect_type, exp, pos, noside);
7855 /* Evaluate the subexpression of EXP starting at *POS as for
7856 evaluate_type, updating *POS to point just past the evaluated
7859 static struct value *
7860 evaluate_subexp_type (struct expression *exp, int *pos)
7862 return (*exp->language_defn->la_exp_desc->evaluate_exp)
7863 (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
7866 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7869 static struct value *
7870 unwrap_value (struct value *val)
7872 struct type *type = ada_check_typedef (value_type (val));
7873 if (ada_is_aligner_type (type))
7875 struct value *v = ada_value_struct_elt (val, "F", 0);
7876 struct type *val_type = ada_check_typedef (value_type (v));
7877 if (ada_type_name (val_type) == NULL)
7878 TYPE_NAME (val_type) = ada_type_name (type);
7880 return unwrap_value (v);
7884 struct type *raw_real_type =
7885 ada_check_typedef (ada_get_base_type (type));
7887 if (type == raw_real_type)
7891 coerce_unspec_val_to_type
7892 (val, ada_to_fixed_type (raw_real_type, 0,
7893 VALUE_ADDRESS (val) + value_offset (val),
7898 static struct value *
7899 cast_to_fixed (struct type *type, struct value *arg)
7903 if (type == value_type (arg))
7905 else if (ada_is_fixed_point_type (value_type (arg)))
7906 val = ada_float_to_fixed (type,
7907 ada_fixed_to_float (value_type (arg),
7908 value_as_long (arg)));
7911 DOUBLEST argd = value_as_double (arg);
7912 val = ada_float_to_fixed (type, argd);
7915 return value_from_longest (type, val);
7918 static struct value *
7919 cast_from_fixed (struct type *type, struct value *arg)
7921 DOUBLEST val = ada_fixed_to_float (value_type (arg),
7922 value_as_long (arg));
7923 return value_from_double (type, val);
7926 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7927 return the converted value. */
7929 static struct value *
7930 coerce_for_assign (struct type *type, struct value *val)
7932 struct type *type2 = value_type (val);
7936 type2 = ada_check_typedef (type2);
7937 type = ada_check_typedef (type);
7939 if (TYPE_CODE (type2) == TYPE_CODE_PTR
7940 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7942 val = ada_value_ind (val);
7943 type2 = value_type (val);
7946 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
7947 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7949 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
7950 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
7951 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
7952 error (_("Incompatible types in assignment"));
7953 deprecated_set_value_type (val, type);
7958 static struct value *
7959 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
7962 struct type *type1, *type2;
7965 arg1 = coerce_ref (arg1);
7966 arg2 = coerce_ref (arg2);
7967 type1 = base_type (ada_check_typedef (value_type (arg1)));
7968 type2 = base_type (ada_check_typedef (value_type (arg2)));
7970 if (TYPE_CODE (type1) != TYPE_CODE_INT
7971 || TYPE_CODE (type2) != TYPE_CODE_INT)
7972 return value_binop (arg1, arg2, op);
7981 return value_binop (arg1, arg2, op);
7984 v2 = value_as_long (arg2);
7986 error (_("second operand of %s must not be zero."), op_string (op));
7988 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
7989 return value_binop (arg1, arg2, op);
7991 v1 = value_as_long (arg1);
7996 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
7997 v += v > 0 ? -1 : 1;
8005 /* Should not reach this point. */
8009 val = allocate_value (type1);
8010 store_unsigned_integer (value_contents_raw (val),
8011 TYPE_LENGTH (value_type (val)), v);
8016 ada_value_equal (struct value *arg1, struct value *arg2)
8018 if (ada_is_direct_array_type (value_type (arg1))
8019 || ada_is_direct_array_type (value_type (arg2)))
8021 /* Automatically dereference any array reference before
8022 we attempt to perform the comparison. */
8023 arg1 = ada_coerce_ref (arg1);
8024 arg2 = ada_coerce_ref (arg2);
8026 arg1 = ada_coerce_to_simple_array (arg1);
8027 arg2 = ada_coerce_to_simple_array (arg2);
8028 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
8029 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
8030 error (_("Attempt to compare array with non-array"));
8031 /* FIXME: The following works only for types whose
8032 representations use all bits (no padding or undefined bits)
8033 and do not have user-defined equality. */
8035 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
8036 && memcmp (value_contents (arg1), value_contents (arg2),
8037 TYPE_LENGTH (value_type (arg1))) == 0;
8039 return value_equal (arg1, arg2);
8042 /* Total number of component associations in the aggregate starting at
8043 index PC in EXP. Assumes that index PC is the start of an
8047 num_component_specs (struct expression *exp, int pc)
8050 m = exp->elts[pc + 1].longconst;
8053 for (i = 0; i < m; i += 1)
8055 switch (exp->elts[pc].opcode)
8061 n += exp->elts[pc + 1].longconst;
8064 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
8069 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
8070 component of LHS (a simple array or a record), updating *POS past
8071 the expression, assuming that LHS is contained in CONTAINER. Does
8072 not modify the inferior's memory, nor does it modify LHS (unless
8073 LHS == CONTAINER). */
8076 assign_component (struct value *container, struct value *lhs, LONGEST index,
8077 struct expression *exp, int *pos)
8079 struct value *mark = value_mark ();
8081 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
8083 struct value *index_val = value_from_longest (builtin_type_int32, index);
8084 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
8088 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
8089 elt = ada_to_fixed_value (unwrap_value (elt));
8092 if (exp->elts[*pos].opcode == OP_AGGREGATE)
8093 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
8095 value_assign_to_component (container, elt,
8096 ada_evaluate_subexp (NULL, exp, pos,
8099 value_free_to_mark (mark);
8102 /* Assuming that LHS represents an lvalue having a record or array
8103 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8104 of that aggregate's value to LHS, advancing *POS past the
8105 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8106 lvalue containing LHS (possibly LHS itself). Does not modify
8107 the inferior's memory, nor does it modify the contents of
8108 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
8110 static struct value *
8111 assign_aggregate (struct value *container,
8112 struct value *lhs, struct expression *exp,
8113 int *pos, enum noside noside)
8115 struct type *lhs_type;
8116 int n = exp->elts[*pos+1].longconst;
8117 LONGEST low_index, high_index;
8120 int max_indices, num_indices;
8121 int is_array_aggregate;
8123 struct value *mark = value_mark ();
8126 if (noside != EVAL_NORMAL)
8129 for (i = 0; i < n; i += 1)
8130 ada_evaluate_subexp (NULL, exp, pos, noside);
8134 container = ada_coerce_ref (container);
8135 if (ada_is_direct_array_type (value_type (container)))
8136 container = ada_coerce_to_simple_array (container);
8137 lhs = ada_coerce_ref (lhs);
8138 if (!deprecated_value_modifiable (lhs))
8139 error (_("Left operand of assignment is not a modifiable lvalue."));
8141 lhs_type = value_type (lhs);
8142 if (ada_is_direct_array_type (lhs_type))
8144 lhs = ada_coerce_to_simple_array (lhs);
8145 lhs_type = value_type (lhs);
8146 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
8147 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
8148 is_array_aggregate = 1;
8150 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
8153 high_index = num_visible_fields (lhs_type) - 1;
8154 is_array_aggregate = 0;
8157 error (_("Left-hand side must be array or record."));
8159 num_specs = num_component_specs (exp, *pos - 3);
8160 max_indices = 4 * num_specs + 4;
8161 indices = alloca (max_indices * sizeof (indices[0]));
8162 indices[0] = indices[1] = low_index - 1;
8163 indices[2] = indices[3] = high_index + 1;
8166 for (i = 0; i < n; i += 1)
8168 switch (exp->elts[*pos].opcode)
8171 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
8172 &num_indices, max_indices,
8173 low_index, high_index);
8176 aggregate_assign_positional (container, lhs, exp, pos, indices,
8177 &num_indices, max_indices,
8178 low_index, high_index);
8182 error (_("Misplaced 'others' clause"));
8183 aggregate_assign_others (container, lhs, exp, pos, indices,
8184 num_indices, low_index, high_index);
8187 error (_("Internal error: bad aggregate clause"));
8194 /* Assign into the component of LHS indexed by the OP_POSITIONAL
8195 construct at *POS, updating *POS past the construct, given that
8196 the positions are relative to lower bound LOW, where HIGH is the
8197 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8198 updating *NUM_INDICES as needed. CONTAINER is as for
8199 assign_aggregate. */
8201 aggregate_assign_positional (struct value *container,
8202 struct value *lhs, struct expression *exp,
8203 int *pos, LONGEST *indices, int *num_indices,
8204 int max_indices, LONGEST low, LONGEST high)
8206 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
8208 if (ind - 1 == high)
8209 warning (_("Extra components in aggregate ignored."));
8212 add_component_interval (ind, ind, indices, num_indices, max_indices);
8214 assign_component (container, lhs, ind, exp, pos);
8217 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8220 /* Assign into the components of LHS indexed by the OP_CHOICES
8221 construct at *POS, updating *POS past the construct, given that
8222 the allowable indices are LOW..HIGH. Record the indices assigned
8223 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8224 needed. CONTAINER is as for assign_aggregate. */
8226 aggregate_assign_from_choices (struct value *container,
8227 struct value *lhs, struct expression *exp,
8228 int *pos, LONGEST *indices, int *num_indices,
8229 int max_indices, LONGEST low, LONGEST high)
8232 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
8233 int choice_pos, expr_pc;
8234 int is_array = ada_is_direct_array_type (value_type (lhs));
8236 choice_pos = *pos += 3;
8238 for (j = 0; j < n_choices; j += 1)
8239 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8241 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8243 for (j = 0; j < n_choices; j += 1)
8245 LONGEST lower, upper;
8246 enum exp_opcode op = exp->elts[choice_pos].opcode;
8247 if (op == OP_DISCRETE_RANGE)
8250 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8252 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
8257 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
8268 name = &exp->elts[choice_pos + 2].string;
8271 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
8274 error (_("Invalid record component association."));
8276 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
8278 if (! find_struct_field (name, value_type (lhs), 0,
8279 NULL, NULL, NULL, NULL, &ind))
8280 error (_("Unknown component name: %s."), name);
8281 lower = upper = ind;
8284 if (lower <= upper && (lower < low || upper > high))
8285 error (_("Index in component association out of bounds."));
8287 add_component_interval (lower, upper, indices, num_indices,
8289 while (lower <= upper)
8293 assign_component (container, lhs, lower, exp, &pos1);
8299 /* Assign the value of the expression in the OP_OTHERS construct in
8300 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8301 have not been previously assigned. The index intervals already assigned
8302 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8303 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
8305 aggregate_assign_others (struct value *container,
8306 struct value *lhs, struct expression *exp,
8307 int *pos, LONGEST *indices, int num_indices,
8308 LONGEST low, LONGEST high)
8311 int expr_pc = *pos+1;
8313 for (i = 0; i < num_indices - 2; i += 2)
8316 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
8320 assign_component (container, lhs, ind, exp, &pos);
8323 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
8326 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
8327 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8328 modifying *SIZE as needed. It is an error if *SIZE exceeds
8329 MAX_SIZE. The resulting intervals do not overlap. */
8331 add_component_interval (LONGEST low, LONGEST high,
8332 LONGEST* indices, int *size, int max_size)
8335 for (i = 0; i < *size; i += 2) {
8336 if (high >= indices[i] && low <= indices[i + 1])
8339 for (kh = i + 2; kh < *size; kh += 2)
8340 if (high < indices[kh])
8342 if (low < indices[i])
8344 indices[i + 1] = indices[kh - 1];
8345 if (high > indices[i + 1])
8346 indices[i + 1] = high;
8347 memcpy (indices + i + 2, indices + kh, *size - kh);
8348 *size -= kh - i - 2;
8351 else if (high < indices[i])
8355 if (*size == max_size)
8356 error (_("Internal error: miscounted aggregate components."));
8358 for (j = *size-1; j >= i+2; j -= 1)
8359 indices[j] = indices[j - 2];
8361 indices[i + 1] = high;
8364 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8367 static struct value *
8368 ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
8370 if (type == ada_check_typedef (value_type (arg2)))
8373 if (ada_is_fixed_point_type (type))
8374 return (cast_to_fixed (type, arg2));
8376 if (ada_is_fixed_point_type (value_type (arg2)))
8377 return cast_from_fixed (type, arg2);
8379 return value_cast (type, arg2);
8382 static struct value *
8383 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
8384 int *pos, enum noside noside)
8387 int tem, tem2, tem3;
8389 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
8392 struct value **argvec;
8396 op = exp->elts[pc].opcode;
8402 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
8403 arg1 = unwrap_value (arg1);
8405 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8406 then we need to perform the conversion manually, because
8407 evaluate_subexp_standard doesn't do it. This conversion is
8408 necessary in Ada because the different kinds of float/fixed
8409 types in Ada have different representations.
8411 Similarly, we need to perform the conversion from OP_LONG
8413 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
8414 arg1 = ada_value_cast (expect_type, arg1, noside);
8420 struct value *result;
8422 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
8423 /* The result type will have code OP_STRING, bashed there from
8424 OP_ARRAY. Bash it back. */
8425 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
8426 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
8432 type = exp->elts[pc + 1].type;
8433 arg1 = evaluate_subexp (type, exp, pos, noside);
8434 if (noside == EVAL_SKIP)
8436 arg1 = ada_value_cast (type, arg1, noside);
8441 type = exp->elts[pc + 1].type;
8442 return ada_evaluate_subexp (type, exp, pos, noside);
8445 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8446 if (exp->elts[*pos].opcode == OP_AGGREGATE)
8448 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
8449 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
8451 return ada_value_assign (arg1, arg1);
8453 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8454 except if the lhs of our assignment is a convenience variable.
8455 In the case of assigning to a convenience variable, the lhs
8456 should be exactly the result of the evaluation of the rhs. */
8457 type = value_type (arg1);
8458 if (VALUE_LVAL (arg1) == lval_internalvar)
8460 arg2 = evaluate_subexp (type, exp, pos, noside);
8461 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
8463 if (ada_is_fixed_point_type (value_type (arg1)))
8464 arg2 = cast_to_fixed (value_type (arg1), arg2);
8465 else if (ada_is_fixed_point_type (value_type (arg2)))
8467 (_("Fixed-point values must be assigned to fixed-point variables"));
8469 arg2 = coerce_for_assign (value_type (arg1), arg2);
8470 return ada_value_assign (arg1, arg2);
8473 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8474 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8475 if (noside == EVAL_SKIP)
8477 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
8478 return (value_from_longest
8480 value_as_long (arg1) + value_as_long (arg2)));
8481 if ((ada_is_fixed_point_type (value_type (arg1))
8482 || ada_is_fixed_point_type (value_type (arg2)))
8483 && value_type (arg1) != value_type (arg2))
8484 error (_("Operands of fixed-point addition must have the same type"));
8485 /* Do the addition, and cast the result to the type of the first
8486 argument. We cannot cast the result to a reference type, so if
8487 ARG1 is a reference type, find its underlying type. */
8488 type = value_type (arg1);
8489 while (TYPE_CODE (type) == TYPE_CODE_REF)
8490 type = TYPE_TARGET_TYPE (type);
8491 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8492 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
8495 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8496 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8497 if (noside == EVAL_SKIP)
8499 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
8500 return (value_from_longest
8502 value_as_long (arg1) - value_as_long (arg2)));
8503 if ((ada_is_fixed_point_type (value_type (arg1))
8504 || ada_is_fixed_point_type (value_type (arg2)))
8505 && value_type (arg1) != value_type (arg2))
8506 error (_("Operands of fixed-point subtraction must have the same type"));
8507 /* Do the substraction, and cast the result to the type of the first
8508 argument. We cannot cast the result to a reference type, so if
8509 ARG1 is a reference type, find its underlying type. */
8510 type = value_type (arg1);
8511 while (TYPE_CODE (type) == TYPE_CODE_REF)
8512 type = TYPE_TARGET_TYPE (type);
8513 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8514 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
8518 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8519 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8520 if (noside == EVAL_SKIP)
8522 else if (noside == EVAL_AVOID_SIDE_EFFECTS
8523 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
8524 return value_zero (value_type (arg1), not_lval);
8527 type = builtin_type (exp->gdbarch)->builtin_double;
8528 if (ada_is_fixed_point_type (value_type (arg1)))
8529 arg1 = cast_from_fixed (type, arg1);
8530 if (ada_is_fixed_point_type (value_type (arg2)))
8531 arg2 = cast_from_fixed (type, arg2);
8532 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8533 return ada_value_binop (arg1, arg2, op);
8538 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8539 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8540 if (noside == EVAL_SKIP)
8542 else if (noside == EVAL_AVOID_SIDE_EFFECTS
8543 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
8544 return value_zero (value_type (arg1), not_lval);
8547 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8548 return ada_value_binop (arg1, arg2, op);
8552 case BINOP_NOTEQUAL:
8553 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8554 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
8555 if (noside == EVAL_SKIP)
8557 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8561 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8562 tem = ada_value_equal (arg1, arg2);
8564 if (op == BINOP_NOTEQUAL)
8566 type = language_bool_type (exp->language_defn, exp->gdbarch);
8567 return value_from_longest (type, (LONGEST) tem);
8570 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8571 if (noside == EVAL_SKIP)
8573 else if (ada_is_fixed_point_type (value_type (arg1)))
8574 return value_cast (value_type (arg1), value_neg (arg1));
8577 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
8578 return value_neg (arg1);
8581 case BINOP_LOGICAL_AND:
8582 case BINOP_LOGICAL_OR:
8583 case UNOP_LOGICAL_NOT:
8588 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8589 type = language_bool_type (exp->language_defn, exp->gdbarch);
8590 return value_cast (type, val);
8593 case BINOP_BITWISE_AND:
8594 case BINOP_BITWISE_IOR:
8595 case BINOP_BITWISE_XOR:
8599 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
8601 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
8603 return value_cast (value_type (arg1), val);
8609 if (noside == EVAL_SKIP)
8614 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
8615 /* Only encountered when an unresolved symbol occurs in a
8616 context other than a function call, in which case, it is
8618 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8619 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
8620 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8622 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
8623 if (ada_is_tagged_type (type, 0))
8625 /* Tagged types are a little special in the fact that the real
8626 type is dynamic and can only be determined by inspecting the
8627 object's tag. This means that we need to get the object's
8628 value first (EVAL_NORMAL) and then extract the actual object
8631 Note that we cannot skip the final step where we extract
8632 the object type from its tag, because the EVAL_NORMAL phase
8633 results in dynamic components being resolved into fixed ones.
8634 This can cause problems when trying to print the type
8635 description of tagged types whose parent has a dynamic size:
8636 We use the type name of the "_parent" component in order
8637 to print the name of the ancestor type in the type description.
8638 If that component had a dynamic size, the resolution into
8639 a fixed type would result in the loss of that type name,
8640 thus preventing us from printing the name of the ancestor
8641 type in the type description. */
8642 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
8643 return value_zero (type_from_tag (ada_value_tag (arg1)), not_lval);
8648 (to_static_fixed_type
8649 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
8655 unwrap_value (evaluate_subexp_standard
8656 (expect_type, exp, pos, noside));
8657 return ada_to_fixed_value (arg1);
8663 /* Allocate arg vector, including space for the function to be
8664 called in argvec[0] and a terminating NULL. */
8665 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8667 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
8669 if (exp->elts[*pos].opcode == OP_VAR_VALUE
8670 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
8671 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8672 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
8675 for (tem = 0; tem <= nargs; tem += 1)
8676 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8679 if (noside == EVAL_SKIP)
8683 if (ada_is_packed_array_type (desc_base_type (value_type (argvec[0]))))
8684 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
8685 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
8686 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
8687 && VALUE_LVAL (argvec[0]) == lval_memory))
8688 argvec[0] = value_addr (argvec[0]);
8690 type = ada_check_typedef (value_type (argvec[0]));
8691 if (TYPE_CODE (type) == TYPE_CODE_PTR)
8693 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
8695 case TYPE_CODE_FUNC:
8696 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8698 case TYPE_CODE_ARRAY:
8700 case TYPE_CODE_STRUCT:
8701 if (noside != EVAL_AVOID_SIDE_EFFECTS)
8702 argvec[0] = ada_value_ind (argvec[0]);
8703 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8706 error (_("cannot subscript or call something of type `%s'"),
8707 ada_type_name (value_type (argvec[0])));
8712 switch (TYPE_CODE (type))
8714 case TYPE_CODE_FUNC:
8715 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8716 return allocate_value (TYPE_TARGET_TYPE (type));
8717 return call_function_by_hand (argvec[0], nargs, argvec + 1);
8718 case TYPE_CODE_STRUCT:
8722 arity = ada_array_arity (type);
8723 type = ada_array_element_type (type, nargs);
8725 error (_("cannot subscript or call a record"));
8727 error (_("wrong number of subscripts; expecting %d"), arity);
8728 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8729 return value_zero (ada_aligned_type (type), lval_memory);
8731 unwrap_value (ada_value_subscript
8732 (argvec[0], nargs, argvec + 1));
8734 case TYPE_CODE_ARRAY:
8735 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8737 type = ada_array_element_type (type, nargs);
8739 error (_("element type of array unknown"));
8741 return value_zero (ada_aligned_type (type), lval_memory);
8744 unwrap_value (ada_value_subscript
8745 (ada_coerce_to_simple_array (argvec[0]),
8746 nargs, argvec + 1));
8747 case TYPE_CODE_PTR: /* Pointer to array */
8748 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
8749 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8751 type = ada_array_element_type (type, nargs);
8753 error (_("element type of array unknown"));
8755 return value_zero (ada_aligned_type (type), lval_memory);
8758 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
8759 nargs, argvec + 1));
8762 error (_("Attempt to index or call something other than an "
8763 "array or function"));
8768 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8769 struct value *low_bound_val =
8770 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8771 struct value *high_bound_val =
8772 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8775 low_bound_val = coerce_ref (low_bound_val);
8776 high_bound_val = coerce_ref (high_bound_val);
8777 low_bound = pos_atr (low_bound_val);
8778 high_bound = pos_atr (high_bound_val);
8780 if (noside == EVAL_SKIP)
8783 /* If this is a reference to an aligner type, then remove all
8785 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8786 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
8787 TYPE_TARGET_TYPE (value_type (array)) =
8788 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
8790 if (ada_is_packed_array_type (value_type (array)))
8791 error (_("cannot slice a packed array"));
8793 /* If this is a reference to an array or an array lvalue,
8794 convert to a pointer. */
8795 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8796 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
8797 && VALUE_LVAL (array) == lval_memory))
8798 array = value_addr (array);
8800 if (noside == EVAL_AVOID_SIDE_EFFECTS
8801 && ada_is_array_descriptor_type (ada_check_typedef
8802 (value_type (array))))
8803 return empty_array (ada_type_of_array (array, 0), low_bound);
8805 array = ada_coerce_to_simple_array_ptr (array);
8807 /* If we have more than one level of pointer indirection,
8808 dereference the value until we get only one level. */
8809 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
8810 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
8812 array = value_ind (array);
8814 /* Make sure we really do have an array type before going further,
8815 to avoid a SEGV when trying to get the index type or the target
8816 type later down the road if the debug info generated by
8817 the compiler is incorrect or incomplete. */
8818 if (!ada_is_simple_array_type (value_type (array)))
8819 error (_("cannot take slice of non-array"));
8821 if (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR)
8823 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
8824 return empty_array (TYPE_TARGET_TYPE (value_type (array)),
8828 struct type *arr_type0 =
8829 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array)),
8831 return ada_value_slice_ptr (array, arr_type0,
8832 longest_to_int (low_bound),
8833 longest_to_int (high_bound));
8836 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8838 else if (high_bound < low_bound)
8839 return empty_array (value_type (array), low_bound);
8841 return ada_value_slice (array, longest_to_int (low_bound),
8842 longest_to_int (high_bound));
8847 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8848 type = exp->elts[pc + 1].type;
8850 if (noside == EVAL_SKIP)
8853 switch (TYPE_CODE (type))
8856 lim_warning (_("Membership test incompletely implemented; "
8857 "always returns true"));
8858 type = language_bool_type (exp->language_defn, exp->gdbarch);
8859 return value_from_longest (type, (LONGEST) 1);
8861 case TYPE_CODE_RANGE:
8862 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
8863 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
8864 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8865 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
8866 type = language_bool_type (exp->language_defn, exp->gdbarch);
8868 value_from_longest (type,
8869 (value_less (arg1, arg3)
8870 || value_equal (arg1, arg3))
8871 && (value_less (arg2, arg1)
8872 || value_equal (arg2, arg1)));
8875 case BINOP_IN_BOUNDS:
8877 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8878 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8880 if (noside == EVAL_SKIP)
8883 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8885 type = language_bool_type (exp->language_defn, exp->gdbarch);
8886 return value_zero (type, not_lval);
8889 tem = longest_to_int (exp->elts[pc + 1].longconst);
8891 if (tem < 1 || tem > ada_array_arity (value_type (arg2)))
8892 error (_("invalid dimension number to 'range"));
8894 arg3 = ada_array_bound (arg2, tem, 1);
8895 arg2 = ada_array_bound (arg2, tem, 0);
8897 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8898 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
8899 type = language_bool_type (exp->language_defn, exp->gdbarch);
8901 value_from_longest (type,
8902 (value_less (arg1, arg3)
8903 || value_equal (arg1, arg3))
8904 && (value_less (arg2, arg1)
8905 || value_equal (arg2, arg1)));
8907 case TERNOP_IN_RANGE:
8908 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8909 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8910 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8912 if (noside == EVAL_SKIP)
8915 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
8916 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
8917 type = language_bool_type (exp->language_defn, exp->gdbarch);
8919 value_from_longest (type,
8920 (value_less (arg1, arg3)
8921 || value_equal (arg1, arg3))
8922 && (value_less (arg2, arg1)
8923 || value_equal (arg2, arg1)));
8929 struct type *type_arg;
8930 if (exp->elts[*pos].opcode == OP_TYPE)
8932 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
8934 type_arg = exp->elts[pc + 2].type;
8938 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8942 if (exp->elts[*pos].opcode != OP_LONG)
8943 error (_("Invalid operand to '%s"), ada_attribute_name (op));
8944 tem = longest_to_int (exp->elts[*pos + 2].longconst);
8947 if (noside == EVAL_SKIP)
8950 if (type_arg == NULL)
8952 arg1 = ada_coerce_ref (arg1);
8954 if (ada_is_packed_array_type (value_type (arg1)))
8955 arg1 = ada_coerce_to_simple_array (arg1);
8957 if (tem < 1 || tem > ada_array_arity (value_type (arg1)))
8958 error (_("invalid dimension number to '%s"),
8959 ada_attribute_name (op));
8961 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8963 type = ada_index_type (value_type (arg1), tem);
8966 (_("attempt to take bound of something that is not an array"));
8967 return allocate_value (type);
8972 default: /* Should never happen. */
8973 error (_("unexpected attribute encountered"));
8975 return ada_array_bound (arg1, tem, 0);
8977 return ada_array_bound (arg1, tem, 1);
8979 return ada_array_length (arg1, tem);
8982 else if (discrete_type_p (type_arg))
8984 struct type *range_type;
8985 char *name = ada_type_name (type_arg);
8987 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
8989 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
8990 if (range_type == NULL)
8991 range_type = type_arg;
8995 error (_("unexpected attribute encountered"));
8997 return value_from_longest
8998 (range_type, discrete_type_low_bound (range_type));
9000 return value_from_longest
9001 (range_type, discrete_type_high_bound (range_type));
9003 error (_("the 'length attribute applies only to array types"));
9006 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
9007 error (_("unimplemented type attribute"));
9012 if (ada_is_packed_array_type (type_arg))
9013 type_arg = decode_packed_array_type (type_arg);
9015 if (tem < 1 || tem > ada_array_arity (type_arg))
9016 error (_("invalid dimension number to '%s"),
9017 ada_attribute_name (op));
9019 type = ada_index_type (type_arg, tem);
9022 (_("attempt to take bound of something that is not an array"));
9023 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9024 return allocate_value (type);
9029 error (_("unexpected attribute encountered"));
9031 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
9032 return value_from_longest (type, low);
9034 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
9035 return value_from_longest (type, high);
9037 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
9038 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
9039 return value_from_longest (type, high - low + 1);
9045 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9046 if (noside == EVAL_SKIP)
9049 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9050 return value_zero (ada_tag_type (arg1), not_lval);
9052 return ada_value_tag (arg1);
9056 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9057 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9058 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9059 if (noside == EVAL_SKIP)
9061 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9062 return value_zero (value_type (arg1), not_lval);
9065 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9066 return value_binop (arg1, arg2,
9067 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
9070 case OP_ATR_MODULUS:
9072 struct type *type_arg = exp->elts[pc + 2].type;
9073 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9075 if (noside == EVAL_SKIP)
9078 if (!ada_is_modular_type (type_arg))
9079 error (_("'modulus must be applied to modular type"));
9081 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
9082 ada_modulus (type_arg));
9087 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9088 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9089 if (noside == EVAL_SKIP)
9091 type = builtin_type (exp->gdbarch)->builtin_int;
9092 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9093 return value_zero (type, not_lval);
9095 return value_pos_atr (type, arg1);
9098 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9099 type = value_type (arg1);
9101 /* If the argument is a reference, then dereference its type, since
9102 the user is really asking for the size of the actual object,
9103 not the size of the pointer. */
9104 if (TYPE_CODE (type) == TYPE_CODE_REF)
9105 type = TYPE_TARGET_TYPE (type);
9107 if (noside == EVAL_SKIP)
9109 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9110 return value_zero (builtin_type_int32, not_lval);
9112 return value_from_longest (builtin_type_int32,
9113 TARGET_CHAR_BIT * TYPE_LENGTH (type));
9116 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9117 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9118 type = exp->elts[pc + 2].type;
9119 if (noside == EVAL_SKIP)
9121 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9122 return value_zero (type, not_lval);
9124 return value_val_atr (type, arg1);
9127 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9128 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9129 if (noside == EVAL_SKIP)
9131 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9132 return value_zero (value_type (arg1), not_lval);
9135 /* For integer exponentiation operations,
9136 only promote the first argument. */
9137 if (is_integral_type (value_type (arg2)))
9138 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9140 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
9142 return value_binop (arg1, arg2, op);
9146 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9147 if (noside == EVAL_SKIP)
9153 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9154 if (noside == EVAL_SKIP)
9156 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
9157 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
9158 return value_neg (arg1);
9163 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9164 if (noside == EVAL_SKIP)
9166 type = ada_check_typedef (value_type (arg1));
9167 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9169 if (ada_is_array_descriptor_type (type))
9170 /* GDB allows dereferencing GNAT array descriptors. */
9172 struct type *arrType = ada_type_of_array (arg1, 0);
9173 if (arrType == NULL)
9174 error (_("Attempt to dereference null array pointer."));
9175 return value_at_lazy (arrType, 0);
9177 else if (TYPE_CODE (type) == TYPE_CODE_PTR
9178 || TYPE_CODE (type) == TYPE_CODE_REF
9179 /* In C you can dereference an array to get the 1st elt. */
9180 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
9182 type = to_static_fixed_type
9184 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
9186 return value_zero (type, lval_memory);
9188 else if (TYPE_CODE (type) == TYPE_CODE_INT)
9190 /* GDB allows dereferencing an int. */
9191 if (expect_type == NULL)
9192 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
9197 to_static_fixed_type (ada_aligned_type (expect_type));
9198 return value_zero (expect_type, lval_memory);
9202 error (_("Attempt to take contents of a non-pointer value."));
9204 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
9205 type = ada_check_typedef (value_type (arg1));
9207 if (TYPE_CODE (type) == TYPE_CODE_INT && expect_type != NULL)
9208 /* GDB allows dereferencing an int. We give it the expected
9209 type (which will be set in the case of a coercion or
9211 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
9214 if (ada_is_array_descriptor_type (type))
9215 /* GDB allows dereferencing GNAT array descriptors. */
9216 return ada_coerce_to_simple_array (arg1);
9218 return ada_value_ind (arg1);
9220 case STRUCTOP_STRUCT:
9221 tem = longest_to_int (exp->elts[pc + 1].longconst);
9222 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
9223 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9224 if (noside == EVAL_SKIP)
9226 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9228 struct type *type1 = value_type (arg1);
9229 if (ada_is_tagged_type (type1, 1))
9231 type = ada_lookup_struct_elt_type (type1,
9232 &exp->elts[pc + 2].string,
9235 /* In this case, we assume that the field COULD exist
9236 in some extension of the type. Return an object of
9237 "type" void, which will match any formal
9238 (see ada_type_match). */
9239 return value_zero (builtin_type_void, lval_memory);
9243 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
9246 return value_zero (ada_aligned_type (type), lval_memory);
9250 ada_to_fixed_value (unwrap_value
9251 (ada_value_struct_elt
9252 (arg1, &exp->elts[pc + 2].string, 0)));
9254 /* The value is not supposed to be used. This is here to make it
9255 easier to accommodate expressions that contain types. */
9257 if (noside == EVAL_SKIP)
9259 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9260 return allocate_value (exp->elts[pc + 1].type);
9262 error (_("Attempt to use a type name as an expression"));
9267 case OP_DISCRETE_RANGE:
9270 if (noside == EVAL_NORMAL)
9274 error (_("Undefined name, ambiguous name, or renaming used in "
9275 "component association: %s."), &exp->elts[pc+2].string);
9277 error (_("Aggregates only allowed on the right of an assignment"));
9279 internal_error (__FILE__, __LINE__, _("aggregate apparently mangled"));
9282 ada_forward_operator_length (exp, pc, &oplen, &nargs);
9284 for (tem = 0; tem < nargs; tem += 1)
9285 ada_evaluate_subexp (NULL, exp, pos, noside);
9290 return value_from_longest (builtin_type_int8, (LONGEST) 1);
9296 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9297 type name that encodes the 'small and 'delta information.
9298 Otherwise, return NULL. */
9301 fixed_type_info (struct type *type)
9303 const char *name = ada_type_name (type);
9304 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
9306 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
9308 const char *tail = strstr (name, "___XF_");
9314 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
9315 return fixed_type_info (TYPE_TARGET_TYPE (type));
9320 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9323 ada_is_fixed_point_type (struct type *type)
9325 return fixed_type_info (type) != NULL;
9328 /* Return non-zero iff TYPE represents a System.Address type. */
9331 ada_is_system_address_type (struct type *type)
9333 return (TYPE_NAME (type)
9334 && strcmp (TYPE_NAME (type), "system__address") == 0);
9337 /* Assuming that TYPE is the representation of an Ada fixed-point
9338 type, return its delta, or -1 if the type is malformed and the
9339 delta cannot be determined. */
9342 ada_delta (struct type *type)
9344 const char *encoding = fixed_type_info (type);
9347 if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
9350 return (DOUBLEST) num / (DOUBLEST) den;
9353 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9354 factor ('SMALL value) associated with the type. */
9357 scaling_factor (struct type *type)
9359 const char *encoding = fixed_type_info (type);
9360 unsigned long num0, den0, num1, den1;
9363 n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);
9368 return (DOUBLEST) num1 / (DOUBLEST) den1;
9370 return (DOUBLEST) num0 / (DOUBLEST) den0;
9374 /* Assuming that X is the representation of a value of fixed-point
9375 type TYPE, return its floating-point equivalent. */
9378 ada_fixed_to_float (struct type *type, LONGEST x)
9380 return (DOUBLEST) x *scaling_factor (type);
9383 /* The representation of a fixed-point value of type TYPE
9384 corresponding to the value X. */
9387 ada_float_to_fixed (struct type *type, DOUBLEST x)
9389 return (LONGEST) (x / scaling_factor (type) + 0.5);
9393 /* VAX floating formats */
9395 /* Non-zero iff TYPE represents one of the special VAX floating-point
9399 ada_is_vax_floating_type (struct type *type)
9402 (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
9405 && (TYPE_CODE (type) == TYPE_CODE_INT
9406 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9407 && strncmp (ada_type_name (type) + name_len - 6, "___XF", 5) == 0;
9410 /* The type of special VAX floating-point type this is, assuming
9411 ada_is_vax_floating_point. */
9414 ada_vax_float_type_suffix (struct type *type)
9416 return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
9419 /* A value representing the special debugging function that outputs
9420 VAX floating-point values of the type represented by TYPE. Assumes
9421 ada_is_vax_floating_type (TYPE). */
9424 ada_vax_float_print_function (struct type *type)
9426 switch (ada_vax_float_type_suffix (type))
9429 return get_var_value ("DEBUG_STRING_F", 0);
9431 return get_var_value ("DEBUG_STRING_D", 0);
9433 return get_var_value ("DEBUG_STRING_G", 0);
9435 error (_("invalid VAX floating-point type"));
9442 /* Scan STR beginning at position K for a discriminant name, and
9443 return the value of that discriminant field of DVAL in *PX. If
9444 PNEW_K is not null, put the position of the character beyond the
9445 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9446 not alter *PX and *PNEW_K if unsuccessful. */
9449 scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
9452 static char *bound_buffer = NULL;
9453 static size_t bound_buffer_len = 0;
9456 struct value *bound_val;
9458 if (dval == NULL || str == NULL || str[k] == '\0')
9461 pend = strstr (str + k, "__");
9465 k += strlen (bound);
9469 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
9470 bound = bound_buffer;
9471 strncpy (bound_buffer, str + k, pend - (str + k));
9472 bound[pend - (str + k)] = '\0';
9476 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
9477 if (bound_val == NULL)
9480 *px = value_as_long (bound_val);
9486 /* Value of variable named NAME in the current environment. If
9487 no such variable found, then if ERR_MSG is null, returns 0, and
9488 otherwise causes an error with message ERR_MSG. */
9490 static struct value *
9491 get_var_value (char *name, char *err_msg)
9493 struct ada_symbol_info *syms;
9496 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
9501 if (err_msg == NULL)
9504 error (("%s"), err_msg);
9507 return value_of_variable (syms[0].sym, syms[0].block);
9510 /* Value of integer variable named NAME in the current environment. If
9511 no such variable found, returns 0, and sets *FLAG to 0. If
9512 successful, sets *FLAG to 1. */
9515 get_int_var_value (char *name, int *flag)
9517 struct value *var_val = get_var_value (name, 0);
9529 return value_as_long (var_val);
9534 /* Return a range type whose base type is that of the range type named
9535 NAME in the current environment, and whose bounds are calculated
9536 from NAME according to the GNAT range encoding conventions.
9537 Extract discriminant values, if needed, from DVAL. If a new type
9538 must be created, allocate in OBJFILE's space. The bounds
9539 information, in general, is encoded in NAME, the base type given in
9540 the named range type. */
9542 static struct type *
9543 to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
9545 struct type *raw_type = ada_find_any_type (name);
9546 struct type *base_type;
9549 if (raw_type == NULL)
9550 base_type = builtin_type_int32;
9551 else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
9552 base_type = TYPE_TARGET_TYPE (raw_type);
9554 base_type = raw_type;
9556 subtype_info = strstr (name, "___XD");
9557 if (subtype_info == NULL)
9559 LONGEST L = discrete_type_low_bound (raw_type);
9560 LONGEST U = discrete_type_high_bound (raw_type);
9561 if (L < INT_MIN || U > INT_MAX)
9564 return create_range_type (alloc_type (objfile), raw_type,
9565 discrete_type_low_bound (raw_type),
9566 discrete_type_high_bound (raw_type));
9570 static char *name_buf = NULL;
9571 static size_t name_len = 0;
9572 int prefix_len = subtype_info - name;
9578 GROW_VECT (name_buf, name_len, prefix_len + 5);
9579 strncpy (name_buf, name, prefix_len);
9580 name_buf[prefix_len] = '\0';
9583 bounds_str = strchr (subtype_info, '_');
9586 if (*subtype_info == 'L')
9588 if (!ada_scan_number (bounds_str, n, &L, &n)
9589 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
9591 if (bounds_str[n] == '_')
9593 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
9600 strcpy (name_buf + prefix_len, "___L");
9601 L = get_int_var_value (name_buf, &ok);
9604 lim_warning (_("Unknown lower bound, using 1."));
9609 if (*subtype_info == 'U')
9611 if (!ada_scan_number (bounds_str, n, &U, &n)
9612 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
9618 strcpy (name_buf + prefix_len, "___U");
9619 U = get_int_var_value (name_buf, &ok);
9622 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
9627 if (objfile == NULL)
9628 objfile = TYPE_OBJFILE (base_type);
9629 type = create_range_type (alloc_type (objfile), base_type, L, U);
9630 TYPE_NAME (type) = name;
9635 /* True iff NAME is the name of a range type. */
9638 ada_is_range_type_name (const char *name)
9640 return (name != NULL && strstr (name, "___XD"));
9646 /* True iff TYPE is an Ada modular type. */
9649 ada_is_modular_type (struct type *type)
9651 struct type *subranged_type = base_type (type);
9653 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
9654 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
9655 && TYPE_UNSIGNED (subranged_type));
9658 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9661 ada_modulus (struct type * type)
9663 return (ULONGEST) (unsigned int) TYPE_HIGH_BOUND (type) + 1;
9667 /* Ada exception catchpoint support:
9668 ---------------------------------
9670 We support 3 kinds of exception catchpoints:
9671 . catchpoints on Ada exceptions
9672 . catchpoints on unhandled Ada exceptions
9673 . catchpoints on failed assertions
9675 Exceptions raised during failed assertions, or unhandled exceptions
9676 could perfectly be caught with the general catchpoint on Ada exceptions.
9677 However, we can easily differentiate these two special cases, and having
9678 the option to distinguish these two cases from the rest can be useful
9679 to zero-in on certain situations.
9681 Exception catchpoints are a specialized form of breakpoint,
9682 since they rely on inserting breakpoints inside known routines
9683 of the GNAT runtime. The implementation therefore uses a standard
9684 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9687 Support in the runtime for exception catchpoints have been changed
9688 a few times already, and these changes affect the implementation
9689 of these catchpoints. In order to be able to support several
9690 variants of the runtime, we use a sniffer that will determine
9691 the runtime variant used by the program being debugged.
9693 At this time, we do not support the use of conditions on Ada exception
9694 catchpoints. The COND and COND_STRING fields are therefore set
9695 to NULL (most of the time, see below).
9697 Conditions where EXP_STRING, COND, and COND_STRING are used:
9699 When a user specifies the name of a specific exception in the case
9700 of catchpoints on Ada exceptions, we store the name of that exception
9701 in the EXP_STRING. We then translate this request into an actual
9702 condition stored in COND_STRING, and then parse it into an expression
9705 /* The different types of catchpoints that we introduced for catching
9708 enum exception_catchpoint_kind
9711 ex_catch_exception_unhandled,
9715 /* Ada's standard exceptions. */
9717 static char *standard_exc[] = {
9724 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
9726 /* A structure that describes how to support exception catchpoints
9727 for a given executable. */
9729 struct exception_support_info
9731 /* The name of the symbol to break on in order to insert
9732 a catchpoint on exceptions. */
9733 const char *catch_exception_sym;
9735 /* The name of the symbol to break on in order to insert
9736 a catchpoint on unhandled exceptions. */
9737 const char *catch_exception_unhandled_sym;
9739 /* The name of the symbol to break on in order to insert
9740 a catchpoint on failed assertions. */
9741 const char *catch_assert_sym;
9743 /* Assuming that the inferior just triggered an unhandled exception
9744 catchpoint, this function is responsible for returning the address
9745 in inferior memory where the name of that exception is stored.
9746 Return zero if the address could not be computed. */
9747 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
9750 static CORE_ADDR ada_unhandled_exception_name_addr (void);
9751 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
9753 /* The following exception support info structure describes how to
9754 implement exception catchpoints with the latest version of the
9755 Ada runtime (as of 2007-03-06). */
9757 static const struct exception_support_info default_exception_support_info =
9759 "__gnat_debug_raise_exception", /* catch_exception_sym */
9760 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9761 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9762 ada_unhandled_exception_name_addr
9765 /* The following exception support info structure describes how to
9766 implement exception catchpoints with a slightly older version
9767 of the Ada runtime. */
9769 static const struct exception_support_info exception_support_info_fallback =
9771 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9772 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9773 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9774 ada_unhandled_exception_name_addr_from_raise
9777 /* For each executable, we sniff which exception info structure to use
9778 and cache it in the following global variable. */
9780 static const struct exception_support_info *exception_info = NULL;
9782 /* Inspect the Ada runtime and determine which exception info structure
9783 should be used to provide support for exception catchpoints.
9785 This function will always set exception_info, or raise an error. */
9788 ada_exception_support_info_sniffer (void)
9792 /* If the exception info is already known, then no need to recompute it. */
9793 if (exception_info != NULL)
9796 /* Check the latest (default) exception support info. */
9797 sym = standard_lookup (default_exception_support_info.catch_exception_sym,
9801 exception_info = &default_exception_support_info;
9805 /* Try our fallback exception suport info. */
9806 sym = standard_lookup (exception_support_info_fallback.catch_exception_sym,
9810 exception_info = &exception_support_info_fallback;
9814 /* Sometimes, it is normal for us to not be able to find the routine
9815 we are looking for. This happens when the program is linked with
9816 the shared version of the GNAT runtime, and the program has not been
9817 started yet. Inform the user of these two possible causes if
9820 if (ada_update_initial_language (language_unknown, NULL) != language_ada)
9821 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9823 /* If the symbol does not exist, then check that the program is
9824 already started, to make sure that shared libraries have been
9825 loaded. If it is not started, this may mean that the symbol is
9826 in a shared library. */
9828 if (ptid_get_pid (inferior_ptid) == 0)
9829 error (_("Unable to insert catchpoint. Try to start the program first."));
9831 /* At this point, we know that we are debugging an Ada program and
9832 that the inferior has been started, but we still are not able to
9833 find the run-time symbols. That can mean that we are in
9834 configurable run time mode, or that a-except as been optimized
9835 out by the linker... In any case, at this point it is not worth
9836 supporting this feature. */
9838 error (_("Cannot insert catchpoints in this configuration."));
9841 /* An observer of "executable_changed" events.
9842 Its role is to clear certain cached values that need to be recomputed
9843 each time a new executable is loaded by GDB. */
9846 ada_executable_changed_observer (void)
9848 /* If the executable changed, then it is possible that the Ada runtime
9849 is different. So we need to invalidate the exception support info
9851 exception_info = NULL;
9854 /* Return the name of the function at PC, NULL if could not find it.
9855 This function only checks the debugging information, not the symbol
9859 function_name_from_pc (CORE_ADDR pc)
9863 if (!find_pc_partial_function (pc, &func_name, NULL, NULL))
9869 /* True iff FRAME is very likely to be that of a function that is
9870 part of the runtime system. This is all very heuristic, but is
9871 intended to be used as advice as to what frames are uninteresting
9875 is_known_support_routine (struct frame_info *frame)
9877 struct symtab_and_line sal;
9881 /* If this code does not have any debugging information (no symtab),
9882 This cannot be any user code. */
9884 find_frame_sal (frame, &sal);
9885 if (sal.symtab == NULL)
9888 /* If there is a symtab, but the associated source file cannot be
9889 located, then assume this is not user code: Selecting a frame
9890 for which we cannot display the code would not be very helpful
9891 for the user. This should also take care of case such as VxWorks
9892 where the kernel has some debugging info provided for a few units. */
9894 if (symtab_to_fullname (sal.symtab) == NULL)
9897 /* Check the unit filename againt the Ada runtime file naming.
9898 We also check the name of the objfile against the name of some
9899 known system libraries that sometimes come with debugging info
9902 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
9904 re_comp (known_runtime_file_name_patterns[i]);
9905 if (re_exec (sal.symtab->filename))
9907 if (sal.symtab->objfile != NULL
9908 && re_exec (sal.symtab->objfile->name))
9912 /* Check whether the function is a GNAT-generated entity. */
9914 func_name = function_name_from_pc (get_frame_address_in_block (frame));
9915 if (func_name == NULL)
9918 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
9920 re_comp (known_auxiliary_function_name_patterns[i]);
9921 if (re_exec (func_name))
9928 /* Find the first frame that contains debugging information and that is not
9929 part of the Ada run-time, starting from FI and moving upward. */
9932 ada_find_printable_frame (struct frame_info *fi)
9934 for (; fi != NULL; fi = get_prev_frame (fi))
9936 if (!is_known_support_routine (fi))
9945 /* Assuming that the inferior just triggered an unhandled exception
9946 catchpoint, return the address in inferior memory where the name
9947 of the exception is stored.
9949 Return zero if the address could not be computed. */
9952 ada_unhandled_exception_name_addr (void)
9954 return parse_and_eval_address ("e.full_name");
9957 /* Same as ada_unhandled_exception_name_addr, except that this function
9958 should be used when the inferior uses an older version of the runtime,
9959 where the exception name needs to be extracted from a specific frame
9960 several frames up in the callstack. */
9963 ada_unhandled_exception_name_addr_from_raise (void)
9966 struct frame_info *fi;
9968 /* To determine the name of this exception, we need to select
9969 the frame corresponding to RAISE_SYM_NAME. This frame is
9970 at least 3 levels up, so we simply skip the first 3 frames
9971 without checking the name of their associated function. */
9972 fi = get_current_frame ();
9973 for (frame_level = 0; frame_level < 3; frame_level += 1)
9975 fi = get_prev_frame (fi);
9979 const char *func_name =
9980 function_name_from_pc (get_frame_address_in_block (fi));
9981 if (func_name != NULL
9982 && strcmp (func_name, exception_info->catch_exception_sym) == 0)
9983 break; /* We found the frame we were looking for... */
9984 fi = get_prev_frame (fi);
9991 return parse_and_eval_address ("id.full_name");
9994 /* Assuming the inferior just triggered an Ada exception catchpoint
9995 (of any type), return the address in inferior memory where the name
9996 of the exception is stored, if applicable.
9998 Return zero if the address could not be computed, or if not relevant. */
10001 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex,
10002 struct breakpoint *b)
10006 case ex_catch_exception:
10007 return (parse_and_eval_address ("e.full_name"));
10010 case ex_catch_exception_unhandled:
10011 return exception_info->unhandled_exception_name_addr ();
10014 case ex_catch_assert:
10015 return 0; /* Exception name is not relevant in this case. */
10019 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10023 return 0; /* Should never be reached. */
10026 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
10027 any error that ada_exception_name_addr_1 might cause to be thrown.
10028 When an error is intercepted, a warning with the error message is printed,
10029 and zero is returned. */
10032 ada_exception_name_addr (enum exception_catchpoint_kind ex,
10033 struct breakpoint *b)
10035 struct gdb_exception e;
10036 CORE_ADDR result = 0;
10038 TRY_CATCH (e, RETURN_MASK_ERROR)
10040 result = ada_exception_name_addr_1 (ex, b);
10045 warning (_("failed to get exception name: %s"), e.message);
10052 /* Implement the PRINT_IT method in the breakpoint_ops structure
10053 for all exception catchpoint kinds. */
10055 static enum print_stop_action
10056 print_it_exception (enum exception_catchpoint_kind ex, struct breakpoint *b)
10058 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
10059 char exception_name[256];
10063 read_memory (addr, exception_name, sizeof (exception_name) - 1);
10064 exception_name [sizeof (exception_name) - 1] = '\0';
10067 ada_find_printable_frame (get_current_frame ());
10069 annotate_catchpoint (b->number);
10072 case ex_catch_exception:
10074 printf_filtered (_("\nCatchpoint %d, %s at "),
10075 b->number, exception_name);
10077 printf_filtered (_("\nCatchpoint %d, exception at "), b->number);
10079 case ex_catch_exception_unhandled:
10081 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10082 b->number, exception_name);
10084 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10087 case ex_catch_assert:
10088 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10093 return PRINT_SRC_AND_LOC;
10096 /* Implement the PRINT_ONE method in the breakpoint_ops structure
10097 for all exception catchpoint kinds. */
10100 print_one_exception (enum exception_catchpoint_kind ex,
10101 struct breakpoint *b, CORE_ADDR *last_addr)
10105 annotate_field (4);
10106 ui_out_field_core_addr (uiout, "addr", b->loc->address);
10109 annotate_field (5);
10110 *last_addr = b->loc->address;
10113 case ex_catch_exception:
10114 if (b->exp_string != NULL)
10116 char *msg = xstrprintf (_("`%s' Ada exception"), b->exp_string);
10118 ui_out_field_string (uiout, "what", msg);
10122 ui_out_field_string (uiout, "what", "all Ada exceptions");
10126 case ex_catch_exception_unhandled:
10127 ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
10130 case ex_catch_assert:
10131 ui_out_field_string (uiout, "what", "failed Ada assertions");
10135 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10140 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
10141 for all exception catchpoint kinds. */
10144 print_mention_exception (enum exception_catchpoint_kind ex,
10145 struct breakpoint *b)
10149 case ex_catch_exception:
10150 if (b->exp_string != NULL)
10151 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10152 b->number, b->exp_string);
10154 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b->number);
10158 case ex_catch_exception_unhandled:
10159 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10163 case ex_catch_assert:
10164 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b->number);
10168 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
10173 /* Virtual table for "catch exception" breakpoints. */
10175 static enum print_stop_action
10176 print_it_catch_exception (struct breakpoint *b)
10178 return print_it_exception (ex_catch_exception, b);
10182 print_one_catch_exception (struct breakpoint *b, CORE_ADDR *last_addr)
10184 print_one_exception (ex_catch_exception, b, last_addr);
10188 print_mention_catch_exception (struct breakpoint *b)
10190 print_mention_exception (ex_catch_exception, b);
10193 static struct breakpoint_ops catch_exception_breakpoint_ops =
10197 NULL, /* breakpoint_hit */
10198 print_it_catch_exception,
10199 print_one_catch_exception,
10200 print_mention_catch_exception
10203 /* Virtual table for "catch exception unhandled" breakpoints. */
10205 static enum print_stop_action
10206 print_it_catch_exception_unhandled (struct breakpoint *b)
10208 return print_it_exception (ex_catch_exception_unhandled, b);
10212 print_one_catch_exception_unhandled (struct breakpoint *b, CORE_ADDR *last_addr)
10214 print_one_exception (ex_catch_exception_unhandled, b, last_addr);
10218 print_mention_catch_exception_unhandled (struct breakpoint *b)
10220 print_mention_exception (ex_catch_exception_unhandled, b);
10223 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops = {
10226 NULL, /* breakpoint_hit */
10227 print_it_catch_exception_unhandled,
10228 print_one_catch_exception_unhandled,
10229 print_mention_catch_exception_unhandled
10232 /* Virtual table for "catch assert" breakpoints. */
10234 static enum print_stop_action
10235 print_it_catch_assert (struct breakpoint *b)
10237 return print_it_exception (ex_catch_assert, b);
10241 print_one_catch_assert (struct breakpoint *b, CORE_ADDR *last_addr)
10243 print_one_exception (ex_catch_assert, b, last_addr);
10247 print_mention_catch_assert (struct breakpoint *b)
10249 print_mention_exception (ex_catch_assert, b);
10252 static struct breakpoint_ops catch_assert_breakpoint_ops = {
10255 NULL, /* breakpoint_hit */
10256 print_it_catch_assert,
10257 print_one_catch_assert,
10258 print_mention_catch_assert
10261 /* Return non-zero if B is an Ada exception catchpoint. */
10264 ada_exception_catchpoint_p (struct breakpoint *b)
10266 return (b->ops == &catch_exception_breakpoint_ops
10267 || b->ops == &catch_exception_unhandled_breakpoint_ops
10268 || b->ops == &catch_assert_breakpoint_ops);
10271 /* Return a newly allocated copy of the first space-separated token
10272 in ARGSP, and then adjust ARGSP to point immediately after that
10275 Return NULL if ARGPS does not contain any more tokens. */
10278 ada_get_next_arg (char **argsp)
10280 char *args = *argsp;
10284 /* Skip any leading white space. */
10286 while (isspace (*args))
10289 if (args[0] == '\0')
10290 return NULL; /* No more arguments. */
10292 /* Find the end of the current argument. */
10295 while (*end != '\0' && !isspace (*end))
10298 /* Adjust ARGSP to point to the start of the next argument. */
10302 /* Make a copy of the current argument and return it. */
10304 result = xmalloc (end - args + 1);
10305 strncpy (result, args, end - args);
10306 result[end - args] = '\0';
10311 /* Split the arguments specified in a "catch exception" command.
10312 Set EX to the appropriate catchpoint type.
10313 Set EXP_STRING to the name of the specific exception if
10314 specified by the user. */
10317 catch_ada_exception_command_split (char *args,
10318 enum exception_catchpoint_kind *ex,
10321 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
10322 char *exception_name;
10324 exception_name = ada_get_next_arg (&args);
10325 make_cleanup (xfree, exception_name);
10327 /* Check that we do not have any more arguments. Anything else
10330 while (isspace (*args))
10333 if (args[0] != '\0')
10334 error (_("Junk at end of expression"));
10336 discard_cleanups (old_chain);
10338 if (exception_name == NULL)
10340 /* Catch all exceptions. */
10341 *ex = ex_catch_exception;
10342 *exp_string = NULL;
10344 else if (strcmp (exception_name, "unhandled") == 0)
10346 /* Catch unhandled exceptions. */
10347 *ex = ex_catch_exception_unhandled;
10348 *exp_string = NULL;
10352 /* Catch a specific exception. */
10353 *ex = ex_catch_exception;
10354 *exp_string = exception_name;
10358 /* Return the name of the symbol on which we should break in order to
10359 implement a catchpoint of the EX kind. */
10361 static const char *
10362 ada_exception_sym_name (enum exception_catchpoint_kind ex)
10364 gdb_assert (exception_info != NULL);
10368 case ex_catch_exception:
10369 return (exception_info->catch_exception_sym);
10371 case ex_catch_exception_unhandled:
10372 return (exception_info->catch_exception_unhandled_sym);
10374 case ex_catch_assert:
10375 return (exception_info->catch_assert_sym);
10378 internal_error (__FILE__, __LINE__,
10379 _("unexpected catchpoint kind (%d)"), ex);
10383 /* Return the breakpoint ops "virtual table" used for catchpoints
10386 static struct breakpoint_ops *
10387 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex)
10391 case ex_catch_exception:
10392 return (&catch_exception_breakpoint_ops);
10394 case ex_catch_exception_unhandled:
10395 return (&catch_exception_unhandled_breakpoint_ops);
10397 case ex_catch_assert:
10398 return (&catch_assert_breakpoint_ops);
10401 internal_error (__FILE__, __LINE__,
10402 _("unexpected catchpoint kind (%d)"), ex);
10406 /* Return the condition that will be used to match the current exception
10407 being raised with the exception that the user wants to catch. This
10408 assumes that this condition is used when the inferior just triggered
10409 an exception catchpoint.
10411 The string returned is a newly allocated string that needs to be
10412 deallocated later. */
10415 ada_exception_catchpoint_cond_string (const char *exp_string)
10419 /* The standard exceptions are a special case. They are defined in
10420 runtime units that have been compiled without debugging info; if
10421 EXP_STRING is the not-fully-qualified name of a standard
10422 exception (e.g. "constraint_error") then, during the evaluation
10423 of the condition expression, the symbol lookup on this name would
10424 *not* return this standard exception. The catchpoint condition
10425 may then be set only on user-defined exceptions which have the
10426 same not-fully-qualified name (e.g. my_package.constraint_error).
10428 To avoid this unexcepted behavior, these standard exceptions are
10429 systematically prefixed by "standard". This means that "catch
10430 exception constraint_error" is rewritten into "catch exception
10431 standard.constraint_error".
10433 If an exception named contraint_error is defined in another package of
10434 the inferior program, then the only way to specify this exception as a
10435 breakpoint condition is to use its fully-qualified named:
10436 e.g. my_package.constraint_error. */
10438 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
10440 if (strcmp (standard_exc [i], exp_string) == 0)
10442 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
10446 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string);
10449 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
10451 static struct expression *
10452 ada_parse_catchpoint_condition (char *cond_string,
10453 struct symtab_and_line sal)
10455 return (parse_exp_1 (&cond_string, block_for_pc (sal.pc), 0));
10458 /* Return the symtab_and_line that should be used to insert an exception
10459 catchpoint of the TYPE kind.
10461 EX_STRING should contain the name of a specific exception
10462 that the catchpoint should catch, or NULL otherwise.
10464 The idea behind all the remaining parameters is that their names match
10465 the name of certain fields in the breakpoint structure that are used to
10466 handle exception catchpoints. This function returns the value to which
10467 these fields should be set, depending on the type of catchpoint we need
10470 If COND and COND_STRING are both non-NULL, any value they might
10471 hold will be free'ed, and then replaced by newly allocated ones.
10472 These parameters are left untouched otherwise. */
10474 static struct symtab_and_line
10475 ada_exception_sal (enum exception_catchpoint_kind ex, char *exp_string,
10476 char **addr_string, char **cond_string,
10477 struct expression **cond, struct breakpoint_ops **ops)
10479 const char *sym_name;
10480 struct symbol *sym;
10481 struct symtab_and_line sal;
10483 /* First, find out which exception support info to use. */
10484 ada_exception_support_info_sniffer ();
10486 /* Then lookup the function on which we will break in order to catch
10487 the Ada exceptions requested by the user. */
10489 sym_name = ada_exception_sym_name (ex);
10490 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
10492 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10493 that should be compiled with debugging information. As a result, we
10494 expect to find that symbol in the symtabs. If we don't find it, then
10495 the target most likely does not support Ada exceptions, or we cannot
10496 insert exception breakpoints yet, because the GNAT runtime hasn't been
10499 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10500 in such a way that no debugging information is produced for the symbol
10501 we are looking for. In this case, we could search the minimal symbols
10502 as a fall-back mechanism. This would still be operating in degraded
10503 mode, however, as we would still be missing the debugging information
10504 that is needed in order to extract the name of the exception being
10505 raised (this name is printed in the catchpoint message, and is also
10506 used when trying to catch a specific exception). We do not handle
10507 this case for now. */
10510 error (_("Unable to break on '%s' in this configuration."), sym_name);
10512 /* Make sure that the symbol we found corresponds to a function. */
10513 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
10514 error (_("Symbol \"%s\" is not a function (class = %d)"),
10515 sym_name, SYMBOL_CLASS (sym));
10517 sal = find_function_start_sal (sym, 1);
10519 /* Set ADDR_STRING. */
10521 *addr_string = xstrdup (sym_name);
10523 /* Set the COND and COND_STRING (if not NULL). */
10525 if (cond_string != NULL && cond != NULL)
10527 if (*cond_string != NULL)
10529 xfree (*cond_string);
10530 *cond_string = NULL;
10537 if (exp_string != NULL)
10539 *cond_string = ada_exception_catchpoint_cond_string (exp_string);
10540 *cond = ada_parse_catchpoint_condition (*cond_string, sal);
10545 *ops = ada_exception_breakpoint_ops (ex);
10550 /* Parse the arguments (ARGS) of the "catch exception" command.
10552 Set TYPE to the appropriate exception catchpoint type.
10553 If the user asked the catchpoint to catch only a specific
10554 exception, then save the exception name in ADDR_STRING.
10556 See ada_exception_sal for a description of all the remaining
10557 function arguments of this function. */
10559 struct symtab_and_line
10560 ada_decode_exception_location (char *args, char **addr_string,
10561 char **exp_string, char **cond_string,
10562 struct expression **cond,
10563 struct breakpoint_ops **ops)
10565 enum exception_catchpoint_kind ex;
10567 catch_ada_exception_command_split (args, &ex, exp_string);
10568 return ada_exception_sal (ex, *exp_string, addr_string, cond_string,
10572 struct symtab_and_line
10573 ada_decode_assert_location (char *args, char **addr_string,
10574 struct breakpoint_ops **ops)
10576 /* Check that no argument where provided at the end of the command. */
10580 while (isspace (*args))
10583 error (_("Junk at end of arguments."));
10586 return ada_exception_sal (ex_catch_assert, NULL, addr_string, NULL, NULL,
10591 /* Information about operators given special treatment in functions
10593 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10595 #define ADA_OPERATORS \
10596 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10597 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10598 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10599 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10600 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10601 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10602 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10603 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10604 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10605 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10606 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10607 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10608 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10609 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10610 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
10611 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10612 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10613 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10614 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
10617 ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp)
10619 switch (exp->elts[pc - 1].opcode)
10622 operator_length_standard (exp, pc, oplenp, argsp);
10625 #define OP_DEFN(op, len, args, binop) \
10626 case op: *oplenp = len; *argsp = args; break;
10632 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
10637 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
10643 ada_op_name (enum exp_opcode opcode)
10648 return op_name_standard (opcode);
10650 #define OP_DEFN(op, len, args, binop) case op: return #op;
10655 return "OP_AGGREGATE";
10657 return "OP_CHOICES";
10663 /* As for operator_length, but assumes PC is pointing at the first
10664 element of the operator, and gives meaningful results only for the
10665 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
10668 ada_forward_operator_length (struct expression *exp, int pc,
10669 int *oplenp, int *argsp)
10671 switch (exp->elts[pc].opcode)
10674 *oplenp = *argsp = 0;
10677 #define OP_DEFN(op, len, args, binop) \
10678 case op: *oplenp = len; *argsp = args; break;
10684 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
10689 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
10695 int len = longest_to_int (exp->elts[pc + 1].longconst);
10696 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
10704 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
10706 enum exp_opcode op = exp->elts[elt].opcode;
10711 ada_forward_operator_length (exp, elt, &oplen, &nargs);
10715 /* Ada attributes ('Foo). */
10718 case OP_ATR_LENGTH:
10722 case OP_ATR_MODULUS:
10729 case UNOP_IN_RANGE:
10731 /* XXX: gdb_sprint_host_address, type_sprint */
10732 fprintf_filtered (stream, _("Type @"));
10733 gdb_print_host_address (exp->elts[pc + 1].type, stream);
10734 fprintf_filtered (stream, " (");
10735 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
10736 fprintf_filtered (stream, ")");
10738 case BINOP_IN_BOUNDS:
10739 fprintf_filtered (stream, " (%d)",
10740 longest_to_int (exp->elts[pc + 2].longconst));
10742 case TERNOP_IN_RANGE:
10747 case OP_DISCRETE_RANGE:
10748 case OP_POSITIONAL:
10755 char *name = &exp->elts[elt + 2].string;
10756 int len = longest_to_int (exp->elts[elt + 1].longconst);
10757 fprintf_filtered (stream, "Text: `%.*s'", len, name);
10762 return dump_subexp_body_standard (exp, stream, elt);
10766 for (i = 0; i < nargs; i += 1)
10767 elt = dump_subexp (exp, stream, elt);
10772 /* The Ada extension of print_subexp (q.v.). */
10775 ada_print_subexp (struct expression *exp, int *pos,
10776 struct ui_file *stream, enum precedence prec)
10778 int oplen, nargs, i;
10780 enum exp_opcode op = exp->elts[pc].opcode;
10782 ada_forward_operator_length (exp, pc, &oplen, &nargs);
10789 print_subexp_standard (exp, pos, stream, prec);
10793 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
10796 case BINOP_IN_BOUNDS:
10797 /* XXX: sprint_subexp */
10798 print_subexp (exp, pos, stream, PREC_SUFFIX);
10799 fputs_filtered (" in ", stream);
10800 print_subexp (exp, pos, stream, PREC_SUFFIX);
10801 fputs_filtered ("'range", stream);
10802 if (exp->elts[pc + 1].longconst > 1)
10803 fprintf_filtered (stream, "(%ld)",
10804 (long) exp->elts[pc + 1].longconst);
10807 case TERNOP_IN_RANGE:
10808 if (prec >= PREC_EQUAL)
10809 fputs_filtered ("(", stream);
10810 /* XXX: sprint_subexp */
10811 print_subexp (exp, pos, stream, PREC_SUFFIX);
10812 fputs_filtered (" in ", stream);
10813 print_subexp (exp, pos, stream, PREC_EQUAL);
10814 fputs_filtered (" .. ", stream);
10815 print_subexp (exp, pos, stream, PREC_EQUAL);
10816 if (prec >= PREC_EQUAL)
10817 fputs_filtered (")", stream);
10822 case OP_ATR_LENGTH:
10826 case OP_ATR_MODULUS:
10831 if (exp->elts[*pos].opcode == OP_TYPE)
10833 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
10834 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
10838 print_subexp (exp, pos, stream, PREC_SUFFIX);
10839 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
10843 for (tem = 1; tem < nargs; tem += 1)
10845 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
10846 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
10848 fputs_filtered (")", stream);
10853 type_print (exp->elts[pc + 1].type, "", stream, 0);
10854 fputs_filtered ("'(", stream);
10855 print_subexp (exp, pos, stream, PREC_PREFIX);
10856 fputs_filtered (")", stream);
10859 case UNOP_IN_RANGE:
10860 /* XXX: sprint_subexp */
10861 print_subexp (exp, pos, stream, PREC_SUFFIX);
10862 fputs_filtered (" in ", stream);
10863 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
10866 case OP_DISCRETE_RANGE:
10867 print_subexp (exp, pos, stream, PREC_SUFFIX);
10868 fputs_filtered ("..", stream);
10869 print_subexp (exp, pos, stream, PREC_SUFFIX);
10873 fputs_filtered ("others => ", stream);
10874 print_subexp (exp, pos, stream, PREC_SUFFIX);
10878 for (i = 0; i < nargs-1; i += 1)
10881 fputs_filtered ("|", stream);
10882 print_subexp (exp, pos, stream, PREC_SUFFIX);
10884 fputs_filtered (" => ", stream);
10885 print_subexp (exp, pos, stream, PREC_SUFFIX);
10888 case OP_POSITIONAL:
10889 print_subexp (exp, pos, stream, PREC_SUFFIX);
10893 fputs_filtered ("(", stream);
10894 for (i = 0; i < nargs; i += 1)
10897 fputs_filtered (", ", stream);
10898 print_subexp (exp, pos, stream, PREC_SUFFIX);
10900 fputs_filtered (")", stream);
10905 /* Table mapping opcodes into strings for printing operators
10906 and precedences of the operators. */
10908 static const struct op_print ada_op_print_tab[] = {
10909 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
10910 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
10911 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
10912 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
10913 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
10914 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
10915 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
10916 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
10917 {"<=", BINOP_LEQ, PREC_ORDER, 0},
10918 {">=", BINOP_GEQ, PREC_ORDER, 0},
10919 {">", BINOP_GTR, PREC_ORDER, 0},
10920 {"<", BINOP_LESS, PREC_ORDER, 0},
10921 {">>", BINOP_RSH, PREC_SHIFT, 0},
10922 {"<<", BINOP_LSH, PREC_SHIFT, 0},
10923 {"+", BINOP_ADD, PREC_ADD, 0},
10924 {"-", BINOP_SUB, PREC_ADD, 0},
10925 {"&", BINOP_CONCAT, PREC_ADD, 0},
10926 {"*", BINOP_MUL, PREC_MUL, 0},
10927 {"/", BINOP_DIV, PREC_MUL, 0},
10928 {"rem", BINOP_REM, PREC_MUL, 0},
10929 {"mod", BINOP_MOD, PREC_MUL, 0},
10930 {"**", BINOP_EXP, PREC_REPEAT, 0},
10931 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
10932 {"-", UNOP_NEG, PREC_PREFIX, 0},
10933 {"+", UNOP_PLUS, PREC_PREFIX, 0},
10934 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
10935 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
10936 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
10937 {".all", UNOP_IND, PREC_SUFFIX, 1},
10938 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
10939 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
10943 enum ada_primitive_types {
10944 ada_primitive_type_int,
10945 ada_primitive_type_long,
10946 ada_primitive_type_short,
10947 ada_primitive_type_char,
10948 ada_primitive_type_float,
10949 ada_primitive_type_double,
10950 ada_primitive_type_void,
10951 ada_primitive_type_long_long,
10952 ada_primitive_type_long_double,
10953 ada_primitive_type_natural,
10954 ada_primitive_type_positive,
10955 ada_primitive_type_system_address,
10956 nr_ada_primitive_types
10960 ada_language_arch_info (struct gdbarch *gdbarch,
10961 struct language_arch_info *lai)
10963 const struct builtin_type *builtin = builtin_type (gdbarch);
10964 lai->primitive_type_vector
10965 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
10967 lai->primitive_type_vector [ada_primitive_type_int] =
10968 init_type (TYPE_CODE_INT,
10969 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
10970 0, "integer", (struct objfile *) NULL);
10971 lai->primitive_type_vector [ada_primitive_type_long] =
10972 init_type (TYPE_CODE_INT,
10973 gdbarch_long_bit (gdbarch) / TARGET_CHAR_BIT,
10974 0, "long_integer", (struct objfile *) NULL);
10975 lai->primitive_type_vector [ada_primitive_type_short] =
10976 init_type (TYPE_CODE_INT,
10977 gdbarch_short_bit (gdbarch) / TARGET_CHAR_BIT,
10978 0, "short_integer", (struct objfile *) NULL);
10979 lai->string_char_type =
10980 lai->primitive_type_vector [ada_primitive_type_char] =
10981 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
10982 0, "character", (struct objfile *) NULL);
10983 lai->primitive_type_vector [ada_primitive_type_float] =
10984 init_type (TYPE_CODE_FLT,
10985 gdbarch_float_bit (gdbarch)/ TARGET_CHAR_BIT,
10986 0, "float", (struct objfile *) NULL);
10987 lai->primitive_type_vector [ada_primitive_type_double] =
10988 init_type (TYPE_CODE_FLT,
10989 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
10990 0, "long_float", (struct objfile *) NULL);
10991 lai->primitive_type_vector [ada_primitive_type_long_long] =
10992 init_type (TYPE_CODE_INT,
10993 gdbarch_long_long_bit (gdbarch) / TARGET_CHAR_BIT,
10994 0, "long_long_integer", (struct objfile *) NULL);
10995 lai->primitive_type_vector [ada_primitive_type_long_double] =
10996 init_type (TYPE_CODE_FLT,
10997 gdbarch_double_bit (gdbarch) / TARGET_CHAR_BIT,
10998 0, "long_long_float", (struct objfile *) NULL);
10999 lai->primitive_type_vector [ada_primitive_type_natural] =
11000 init_type (TYPE_CODE_INT,
11001 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
11002 0, "natural", (struct objfile *) NULL);
11003 lai->primitive_type_vector [ada_primitive_type_positive] =
11004 init_type (TYPE_CODE_INT,
11005 gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
11006 0, "positive", (struct objfile *) NULL);
11007 lai->primitive_type_vector [ada_primitive_type_void] = builtin->builtin_void;
11009 lai->primitive_type_vector [ada_primitive_type_system_address] =
11010 lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
11011 (struct objfile *) NULL));
11012 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
11013 = "system__address";
11015 lai->bool_type_symbol = "boolean";
11016 lai->bool_type_default = builtin->builtin_bool;
11019 /* Language vector */
11021 /* Not really used, but needed in the ada_language_defn. */
11024 emit_char (int c, struct ui_file *stream, int quoter)
11026 ada_emit_char (c, stream, quoter, 1);
11032 warnings_issued = 0;
11033 return ada_parse ();
11036 static const struct exp_descriptor ada_exp_descriptor = {
11038 ada_operator_length,
11040 ada_dump_subexp_body,
11041 ada_evaluate_subexp
11044 const struct language_defn ada_language_defn = {
11045 "ada", /* Language name */
11049 case_sensitive_on, /* Yes, Ada is case-insensitive, but
11050 that's not quite what this means. */
11052 macro_expansion_no,
11053 &ada_exp_descriptor,
11057 ada_printchar, /* Print a character constant */
11058 ada_printstr, /* Function to print string constant */
11059 emit_char, /* Function to print single char (not used) */
11060 ada_print_type, /* Print a type using appropriate syntax */
11061 default_print_typedef, /* Print a typedef using appropriate syntax */
11062 ada_val_print, /* Print a value using appropriate syntax */
11063 ada_value_print, /* Print a top-level value */
11064 NULL, /* Language specific skip_trampoline */
11065 NULL, /* name_of_this */
11066 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
11067 basic_lookup_transparent_type, /* lookup_transparent_type */
11068 ada_la_decode, /* Language specific symbol demangler */
11069 NULL, /* Language specific class_name_from_physname */
11070 ada_op_print_tab, /* expression operators for printing */
11071 0, /* c-style arrays */
11072 1, /* String lower bound */
11073 ada_get_gdb_completer_word_break_characters,
11074 ada_make_symbol_completion_list,
11075 ada_language_arch_info,
11076 ada_print_array_index,
11077 default_pass_by_reference,
11082 _initialize_ada_language (void)
11084 add_language (&ada_language_defn);
11086 varsize_limit = 65536;
11088 obstack_init (&symbol_list_obstack);
11090 decoded_names_store = htab_create_alloc
11091 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
11092 NULL, xcalloc, xfree);
11094 observer_attach_executable_changed (ada_executable_changed_observer);