1 /* Ada language support routines for GDB, the GNU debugger. Copyright (C)
3 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005 Free
4 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 2 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, write to the Free Software
20 Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
26 #include "gdb_string.h"
30 #include "gdb_regex.h"
35 #include "expression.h"
36 #include "parser-defs.h"
42 #include "breakpoint.h"
45 #include "gdb_obstack.h"
47 #include "completer.h"
54 #include "dictionary.h"
55 #include "exceptions.h"
57 #ifndef ADA_RETAIN_DOTS
58 #define ADA_RETAIN_DOTS 0
61 /* Define whether or not the C operator '/' truncates towards zero for
62 differently signed operands (truncation direction is undefined in C).
63 Copied from valarith.c. */
65 #ifndef TRUNCATION_TOWARDS_ZERO
66 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
70 static void extract_string (CORE_ADDR addr, char *buf);
72 static struct type *ada_create_fundamental_type (struct objfile *, int);
74 static void modify_general_field (char *, LONGEST, int, int);
76 static struct type *desc_base_type (struct type *);
78 static struct type *desc_bounds_type (struct type *);
80 static struct value *desc_bounds (struct value *);
82 static int fat_pntr_bounds_bitpos (struct type *);
84 static int fat_pntr_bounds_bitsize (struct type *);
86 static struct type *desc_data_type (struct type *);
88 static struct value *desc_data (struct value *);
90 static int fat_pntr_data_bitpos (struct type *);
92 static int fat_pntr_data_bitsize (struct type *);
94 static struct value *desc_one_bound (struct value *, int, int);
96 static int desc_bound_bitpos (struct type *, int, int);
98 static int desc_bound_bitsize (struct type *, int, int);
100 static struct type *desc_index_type (struct type *, int);
102 static int desc_arity (struct type *);
104 static int ada_type_match (struct type *, struct type *, int);
106 static int ada_args_match (struct symbol *, struct value **, int);
108 static struct value *ensure_lval (struct value *, CORE_ADDR *);
110 static struct value *convert_actual (struct value *, struct type *,
113 static struct value *make_array_descriptor (struct type *, struct value *,
116 static void ada_add_block_symbols (struct obstack *,
117 struct block *, const char *,
118 domain_enum, struct objfile *,
119 struct symtab *, int);
121 static int is_nonfunction (struct ada_symbol_info *, int);
123 static void add_defn_to_vec (struct obstack *, struct symbol *,
124 struct block *, struct symtab *);
126 static int num_defns_collected (struct obstack *);
128 static struct ada_symbol_info *defns_collected (struct obstack *, int);
130 static struct partial_symbol *ada_lookup_partial_symbol (struct partial_symtab
131 *, const char *, int,
134 static struct symtab *symtab_for_sym (struct symbol *);
136 static struct value *resolve_subexp (struct expression **, int *, int,
139 static void replace_operator_with_call (struct expression **, int, int, int,
140 struct symbol *, struct block *);
142 static int possible_user_operator_p (enum exp_opcode, struct value **);
144 static char *ada_op_name (enum exp_opcode);
146 static const char *ada_decoded_op_name (enum exp_opcode);
148 static int numeric_type_p (struct type *);
150 static int integer_type_p (struct type *);
152 static int scalar_type_p (struct type *);
154 static int discrete_type_p (struct type *);
156 static struct type *ada_lookup_struct_elt_type (struct type *, char *,
159 static struct value *evaluate_subexp (struct type *, struct expression *,
162 static struct value *evaluate_subexp_type (struct expression *, int *);
164 static int is_dynamic_field (struct type *, int);
166 static struct type *to_fixed_variant_branch_type (struct type *,
168 CORE_ADDR, struct value *);
170 static struct type *to_fixed_array_type (struct type *, struct value *, int);
172 static struct type *to_fixed_range_type (char *, struct value *,
175 static struct type *to_static_fixed_type (struct type *);
177 static struct value *unwrap_value (struct value *);
179 static struct type *packed_array_type (struct type *, long *);
181 static struct type *decode_packed_array_type (struct type *);
183 static struct value *decode_packed_array (struct value *);
185 static struct value *value_subscript_packed (struct value *, int,
188 static void move_bits (gdb_byte *, int, const gdb_byte *, int, int);
190 static struct value *coerce_unspec_val_to_type (struct value *,
193 static struct value *get_var_value (char *, char *);
195 static int lesseq_defined_than (struct symbol *, struct symbol *);
197 static int equiv_types (struct type *, struct type *);
199 static int is_name_suffix (const char *);
201 static int wild_match (const char *, int, const char *);
203 static struct value *ada_coerce_ref (struct value *);
205 static LONGEST pos_atr (struct value *);
207 static struct value *value_pos_atr (struct value *);
209 static struct value *value_val_atr (struct type *, struct value *);
211 static struct symbol *standard_lookup (const char *, const struct block *,
214 static struct value *ada_search_struct_field (char *, struct value *, int,
217 static struct value *ada_value_primitive_field (struct value *, int, int,
220 static int find_struct_field (char *, struct type *, int,
221 struct type **, int *, int *, int *, int *);
223 static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
226 static struct value *ada_to_fixed_value (struct value *);
228 static int ada_resolve_function (struct ada_symbol_info *, int,
229 struct value **, int, const char *,
232 static struct value *ada_coerce_to_simple_array (struct value *);
234 static int ada_is_direct_array_type (struct type *);
236 static void ada_language_arch_info (struct gdbarch *,
237 struct language_arch_info *);
239 static void check_size (const struct type *);
241 static struct value *ada_index_struct_field (int, struct value *, int,
244 static struct value *assign_aggregate (struct value *, struct value *,
245 struct expression *, int *, enum noside);
247 static void aggregate_assign_from_choices (struct value *, struct value *,
249 int *, LONGEST *, int *,
250 int, LONGEST, LONGEST);
252 static void aggregate_assign_positional (struct value *, struct value *,
254 int *, LONGEST *, int *, int,
258 static void aggregate_assign_others (struct value *, struct value *,
260 int *, LONGEST *, int, LONGEST, LONGEST);
263 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
266 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
269 static void ada_forward_operator_length (struct expression *, int, int *,
274 /* Maximum-sized dynamic type. */
275 static unsigned int varsize_limit;
277 /* FIXME: brobecker/2003-09-17: No longer a const because it is
278 returned by a function that does not return a const char *. */
279 static char *ada_completer_word_break_characters =
281 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
283 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
286 /* The name of the symbol to use to get the name of the main subprogram. */
287 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
288 = "__gnat_ada_main_program_name";
290 /* The name of the runtime function called when an exception is raised. */
291 static const char raise_sym_name[] = "__gnat_raise_nodefer_with_msg";
293 /* The name of the runtime function called when an unhandled exception
295 static const char raise_unhandled_sym_name[] = "__gnat_unhandled_exception";
297 /* The name of the runtime function called when an assert failure is
299 static const char raise_assert_sym_name[] =
300 "system__assertions__raise_assert_failure";
302 /* A string that reflects the longest exception expression rewrite,
303 aside from the exception name. */
304 static const char longest_exception_template[] =
305 "'__gnat_raise_nodefer_with_msg' if long_integer(e) = long_integer(&)";
307 /* Limit on the number of warnings to raise per expression evaluation. */
308 static int warning_limit = 2;
310 /* Number of warning messages issued; reset to 0 by cleanups after
311 expression evaluation. */
312 static int warnings_issued = 0;
314 static const char *known_runtime_file_name_patterns[] = {
315 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
318 static const char *known_auxiliary_function_name_patterns[] = {
319 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
322 /* Space for allocating results of ada_lookup_symbol_list. */
323 static struct obstack symbol_list_obstack;
329 ada_get_gdb_completer_word_break_characters (void)
331 return ada_completer_word_break_characters;
334 /* Print an array element index using the Ada syntax. */
337 ada_print_array_index (struct value *index_value, struct ui_file *stream,
338 int format, enum val_prettyprint pretty)
340 LA_VALUE_PRINT (index_value, stream, format, pretty);
341 fprintf_filtered (stream, " => ");
344 /* Read the string located at ADDR from the inferior and store the
348 extract_string (CORE_ADDR addr, char *buf)
352 /* Loop, reading one byte at a time, until we reach the '\000'
353 end-of-string marker. */
356 target_read_memory (addr + char_index * sizeof (char),
357 buf + char_index * sizeof (char), sizeof (char));
360 while (buf[char_index - 1] != '\000');
363 /* Assuming VECT points to an array of *SIZE objects of size
364 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
365 updating *SIZE as necessary and returning the (new) array. */
368 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
370 if (*size < min_size)
373 if (*size < min_size)
375 vect = xrealloc (vect, *size * element_size);
380 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
381 suffix of FIELD_NAME beginning "___". */
384 field_name_match (const char *field_name, const char *target)
386 int len = strlen (target);
388 (strncmp (field_name, target, len) == 0
389 && (field_name[len] == '\0'
390 || (strncmp (field_name + len, "___", 3) == 0
391 && strcmp (field_name + strlen (field_name) - 6,
396 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
397 FIELD_NAME, and return its index. This function also handles fields
398 whose name have ___ suffixes because the compiler sometimes alters
399 their name by adding such a suffix to represent fields with certain
400 constraints. If the field could not be found, return a negative
401 number if MAYBE_MISSING is set. Otherwise raise an error. */
404 ada_get_field_index (const struct type *type, const char *field_name,
408 for (fieldno = 0; fieldno < TYPE_NFIELDS (type); fieldno++)
409 if (field_name_match (TYPE_FIELD_NAME (type, fieldno), field_name))
413 error (_("Unable to find field %s in struct %s. Aborting"),
414 field_name, TYPE_NAME (type));
419 /* The length of the prefix of NAME prior to any "___" suffix. */
422 ada_name_prefix_len (const char *name)
428 const char *p = strstr (name, "___");
430 return strlen (name);
436 /* Return non-zero if SUFFIX is a suffix of STR.
437 Return zero if STR is null. */
440 is_suffix (const char *str, const char *suffix)
446 len2 = strlen (suffix);
447 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
450 /* Create a value of type TYPE whose contents come from VALADDR, if it
451 is non-null, and whose memory address (in the inferior) is
455 value_from_contents_and_address (struct type *type,
456 const gdb_byte *valaddr,
459 struct value *v = allocate_value (type);
461 set_value_lazy (v, 1);
463 memcpy (value_contents_raw (v), valaddr, TYPE_LENGTH (type));
464 VALUE_ADDRESS (v) = address;
466 VALUE_LVAL (v) = lval_memory;
470 /* The contents of value VAL, treated as a value of type TYPE. The
471 result is an lval in memory if VAL is. */
473 static struct value *
474 coerce_unspec_val_to_type (struct value *val, struct type *type)
476 type = ada_check_typedef (type);
477 if (value_type (val) == type)
481 struct value *result;
483 /* Make sure that the object size is not unreasonable before
484 trying to allocate some memory for it. */
487 result = allocate_value (type);
488 VALUE_LVAL (result) = VALUE_LVAL (val);
489 set_value_bitsize (result, value_bitsize (val));
490 set_value_bitpos (result, value_bitpos (val));
491 VALUE_ADDRESS (result) = VALUE_ADDRESS (val) + value_offset (val);
493 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
494 set_value_lazy (result, 1);
496 memcpy (value_contents_raw (result), value_contents (val),
502 static const gdb_byte *
503 cond_offset_host (const gdb_byte *valaddr, long offset)
508 return valaddr + offset;
512 cond_offset_target (CORE_ADDR address, long offset)
517 return address + offset;
520 /* Issue a warning (as for the definition of warning in utils.c, but
521 with exactly one argument rather than ...), unless the limit on the
522 number of warnings has passed during the evaluation of the current
525 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
526 provided by "complaint". */
527 static void lim_warning (const char *format, ...) ATTR_FORMAT (printf, 1, 2);
530 lim_warning (const char *format, ...)
533 va_start (args, format);
535 warnings_issued += 1;
536 if (warnings_issued <= warning_limit)
537 vwarning (format, args);
542 /* Issue an error if the size of an object of type T is unreasonable,
543 i.e. if it would be a bad idea to allocate a value of this type in
547 check_size (const struct type *type)
549 if (TYPE_LENGTH (type) > varsize_limit)
550 error (_("object size is larger than varsize-limit"));
554 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
555 gdbtypes.h, but some of the necessary definitions in that file
556 seem to have gone missing. */
558 /* Maximum value of a SIZE-byte signed integer type. */
560 max_of_size (int size)
562 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
563 return top_bit | (top_bit - 1);
566 /* Minimum value of a SIZE-byte signed integer type. */
568 min_of_size (int size)
570 return -max_of_size (size) - 1;
573 /* Maximum value of a SIZE-byte unsigned integer type. */
575 umax_of_size (int size)
577 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
578 return top_bit | (top_bit - 1);
581 /* Maximum value of integral type T, as a signed quantity. */
583 max_of_type (struct type *t)
585 if (TYPE_UNSIGNED (t))
586 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
588 return max_of_size (TYPE_LENGTH (t));
591 /* Minimum value of integral type T, as a signed quantity. */
593 min_of_type (struct type *t)
595 if (TYPE_UNSIGNED (t))
598 return min_of_size (TYPE_LENGTH (t));
601 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
602 static struct value *
603 discrete_type_high_bound (struct type *type)
605 switch (TYPE_CODE (type))
607 case TYPE_CODE_RANGE:
608 return value_from_longest (TYPE_TARGET_TYPE (type),
609 TYPE_HIGH_BOUND (type));
612 value_from_longest (type,
613 TYPE_FIELD_BITPOS (type,
614 TYPE_NFIELDS (type) - 1));
616 return value_from_longest (type, max_of_type (type));
618 error (_("Unexpected type in discrete_type_high_bound."));
622 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
623 static struct value *
624 discrete_type_low_bound (struct type *type)
626 switch (TYPE_CODE (type))
628 case TYPE_CODE_RANGE:
629 return value_from_longest (TYPE_TARGET_TYPE (type),
630 TYPE_LOW_BOUND (type));
632 return value_from_longest (type, TYPE_FIELD_BITPOS (type, 0));
634 return value_from_longest (type, min_of_type (type));
636 error (_("Unexpected type in discrete_type_low_bound."));
640 /* The identity on non-range types. For range types, the underlying
641 non-range scalar type. */
644 base_type (struct type *type)
646 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
648 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
650 type = TYPE_TARGET_TYPE (type);
656 /* Language Selection */
658 /* If the main program is in Ada, return language_ada, otherwise return LANG
659 (the main program is in Ada iif the adainit symbol is found).
661 MAIN_PST is not used. */
664 ada_update_initial_language (enum language lang,
665 struct partial_symtab *main_pst)
667 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
668 (struct objfile *) NULL) != NULL)
674 /* If the main procedure is written in Ada, then return its name.
675 The result is good until the next call. Return NULL if the main
676 procedure doesn't appear to be in Ada. */
681 struct minimal_symbol *msym;
682 CORE_ADDR main_program_name_addr;
683 static char main_program_name[1024];
685 /* For Ada, the name of the main procedure is stored in a specific
686 string constant, generated by the binder. Look for that symbol,
687 extract its address, and then read that string. If we didn't find
688 that string, then most probably the main procedure is not written
690 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
694 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
695 if (main_program_name_addr == 0)
696 error (_("Invalid address for Ada main program name."));
698 extract_string (main_program_name_addr, main_program_name);
699 return main_program_name;
702 /* The main procedure doesn't seem to be in Ada. */
708 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
711 const struct ada_opname_map ada_opname_table[] = {
712 {"Oadd", "\"+\"", BINOP_ADD},
713 {"Osubtract", "\"-\"", BINOP_SUB},
714 {"Omultiply", "\"*\"", BINOP_MUL},
715 {"Odivide", "\"/\"", BINOP_DIV},
716 {"Omod", "\"mod\"", BINOP_MOD},
717 {"Orem", "\"rem\"", BINOP_REM},
718 {"Oexpon", "\"**\"", BINOP_EXP},
719 {"Olt", "\"<\"", BINOP_LESS},
720 {"Ole", "\"<=\"", BINOP_LEQ},
721 {"Ogt", "\">\"", BINOP_GTR},
722 {"Oge", "\">=\"", BINOP_GEQ},
723 {"Oeq", "\"=\"", BINOP_EQUAL},
724 {"One", "\"/=\"", BINOP_NOTEQUAL},
725 {"Oand", "\"and\"", BINOP_BITWISE_AND},
726 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
727 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
728 {"Oconcat", "\"&\"", BINOP_CONCAT},
729 {"Oabs", "\"abs\"", UNOP_ABS},
730 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
731 {"Oadd", "\"+\"", UNOP_PLUS},
732 {"Osubtract", "\"-\"", UNOP_NEG},
736 /* Return non-zero if STR should be suppressed in info listings. */
739 is_suppressed_name (const char *str)
741 if (strncmp (str, "_ada_", 5) == 0)
743 if (str[0] == '_' || str[0] == '\000')
748 const char *suffix = strstr (str, "___");
749 if (suffix != NULL && suffix[3] != 'X')
752 suffix = str + strlen (str);
753 for (p = suffix - 1; p != str; p -= 1)
757 if (p[0] == 'X' && p[-1] != '_')
761 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
762 if (strncmp (ada_opname_table[i].encoded, p,
763 strlen (ada_opname_table[i].encoded)) == 0)
772 /* The "encoded" form of DECODED, according to GNAT conventions.
773 The result is valid until the next call to ada_encode. */
776 ada_encode (const char *decoded)
778 static char *encoding_buffer = NULL;
779 static size_t encoding_buffer_size = 0;
786 GROW_VECT (encoding_buffer, encoding_buffer_size,
787 2 * strlen (decoded) + 10);
790 for (p = decoded; *p != '\0'; p += 1)
792 if (!ADA_RETAIN_DOTS && *p == '.')
794 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
799 const struct ada_opname_map *mapping;
801 for (mapping = ada_opname_table;
802 mapping->encoded != NULL
803 && strncmp (mapping->decoded, p,
804 strlen (mapping->decoded)) != 0; mapping += 1)
806 if (mapping->encoded == NULL)
807 error (_("invalid Ada operator name: %s"), p);
808 strcpy (encoding_buffer + k, mapping->encoded);
809 k += strlen (mapping->encoded);
814 encoding_buffer[k] = *p;
819 encoding_buffer[k] = '\0';
820 return encoding_buffer;
823 /* Return NAME folded to lower case, or, if surrounded by single
824 quotes, unfolded, but with the quotes stripped away. Result good
828 ada_fold_name (const char *name)
830 static char *fold_buffer = NULL;
831 static size_t fold_buffer_size = 0;
833 int len = strlen (name);
834 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
838 strncpy (fold_buffer, name + 1, len - 2);
839 fold_buffer[len - 2] = '\000';
844 for (i = 0; i <= len; i += 1)
845 fold_buffer[i] = tolower (name[i]);
851 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
854 is_lower_alphanum (const char c)
856 return (isdigit (c) || (isalpha (c) && islower (c)));
860 . Discard trailing .{DIGIT}+, ${DIGIT}+ or ___{DIGIT}+
861 These are suffixes introduced by GNAT5 to nested subprogram
862 names, and do not serve any purpose for the debugger.
863 . Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
864 . Discard final N if it follows a lowercase alphanumeric character
865 (protected object subprogram suffix)
866 . Convert other instances of embedded "__" to `.'.
867 . Discard leading _ada_.
868 . Convert operator names to the appropriate quoted symbols.
869 . Remove everything after first ___ if it is followed by
871 . Replace TK__ with __, and a trailing B or TKB with nothing.
872 . Replace _[EB]{DIGIT}+[sb] with nothing (protected object entries)
873 . Put symbols that should be suppressed in <...> brackets.
874 . Remove trailing X[bn]* suffix (indicating names in package bodies).
876 The resulting string is valid until the next call of ada_decode.
877 If the string is unchanged by demangling, the original string pointer
881 ada_decode (const char *encoded)
888 static char *decoding_buffer = NULL;
889 static size_t decoding_buffer_size = 0;
891 if (strncmp (encoded, "_ada_", 5) == 0)
894 if (encoded[0] == '_' || encoded[0] == '<')
897 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+ or __{DIGIT}+. */
898 len0 = strlen (encoded);
899 if (len0 > 1 && isdigit (encoded[len0 - 1]))
902 while (i > 0 && isdigit (encoded[i]))
904 if (i >= 0 && encoded[i] == '.')
906 else if (i >= 0 && encoded[i] == '$')
908 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
910 else if (i >= 1 && strncmp (encoded + i - 1, "__", 2) == 0)
914 /* Remove trailing N. */
916 /* Protected entry subprograms are broken into two
917 separate subprograms: The first one is unprotected, and has
918 a 'N' suffix; the second is the protected version, and has
919 the 'P' suffix. The second calls the first one after handling
920 the protection. Since the P subprograms are internally generated,
921 we leave these names undecoded, giving the user a clue that this
922 entity is internal. */
925 && encoded[len0 - 1] == 'N'
926 && (isdigit (encoded[len0 - 2]) || islower (encoded[len0 - 2])))
929 /* Remove the ___X.* suffix if present. Do not forget to verify that
930 the suffix is located before the current "end" of ENCODED. We want
931 to avoid re-matching parts of ENCODED that have previously been
932 marked as discarded (by decrementing LEN0). */
933 p = strstr (encoded, "___");
934 if (p != NULL && p - encoded < len0 - 3)
942 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
945 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
948 /* Make decoded big enough for possible expansion by operator name. */
949 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
950 decoded = decoding_buffer;
952 if (len0 > 1 && isdigit (encoded[len0 - 1]))
955 while ((i >= 0 && isdigit (encoded[i]))
956 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
958 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
960 else if (encoded[i] == '$')
964 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
965 decoded[j] = encoded[i];
970 if (at_start_name && encoded[i] == 'O')
973 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
975 int op_len = strlen (ada_opname_table[k].encoded);
976 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
978 && !isalnum (encoded[i + op_len]))
980 strcpy (decoded + j, ada_opname_table[k].decoded);
983 j += strlen (ada_opname_table[k].decoded);
987 if (ada_opname_table[k].encoded != NULL)
992 /* Replace "TK__" with "__", which will eventually be translated
993 into "." (just below). */
995 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
998 /* Remove _E{DIGITS}+[sb] */
1000 /* Just as for protected object subprograms, there are 2 categories
1001 of subprograms created by the compiler for each entry. The first
1002 one implements the actual entry code, and has a suffix following
1003 the convention above; the second one implements the barrier and
1004 uses the same convention as above, except that the 'E' is replaced
1007 Just as above, we do not decode the name of barrier functions
1008 to give the user a clue that the code he is debugging has been
1009 internally generated. */
1011 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1012 && isdigit (encoded[i+2]))
1016 while (k < len0 && isdigit (encoded[k]))
1020 && (encoded[k] == 'b' || encoded[k] == 's'))
1023 /* Just as an extra precaution, make sure that if this
1024 suffix is followed by anything else, it is a '_'.
1025 Otherwise, we matched this sequence by accident. */
1027 || (k < len0 && encoded[k] == '_'))
1032 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1033 the GNAT front-end in protected object subprograms. */
1036 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1038 /* Backtrack a bit up until we reach either the begining of
1039 the encoded name, or "__". Make sure that we only find
1040 digits or lowercase characters. */
1041 const char *ptr = encoded + i - 1;
1043 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1046 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1050 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1054 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1058 else if (!ADA_RETAIN_DOTS
1059 && i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1068 decoded[j] = encoded[i];
1073 decoded[j] = '\000';
1075 for (i = 0; decoded[i] != '\0'; i += 1)
1076 if (isupper (decoded[i]) || decoded[i] == ' ')
1079 if (strcmp (decoded, encoded) == 0)
1085 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1086 decoded = decoding_buffer;
1087 if (encoded[0] == '<')
1088 strcpy (decoded, encoded);
1090 sprintf (decoded, "<%s>", encoded);
1095 /* Table for keeping permanent unique copies of decoded names. Once
1096 allocated, names in this table are never released. While this is a
1097 storage leak, it should not be significant unless there are massive
1098 changes in the set of decoded names in successive versions of a
1099 symbol table loaded during a single session. */
1100 static struct htab *decoded_names_store;
1102 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1103 in the language-specific part of GSYMBOL, if it has not been
1104 previously computed. Tries to save the decoded name in the same
1105 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1106 in any case, the decoded symbol has a lifetime at least that of
1108 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1109 const, but nevertheless modified to a semantically equivalent form
1110 when a decoded name is cached in it.
1114 ada_decode_symbol (const struct general_symbol_info *gsymbol)
1117 (char **) &gsymbol->language_specific.cplus_specific.demangled_name;
1118 if (*resultp == NULL)
1120 const char *decoded = ada_decode (gsymbol->name);
1121 if (gsymbol->bfd_section != NULL)
1123 bfd *obfd = gsymbol->bfd_section->owner;
1126 struct objfile *objf;
1129 if (obfd == objf->obfd)
1131 *resultp = obsavestring (decoded, strlen (decoded),
1132 &objf->objfile_obstack);
1138 /* Sometimes, we can't find a corresponding objfile, in which
1139 case, we put the result on the heap. Since we only decode
1140 when needed, we hope this usually does not cause a
1141 significant memory leak (FIXME). */
1142 if (*resultp == NULL)
1144 char **slot = (char **) htab_find_slot (decoded_names_store,
1147 *slot = xstrdup (decoded);
1156 ada_la_decode (const char *encoded, int options)
1158 return xstrdup (ada_decode (encoded));
1161 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1162 suffixes that encode debugging information or leading _ada_ on
1163 SYM_NAME (see is_name_suffix commentary for the debugging
1164 information that is ignored). If WILD, then NAME need only match a
1165 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1166 either argument is NULL. */
1169 ada_match_name (const char *sym_name, const char *name, int wild)
1171 if (sym_name == NULL || name == NULL)
1174 return wild_match (name, strlen (name), sym_name);
1177 int len_name = strlen (name);
1178 return (strncmp (sym_name, name, len_name) == 0
1179 && is_name_suffix (sym_name + len_name))
1180 || (strncmp (sym_name, "_ada_", 5) == 0
1181 && strncmp (sym_name + 5, name, len_name) == 0
1182 && is_name_suffix (sym_name + len_name + 5));
1186 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1187 suppressed in info listings. */
1190 ada_suppress_symbol_printing (struct symbol *sym)
1192 if (SYMBOL_DOMAIN (sym) == STRUCT_DOMAIN)
1195 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym));
1201 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1203 static char *bound_name[] = {
1204 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1205 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1208 /* Maximum number of array dimensions we are prepared to handle. */
1210 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1212 /* Like modify_field, but allows bitpos > wordlength. */
1215 modify_general_field (char *addr, LONGEST fieldval, int bitpos, int bitsize)
1217 modify_field (addr + bitpos / 8, fieldval, bitpos % 8, bitsize);
1221 /* The desc_* routines return primitive portions of array descriptors
1224 /* The descriptor or array type, if any, indicated by TYPE; removes
1225 level of indirection, if needed. */
1227 static struct type *
1228 desc_base_type (struct type *type)
1232 type = ada_check_typedef (type);
1234 && (TYPE_CODE (type) == TYPE_CODE_PTR
1235 || TYPE_CODE (type) == TYPE_CODE_REF))
1236 return ada_check_typedef (TYPE_TARGET_TYPE (type));
1241 /* True iff TYPE indicates a "thin" array pointer type. */
1244 is_thin_pntr (struct type *type)
1247 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1248 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1251 /* The descriptor type for thin pointer type TYPE. */
1253 static struct type *
1254 thin_descriptor_type (struct type *type)
1256 struct type *base_type = desc_base_type (type);
1257 if (base_type == NULL)
1259 if (is_suffix (ada_type_name (base_type), "___XVE"))
1263 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1264 if (alt_type == NULL)
1271 /* A pointer to the array data for thin-pointer value VAL. */
1273 static struct value *
1274 thin_data_pntr (struct value *val)
1276 struct type *type = value_type (val);
1277 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1278 return value_cast (desc_data_type (thin_descriptor_type (type)),
1281 return value_from_longest (desc_data_type (thin_descriptor_type (type)),
1282 VALUE_ADDRESS (val) + value_offset (val));
1285 /* True iff TYPE indicates a "thick" array pointer type. */
1288 is_thick_pntr (struct type *type)
1290 type = desc_base_type (type);
1291 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1292 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1295 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1296 pointer to one, the type of its bounds data; otherwise, NULL. */
1298 static struct type *
1299 desc_bounds_type (struct type *type)
1303 type = desc_base_type (type);
1307 else if (is_thin_pntr (type))
1309 type = thin_descriptor_type (type);
1312 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1314 return ada_check_typedef (r);
1316 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1318 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1320 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1325 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1326 one, a pointer to its bounds data. Otherwise NULL. */
1328 static struct value *
1329 desc_bounds (struct value *arr)
1331 struct type *type = ada_check_typedef (value_type (arr));
1332 if (is_thin_pntr (type))
1334 struct type *bounds_type =
1335 desc_bounds_type (thin_descriptor_type (type));
1338 if (desc_bounds_type == NULL)
1339 error (_("Bad GNAT array descriptor"));
1341 /* NOTE: The following calculation is not really kosher, but
1342 since desc_type is an XVE-encoded type (and shouldn't be),
1343 the correct calculation is a real pain. FIXME (and fix GCC). */
1344 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1345 addr = value_as_long (arr);
1347 addr = VALUE_ADDRESS (arr) + value_offset (arr);
1350 value_from_longest (lookup_pointer_type (bounds_type),
1351 addr - TYPE_LENGTH (bounds_type));
1354 else if (is_thick_pntr (type))
1355 return value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1356 _("Bad GNAT array descriptor"));
1361 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1362 position of the field containing the address of the bounds data. */
1365 fat_pntr_bounds_bitpos (struct type *type)
1367 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1370 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1371 size of the field containing the address of the bounds data. */
1374 fat_pntr_bounds_bitsize (struct type *type)
1376 type = desc_base_type (type);
1378 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1379 return TYPE_FIELD_BITSIZE (type, 1);
1381 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1384 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1385 pointer to one, the type of its array data (a
1386 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1387 ada_type_of_array to get an array type with bounds data. */
1389 static struct type *
1390 desc_data_type (struct type *type)
1392 type = desc_base_type (type);
1394 /* NOTE: The following is bogus; see comment in desc_bounds. */
1395 if (is_thin_pntr (type))
1396 return lookup_pointer_type
1397 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)));
1398 else if (is_thick_pntr (type))
1399 return lookup_struct_elt_type (type, "P_ARRAY", 1);
1404 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1407 static struct value *
1408 desc_data (struct value *arr)
1410 struct type *type = value_type (arr);
1411 if (is_thin_pntr (type))
1412 return thin_data_pntr (arr);
1413 else if (is_thick_pntr (type))
1414 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1415 _("Bad GNAT array descriptor"));
1421 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1422 position of the field containing the address of the data. */
1425 fat_pntr_data_bitpos (struct type *type)
1427 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1430 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1431 size of the field containing the address of the data. */
1434 fat_pntr_data_bitsize (struct type *type)
1436 type = desc_base_type (type);
1438 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1439 return TYPE_FIELD_BITSIZE (type, 0);
1441 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1444 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1445 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1446 bound, if WHICH is 1. The first bound is I=1. */
1448 static struct value *
1449 desc_one_bound (struct value *bounds, int i, int which)
1451 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1452 _("Bad GNAT array descriptor bounds"));
1455 /* If BOUNDS is an array-bounds structure type, return the bit position
1456 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1457 bound, if WHICH is 1. The first bound is I=1. */
1460 desc_bound_bitpos (struct type *type, int i, int which)
1462 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1465 /* If BOUNDS is an array-bounds structure type, return the bit field size
1466 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1467 bound, if WHICH is 1. The first bound is I=1. */
1470 desc_bound_bitsize (struct type *type, int i, int which)
1472 type = desc_base_type (type);
1474 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1475 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1477 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1480 /* If TYPE is the type of an array-bounds structure, the type of its
1481 Ith bound (numbering from 1). Otherwise, NULL. */
1483 static struct type *
1484 desc_index_type (struct type *type, int i)
1486 type = desc_base_type (type);
1488 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1489 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1494 /* The number of index positions in the array-bounds type TYPE.
1495 Return 0 if TYPE is NULL. */
1498 desc_arity (struct type *type)
1500 type = desc_base_type (type);
1503 return TYPE_NFIELDS (type) / 2;
1507 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1508 an array descriptor type (representing an unconstrained array
1512 ada_is_direct_array_type (struct type *type)
1516 type = ada_check_typedef (type);
1517 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1518 || ada_is_array_descriptor_type (type));
1521 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1525 ada_is_array_type (struct type *type)
1528 && (TYPE_CODE (type) == TYPE_CODE_PTR
1529 || TYPE_CODE (type) == TYPE_CODE_REF))
1530 type = TYPE_TARGET_TYPE (type);
1531 return ada_is_direct_array_type (type);
1534 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1537 ada_is_simple_array_type (struct type *type)
1541 type = ada_check_typedef (type);
1542 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1543 || (TYPE_CODE (type) == TYPE_CODE_PTR
1544 && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY));
1547 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1550 ada_is_array_descriptor_type (struct type *type)
1552 struct type *data_type = desc_data_type (type);
1556 type = ada_check_typedef (type);
1559 && ((TYPE_CODE (data_type) == TYPE_CODE_PTR
1560 && TYPE_TARGET_TYPE (data_type) != NULL
1561 && TYPE_CODE (TYPE_TARGET_TYPE (data_type)) == TYPE_CODE_ARRAY)
1562 || TYPE_CODE (data_type) == TYPE_CODE_ARRAY)
1563 && desc_arity (desc_bounds_type (type)) > 0;
1566 /* Non-zero iff type is a partially mal-formed GNAT array
1567 descriptor. FIXME: This is to compensate for some problems with
1568 debugging output from GNAT. Re-examine periodically to see if it
1572 ada_is_bogus_array_descriptor (struct type *type)
1576 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1577 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1578 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1579 && !ada_is_array_descriptor_type (type);
1583 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1584 (fat pointer) returns the type of the array data described---specifically,
1585 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1586 in from the descriptor; otherwise, they are left unspecified. If
1587 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1588 returns NULL. The result is simply the type of ARR if ARR is not
1591 ada_type_of_array (struct value *arr, int bounds)
1593 if (ada_is_packed_array_type (value_type (arr)))
1594 return decode_packed_array_type (value_type (arr));
1596 if (!ada_is_array_descriptor_type (value_type (arr)))
1597 return value_type (arr);
1601 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr))));
1604 struct type *elt_type;
1606 struct value *descriptor;
1607 struct objfile *objf = TYPE_OBJFILE (value_type (arr));
1609 elt_type = ada_array_element_type (value_type (arr), -1);
1610 arity = ada_array_arity (value_type (arr));
1612 if (elt_type == NULL || arity == 0)
1613 return ada_check_typedef (value_type (arr));
1615 descriptor = desc_bounds (arr);
1616 if (value_as_long (descriptor) == 0)
1620 struct type *range_type = alloc_type (objf);
1621 struct type *array_type = alloc_type (objf);
1622 struct value *low = desc_one_bound (descriptor, arity, 0);
1623 struct value *high = desc_one_bound (descriptor, arity, 1);
1626 create_range_type (range_type, value_type (low),
1627 longest_to_int (value_as_long (low)),
1628 longest_to_int (value_as_long (high)));
1629 elt_type = create_array_type (array_type, elt_type, range_type);
1632 return lookup_pointer_type (elt_type);
1636 /* If ARR does not represent an array, returns ARR unchanged.
1637 Otherwise, returns either a standard GDB array with bounds set
1638 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1639 GDB array. Returns NULL if ARR is a null fat pointer. */
1642 ada_coerce_to_simple_array_ptr (struct value *arr)
1644 if (ada_is_array_descriptor_type (value_type (arr)))
1646 struct type *arrType = ada_type_of_array (arr, 1);
1647 if (arrType == NULL)
1649 return value_cast (arrType, value_copy (desc_data (arr)));
1651 else if (ada_is_packed_array_type (value_type (arr)))
1652 return decode_packed_array (arr);
1657 /* If ARR does not represent an array, returns ARR unchanged.
1658 Otherwise, returns a standard GDB array describing ARR (which may
1659 be ARR itself if it already is in the proper form). */
1661 static struct value *
1662 ada_coerce_to_simple_array (struct value *arr)
1664 if (ada_is_array_descriptor_type (value_type (arr)))
1666 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1668 error (_("Bounds unavailable for null array pointer."));
1669 check_size (TYPE_TARGET_TYPE (value_type (arrVal)));
1670 return value_ind (arrVal);
1672 else if (ada_is_packed_array_type (value_type (arr)))
1673 return decode_packed_array (arr);
1678 /* If TYPE represents a GNAT array type, return it translated to an
1679 ordinary GDB array type (possibly with BITSIZE fields indicating
1680 packing). For other types, is the identity. */
1683 ada_coerce_to_simple_array_type (struct type *type)
1685 struct value *mark = value_mark ();
1686 struct value *dummy = value_from_longest (builtin_type_long, 0);
1687 struct type *result;
1688 deprecated_set_value_type (dummy, type);
1689 result = ada_type_of_array (dummy, 0);
1690 value_free_to_mark (mark);
1694 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1697 ada_is_packed_array_type (struct type *type)
1701 type = desc_base_type (type);
1702 type = ada_check_typedef (type);
1704 ada_type_name (type) != NULL
1705 && strstr (ada_type_name (type), "___XP") != NULL;
1708 /* Given that TYPE is a standard GDB array type with all bounds filled
1709 in, and that the element size of its ultimate scalar constituents
1710 (that is, either its elements, or, if it is an array of arrays, its
1711 elements' elements, etc.) is *ELT_BITS, return an identical type,
1712 but with the bit sizes of its elements (and those of any
1713 constituent arrays) recorded in the BITSIZE components of its
1714 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1717 static struct type *
1718 packed_array_type (struct type *type, long *elt_bits)
1720 struct type *new_elt_type;
1721 struct type *new_type;
1722 LONGEST low_bound, high_bound;
1724 type = ada_check_typedef (type);
1725 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1728 new_type = alloc_type (TYPE_OBJFILE (type));
1729 new_elt_type = packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
1731 create_array_type (new_type, new_elt_type, TYPE_FIELD_TYPE (type, 0));
1732 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
1733 TYPE_NAME (new_type) = ada_type_name (type);
1735 if (get_discrete_bounds (TYPE_FIELD_TYPE (type, 0),
1736 &low_bound, &high_bound) < 0)
1737 low_bound = high_bound = 0;
1738 if (high_bound < low_bound)
1739 *elt_bits = TYPE_LENGTH (new_type) = 0;
1742 *elt_bits *= (high_bound - low_bound + 1);
1743 TYPE_LENGTH (new_type) =
1744 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
1747 TYPE_FLAGS (new_type) |= TYPE_FLAG_FIXED_INSTANCE;
1751 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1753 static struct type *
1754 decode_packed_array_type (struct type *type)
1757 struct block **blocks;
1758 const char *raw_name = ada_type_name (ada_check_typedef (type));
1759 char *name = (char *) alloca (strlen (raw_name) + 1);
1760 char *tail = strstr (raw_name, "___XP");
1761 struct type *shadow_type;
1765 type = desc_base_type (type);
1767 memcpy (name, raw_name, tail - raw_name);
1768 name[tail - raw_name] = '\000';
1770 sym = standard_lookup (name, get_selected_block (0), VAR_DOMAIN);
1771 if (sym == NULL || SYMBOL_TYPE (sym) == NULL)
1773 lim_warning (_("could not find bounds information on packed array"));
1776 shadow_type = SYMBOL_TYPE (sym);
1778 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
1780 lim_warning (_("could not understand bounds information on packed array"));
1784 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1787 (_("could not understand bit size information on packed array"));
1791 return packed_array_type (shadow_type, &bits);
1794 /* Given that ARR is a struct value *indicating a GNAT packed array,
1795 returns a simple array that denotes that array. Its type is a
1796 standard GDB array type except that the BITSIZEs of the array
1797 target types are set to the number of bits in each element, and the
1798 type length is set appropriately. */
1800 static struct value *
1801 decode_packed_array (struct value *arr)
1805 arr = ada_coerce_ref (arr);
1806 if (TYPE_CODE (value_type (arr)) == TYPE_CODE_PTR)
1807 arr = ada_value_ind (arr);
1809 type = decode_packed_array_type (value_type (arr));
1812 error (_("can't unpack array"));
1816 if (BITS_BIG_ENDIAN && ada_is_modular_type (value_type (arr)))
1818 /* This is a (right-justified) modular type representing a packed
1819 array with no wrapper. In order to interpret the value through
1820 the (left-justified) packed array type we just built, we must
1821 first left-justify it. */
1822 int bit_size, bit_pos;
1825 mod = ada_modulus (value_type (arr)) - 1;
1832 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
1833 arr = ada_value_primitive_packed_val (arr, NULL,
1834 bit_pos / HOST_CHAR_BIT,
1835 bit_pos % HOST_CHAR_BIT,
1840 return coerce_unspec_val_to_type (arr, type);
1844 /* The value of the element of packed array ARR at the ARITY indices
1845 given in IND. ARR must be a simple array. */
1847 static struct value *
1848 value_subscript_packed (struct value *arr, int arity, struct value **ind)
1851 int bits, elt_off, bit_off;
1852 long elt_total_bit_offset;
1853 struct type *elt_type;
1857 elt_total_bit_offset = 0;
1858 elt_type = ada_check_typedef (value_type (arr));
1859 for (i = 0; i < arity; i += 1)
1861 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
1862 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
1864 (_("attempt to do packed indexing of something other than a packed array"));
1867 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
1868 LONGEST lowerbound, upperbound;
1871 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
1873 lim_warning (_("don't know bounds of array"));
1874 lowerbound = upperbound = 0;
1877 idx = value_as_long (value_pos_atr (ind[i]));
1878 if (idx < lowerbound || idx > upperbound)
1879 lim_warning (_("packed array index %ld out of bounds"), (long) idx);
1880 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
1881 elt_total_bit_offset += (idx - lowerbound) * bits;
1882 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
1885 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
1886 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
1888 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
1890 if (VALUE_LVAL (arr) == lval_internalvar)
1891 VALUE_LVAL (v) = lval_internalvar_component;
1893 VALUE_LVAL (v) = VALUE_LVAL (arr);
1897 /* Non-zero iff TYPE includes negative integer values. */
1900 has_negatives (struct type *type)
1902 switch (TYPE_CODE (type))
1907 return !TYPE_UNSIGNED (type);
1908 case TYPE_CODE_RANGE:
1909 return TYPE_LOW_BOUND (type) < 0;
1914 /* Create a new value of type TYPE from the contents of OBJ starting
1915 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1916 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1917 assigning through the result will set the field fetched from.
1918 VALADDR is ignored unless OBJ is NULL, in which case,
1919 VALADDR+OFFSET must address the start of storage containing the
1920 packed value. The value returned in this case is never an lval.
1921 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1924 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
1925 long offset, int bit_offset, int bit_size,
1929 int src, /* Index into the source area */
1930 targ, /* Index into the target area */
1931 srcBitsLeft, /* Number of source bits left to move */
1932 nsrc, ntarg, /* Number of source and target bytes */
1933 unusedLS, /* Number of bits in next significant
1934 byte of source that are unused */
1935 accumSize; /* Number of meaningful bits in accum */
1936 unsigned char *bytes; /* First byte containing data to unpack */
1937 unsigned char *unpacked;
1938 unsigned long accum; /* Staging area for bits being transferred */
1940 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
1941 /* Transmit bytes from least to most significant; delta is the direction
1942 the indices move. */
1943 int delta = BITS_BIG_ENDIAN ? -1 : 1;
1945 type = ada_check_typedef (type);
1949 v = allocate_value (type);
1950 bytes = (unsigned char *) (valaddr + offset);
1952 else if (value_lazy (obj))
1955 VALUE_ADDRESS (obj) + value_offset (obj) + offset);
1956 bytes = (unsigned char *) alloca (len);
1957 read_memory (VALUE_ADDRESS (v), bytes, len);
1961 v = allocate_value (type);
1962 bytes = (unsigned char *) value_contents (obj) + offset;
1967 VALUE_LVAL (v) = VALUE_LVAL (obj);
1968 if (VALUE_LVAL (obj) == lval_internalvar)
1969 VALUE_LVAL (v) = lval_internalvar_component;
1970 VALUE_ADDRESS (v) = VALUE_ADDRESS (obj) + value_offset (obj) + offset;
1971 set_value_bitpos (v, bit_offset + value_bitpos (obj));
1972 set_value_bitsize (v, bit_size);
1973 if (value_bitpos (v) >= HOST_CHAR_BIT)
1975 VALUE_ADDRESS (v) += 1;
1976 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
1980 set_value_bitsize (v, bit_size);
1981 unpacked = (unsigned char *) value_contents (v);
1983 srcBitsLeft = bit_size;
1985 ntarg = TYPE_LENGTH (type);
1989 memset (unpacked, 0, TYPE_LENGTH (type));
1992 else if (BITS_BIG_ENDIAN)
1995 if (has_negatives (type)
1996 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2000 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2003 switch (TYPE_CODE (type))
2005 case TYPE_CODE_ARRAY:
2006 case TYPE_CODE_UNION:
2007 case TYPE_CODE_STRUCT:
2008 /* Non-scalar values must be aligned at a byte boundary... */
2010 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2011 /* ... And are placed at the beginning (most-significant) bytes
2013 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2017 targ = TYPE_LENGTH (type) - 1;
2023 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2026 unusedLS = bit_offset;
2029 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
2036 /* Mask for removing bits of the next source byte that are not
2037 part of the value. */
2038 unsigned int unusedMSMask =
2039 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2041 /* Sign-extend bits for this byte. */
2042 unsigned int signMask = sign & ~unusedMSMask;
2044 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2045 accumSize += HOST_CHAR_BIT - unusedLS;
2046 if (accumSize >= HOST_CHAR_BIT)
2048 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2049 accumSize -= HOST_CHAR_BIT;
2050 accum >>= HOST_CHAR_BIT;
2054 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2061 accum |= sign << accumSize;
2062 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2063 accumSize -= HOST_CHAR_BIT;
2064 accum >>= HOST_CHAR_BIT;
2072 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2073 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2076 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2077 int src_offset, int n)
2079 unsigned int accum, mask;
2080 int accum_bits, chunk_size;
2082 target += targ_offset / HOST_CHAR_BIT;
2083 targ_offset %= HOST_CHAR_BIT;
2084 source += src_offset / HOST_CHAR_BIT;
2085 src_offset %= HOST_CHAR_BIT;
2086 if (BITS_BIG_ENDIAN)
2088 accum = (unsigned char) *source;
2090 accum_bits = HOST_CHAR_BIT - src_offset;
2095 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2096 accum_bits += HOST_CHAR_BIT;
2098 chunk_size = HOST_CHAR_BIT - targ_offset;
2101 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2102 mask = ((1 << chunk_size) - 1) << unused_right;
2105 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2107 accum_bits -= chunk_size;
2114 accum = (unsigned char) *source >> src_offset;
2116 accum_bits = HOST_CHAR_BIT - src_offset;
2120 accum = accum + ((unsigned char) *source << accum_bits);
2121 accum_bits += HOST_CHAR_BIT;
2123 chunk_size = HOST_CHAR_BIT - targ_offset;
2126 mask = ((1 << chunk_size) - 1) << targ_offset;
2127 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2129 accum_bits -= chunk_size;
2130 accum >>= chunk_size;
2137 /* Store the contents of FROMVAL into the location of TOVAL.
2138 Return a new value with the location of TOVAL and contents of
2139 FROMVAL. Handles assignment into packed fields that have
2140 floating-point or non-scalar types. */
2142 static struct value *
2143 ada_value_assign (struct value *toval, struct value *fromval)
2145 struct type *type = value_type (toval);
2146 int bits = value_bitsize (toval);
2148 toval = ada_coerce_ref (toval);
2149 fromval = ada_coerce_ref (fromval);
2151 if (ada_is_direct_array_type (value_type (toval)))
2152 toval = ada_coerce_to_simple_array (toval);
2153 if (ada_is_direct_array_type (value_type (fromval)))
2154 fromval = ada_coerce_to_simple_array (fromval);
2156 if (!deprecated_value_modifiable (toval))
2157 error (_("Left operand of assignment is not a modifiable lvalue."));
2159 if (VALUE_LVAL (toval) == lval_memory
2161 && (TYPE_CODE (type) == TYPE_CODE_FLT
2162 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2164 int len = (value_bitpos (toval)
2165 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2166 char *buffer = (char *) alloca (len);
2168 CORE_ADDR to_addr = VALUE_ADDRESS (toval) + value_offset (toval);
2170 if (TYPE_CODE (type) == TYPE_CODE_FLT)
2171 fromval = value_cast (type, fromval);
2173 read_memory (to_addr, buffer, len);
2174 if (BITS_BIG_ENDIAN)
2175 move_bits (buffer, value_bitpos (toval),
2176 value_contents (fromval),
2177 TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT -
2180 move_bits (buffer, value_bitpos (toval), value_contents (fromval),
2182 write_memory (to_addr, buffer, len);
2183 if (deprecated_memory_changed_hook)
2184 deprecated_memory_changed_hook (to_addr, len);
2186 val = value_copy (toval);
2187 memcpy (value_contents_raw (val), value_contents (fromval),
2188 TYPE_LENGTH (type));
2189 deprecated_set_value_type (val, type);
2194 return value_assign (toval, fromval);
2198 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2199 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2200 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2201 * COMPONENT, and not the inferior's memory. The current contents
2202 * of COMPONENT are ignored. */
2204 value_assign_to_component (struct value *container, struct value *component,
2207 LONGEST offset_in_container =
2208 (LONGEST) (VALUE_ADDRESS (component) + value_offset (component)
2209 - VALUE_ADDRESS (container) - value_offset (container));
2210 int bit_offset_in_container =
2211 value_bitpos (component) - value_bitpos (container);
2214 val = value_cast (value_type (component), val);
2216 if (value_bitsize (component) == 0)
2217 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2219 bits = value_bitsize (component);
2221 if (BITS_BIG_ENDIAN)
2222 move_bits (value_contents_writeable (container) + offset_in_container,
2223 value_bitpos (container) + bit_offset_in_container,
2224 value_contents (val),
2225 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2228 move_bits (value_contents_writeable (container) + offset_in_container,
2229 value_bitpos (container) + bit_offset_in_container,
2230 value_contents (val), 0, bits);
2233 /* The value of the element of array ARR at the ARITY indices given in IND.
2234 ARR may be either a simple array, GNAT array descriptor, or pointer
2238 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2242 struct type *elt_type;
2244 elt = ada_coerce_to_simple_array (arr);
2246 elt_type = ada_check_typedef (value_type (elt));
2247 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2248 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2249 return value_subscript_packed (elt, arity, ind);
2251 for (k = 0; k < arity; k += 1)
2253 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2254 error (_("too many subscripts (%d expected)"), k);
2255 elt = value_subscript (elt, value_pos_atr (ind[k]));
2260 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2261 value of the element of *ARR at the ARITY indices given in
2262 IND. Does not read the entire array into memory. */
2265 ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
2270 for (k = 0; k < arity; k += 1)
2275 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2276 error (_("too many subscripts (%d expected)"), k);
2277 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2279 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2280 idx = value_pos_atr (ind[k]);
2282 idx = value_sub (idx, value_from_longest (builtin_type_int, lwb));
2283 arr = value_add (arr, idx);
2284 type = TYPE_TARGET_TYPE (type);
2287 return value_ind (arr);
2290 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2291 actual type of ARRAY_PTR is ignored), returns a reference to
2292 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2293 bound of this array is LOW, as per Ada rules. */
2294 static struct value *
2295 ada_value_slice_ptr (struct value *array_ptr, struct type *type,
2298 CORE_ADDR base = value_as_address (array_ptr)
2299 + ((low - TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type)))
2300 * TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
2301 struct type *index_type =
2302 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)),
2304 struct type *slice_type =
2305 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2306 return value_from_pointer (lookup_reference_type (slice_type), base);
2310 static struct value *
2311 ada_value_slice (struct value *array, int low, int high)
2313 struct type *type = value_type (array);
2314 struct type *index_type =
2315 create_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2316 struct type *slice_type =
2317 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2318 return value_cast (slice_type, value_slice (array, low, high - low + 1));
2321 /* If type is a record type in the form of a standard GNAT array
2322 descriptor, returns the number of dimensions for type. If arr is a
2323 simple array, returns the number of "array of"s that prefix its
2324 type designation. Otherwise, returns 0. */
2327 ada_array_arity (struct type *type)
2334 type = desc_base_type (type);
2337 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2338 return desc_arity (desc_bounds_type (type));
2340 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2343 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2349 /* If TYPE is a record type in the form of a standard GNAT array
2350 descriptor or a simple array type, returns the element type for
2351 TYPE after indexing by NINDICES indices, or by all indices if
2352 NINDICES is -1. Otherwise, returns NULL. */
2355 ada_array_element_type (struct type *type, int nindices)
2357 type = desc_base_type (type);
2359 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2362 struct type *p_array_type;
2364 p_array_type = desc_data_type (type);
2366 k = ada_array_arity (type);
2370 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2371 if (nindices >= 0 && k > nindices)
2373 p_array_type = TYPE_TARGET_TYPE (p_array_type);
2374 while (k > 0 && p_array_type != NULL)
2376 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2379 return p_array_type;
2381 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2383 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
2385 type = TYPE_TARGET_TYPE (type);
2394 /* The type of nth index in arrays of given type (n numbering from 1).
2395 Does not examine memory. */
2398 ada_index_type (struct type *type, int n)
2400 struct type *result_type;
2402 type = desc_base_type (type);
2404 if (n > ada_array_arity (type))
2407 if (ada_is_simple_array_type (type))
2411 for (i = 1; i < n; i += 1)
2412 type = TYPE_TARGET_TYPE (type);
2413 result_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 0));
2414 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2415 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2416 perhaps stabsread.c would make more sense. */
2417 if (result_type == NULL || TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2418 result_type = builtin_type_int;
2423 return desc_index_type (desc_bounds_type (type), n);
2426 /* Given that arr is an array type, returns the lower bound of the
2427 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2428 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2429 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2430 bounds type. It works for other arrays with bounds supplied by
2431 run-time quantities other than discriminants. */
2434 ada_array_bound_from_type (struct type * arr_type, int n, int which,
2435 struct type ** typep)
2438 struct type *index_type_desc;
2440 if (ada_is_packed_array_type (arr_type))
2441 arr_type = decode_packed_array_type (arr_type);
2443 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2446 *typep = builtin_type_int;
2447 return (LONGEST) - which;
2450 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2451 type = TYPE_TARGET_TYPE (arr_type);
2455 index_type_desc = ada_find_parallel_type (type, "___XA");
2456 if (index_type_desc == NULL)
2458 struct type *range_type;
2459 struct type *index_type;
2463 type = TYPE_TARGET_TYPE (type);
2467 range_type = TYPE_INDEX_TYPE (type);
2468 index_type = TYPE_TARGET_TYPE (range_type);
2469 if (TYPE_CODE (index_type) == TYPE_CODE_UNDEF)
2470 index_type = builtin_type_long;
2472 *typep = index_type;
2474 (LONGEST) (which == 0
2475 ? TYPE_LOW_BOUND (range_type)
2476 : TYPE_HIGH_BOUND (range_type));
2480 struct type *index_type =
2481 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n - 1),
2482 NULL, TYPE_OBJFILE (arr_type));
2484 *typep = TYPE_TARGET_TYPE (index_type);
2486 (LONGEST) (which == 0
2487 ? TYPE_LOW_BOUND (index_type)
2488 : TYPE_HIGH_BOUND (index_type));
2492 /* Given that arr is an array value, returns the lower bound of the
2493 nth index (numbering from 1) if which is 0, and the upper bound if
2494 which is 1. This routine will also work for arrays with bounds
2495 supplied by run-time quantities other than discriminants. */
2498 ada_array_bound (struct value *arr, int n, int which)
2500 struct type *arr_type = value_type (arr);
2502 if (ada_is_packed_array_type (arr_type))
2503 return ada_array_bound (decode_packed_array (arr), n, which);
2504 else if (ada_is_simple_array_type (arr_type))
2507 LONGEST v = ada_array_bound_from_type (arr_type, n, which, &type);
2508 return value_from_longest (type, v);
2511 return desc_one_bound (desc_bounds (arr), n, which);
2514 /* Given that arr is an array value, returns the length of the
2515 nth index. This routine will also work for arrays with bounds
2516 supplied by run-time quantities other than discriminants.
2517 Does not work for arrays indexed by enumeration types with representation
2518 clauses at the moment. */
2521 ada_array_length (struct value *arr, int n)
2523 struct type *arr_type = ada_check_typedef (value_type (arr));
2525 if (ada_is_packed_array_type (arr_type))
2526 return ada_array_length (decode_packed_array (arr), n);
2528 if (ada_is_simple_array_type (arr_type))
2532 ada_array_bound_from_type (arr_type, n, 1, &type) -
2533 ada_array_bound_from_type (arr_type, n, 0, NULL) + 1;
2534 return value_from_longest (type, v);
2538 value_from_longest (builtin_type_int,
2539 value_as_long (desc_one_bound (desc_bounds (arr),
2541 - value_as_long (desc_one_bound (desc_bounds (arr),
2545 /* An empty array whose type is that of ARR_TYPE (an array type),
2546 with bounds LOW to LOW-1. */
2548 static struct value *
2549 empty_array (struct type *arr_type, int low)
2551 struct type *index_type =
2552 create_range_type (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type)),
2554 struct type *elt_type = ada_array_element_type (arr_type, 1);
2555 return allocate_value (create_array_type (NULL, elt_type, index_type));
2559 /* Name resolution */
2561 /* The "decoded" name for the user-definable Ada operator corresponding
2565 ada_decoded_op_name (enum exp_opcode op)
2569 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
2571 if (ada_opname_table[i].op == op)
2572 return ada_opname_table[i].decoded;
2574 error (_("Could not find operator name for opcode"));
2578 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2579 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2580 undefined namespace) and converts operators that are
2581 user-defined into appropriate function calls. If CONTEXT_TYPE is
2582 non-null, it provides a preferred result type [at the moment, only
2583 type void has any effect---causing procedures to be preferred over
2584 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2585 return type is preferred. May change (expand) *EXP. */
2588 resolve (struct expression **expp, int void_context_p)
2592 resolve_subexp (expp, &pc, 1, void_context_p ? builtin_type_void : NULL);
2595 /* Resolve the operator of the subexpression beginning at
2596 position *POS of *EXPP. "Resolving" consists of replacing
2597 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2598 with their resolutions, replacing built-in operators with
2599 function calls to user-defined operators, where appropriate, and,
2600 when DEPROCEDURE_P is non-zero, converting function-valued variables
2601 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2602 are as in ada_resolve, above. */
2604 static struct value *
2605 resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
2606 struct type *context_type)
2610 struct expression *exp; /* Convenience: == *expp. */
2611 enum exp_opcode op = (*expp)->elts[pc].opcode;
2612 struct value **argvec; /* Vector of operand types (alloca'ed). */
2613 int nargs; /* Number of operands. */
2620 /* Pass one: resolve operands, saving their types and updating *pos,
2625 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2626 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2631 resolve_subexp (expp, pos, 0, NULL);
2633 nargs = longest_to_int (exp->elts[pc + 1].longconst);
2638 resolve_subexp (expp, pos, 0, NULL);
2643 resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2646 case OP_ATR_MODULUS:
2656 case TERNOP_IN_RANGE:
2657 case BINOP_IN_BOUNDS:
2663 case OP_DISCRETE_RANGE:
2665 ada_forward_operator_length (exp, pc, &oplen, &nargs);
2674 arg1 = resolve_subexp (expp, pos, 0, NULL);
2676 resolve_subexp (expp, pos, 1, NULL);
2678 resolve_subexp (expp, pos, 1, value_type (arg1));
2695 case BINOP_LOGICAL_AND:
2696 case BINOP_LOGICAL_OR:
2697 case BINOP_BITWISE_AND:
2698 case BINOP_BITWISE_IOR:
2699 case BINOP_BITWISE_XOR:
2702 case BINOP_NOTEQUAL:
2709 case BINOP_SUBSCRIPT:
2714 case UNOP_LOGICAL_NOT:
2731 case OP_INTERNALVAR:
2740 case STRUCTOP_STRUCT:
2741 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2754 error (_("Unexpected operator during name resolution"));
2757 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
2758 for (i = 0; i < nargs; i += 1)
2759 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
2763 /* Pass two: perform any resolution on principal operator. */
2770 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
2772 struct ada_symbol_info *candidates;
2776 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2777 (exp->elts[pc + 2].symbol),
2778 exp->elts[pc + 1].block, VAR_DOMAIN,
2781 if (n_candidates > 1)
2783 /* Types tend to get re-introduced locally, so if there
2784 are any local symbols that are not types, first filter
2787 for (j = 0; j < n_candidates; j += 1)
2788 switch (SYMBOL_CLASS (candidates[j].sym))
2794 case LOC_REGPARM_ADDR:
2798 case LOC_BASEREG_ARG:
2800 case LOC_COMPUTED_ARG:
2806 if (j < n_candidates)
2809 while (j < n_candidates)
2811 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
2813 candidates[j] = candidates[n_candidates - 1];
2822 if (n_candidates == 0)
2823 error (_("No definition found for %s"),
2824 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2825 else if (n_candidates == 1)
2827 else if (deprocedure_p
2828 && !is_nonfunction (candidates, n_candidates))
2830 i = ada_resolve_function
2831 (candidates, n_candidates, NULL, 0,
2832 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
2835 error (_("Could not find a match for %s"),
2836 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2840 printf_filtered (_("Multiple matches for %s\n"),
2841 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2842 user_select_syms (candidates, n_candidates, 1);
2846 exp->elts[pc + 1].block = candidates[i].block;
2847 exp->elts[pc + 2].symbol = candidates[i].sym;
2848 if (innermost_block == NULL
2849 || contained_in (candidates[i].block, innermost_block))
2850 innermost_block = candidates[i].block;
2854 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
2857 replace_operator_with_call (expp, pc, 0, 0,
2858 exp->elts[pc + 2].symbol,
2859 exp->elts[pc + 1].block);
2866 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
2867 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2869 struct ada_symbol_info *candidates;
2873 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2874 (exp->elts[pc + 5].symbol),
2875 exp->elts[pc + 4].block, VAR_DOMAIN,
2877 if (n_candidates == 1)
2881 i = ada_resolve_function
2882 (candidates, n_candidates,
2884 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
2887 error (_("Could not find a match for %s"),
2888 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
2891 exp->elts[pc + 4].block = candidates[i].block;
2892 exp->elts[pc + 5].symbol = candidates[i].sym;
2893 if (innermost_block == NULL
2894 || contained_in (candidates[i].block, innermost_block))
2895 innermost_block = candidates[i].block;
2906 case BINOP_BITWISE_AND:
2907 case BINOP_BITWISE_IOR:
2908 case BINOP_BITWISE_XOR:
2910 case BINOP_NOTEQUAL:
2918 case UNOP_LOGICAL_NOT:
2920 if (possible_user_operator_p (op, argvec))
2922 struct ada_symbol_info *candidates;
2926 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
2927 (struct block *) NULL, VAR_DOMAIN,
2929 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
2930 ada_decoded_op_name (op), NULL);
2934 replace_operator_with_call (expp, pc, nargs, 1,
2935 candidates[i].sym, candidates[i].block);
2945 return evaluate_subexp_type (exp, pos);
2948 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2949 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2950 a non-pointer. A type of 'void' (which is never a valid expression type)
2951 by convention matches anything. */
2952 /* The term "match" here is rather loose. The match is heuristic and
2953 liberal. FIXME: TOO liberal, in fact. */
2956 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
2958 ftype = ada_check_typedef (ftype);
2959 atype = ada_check_typedef (atype);
2961 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
2962 ftype = TYPE_TARGET_TYPE (ftype);
2963 if (TYPE_CODE (atype) == TYPE_CODE_REF)
2964 atype = TYPE_TARGET_TYPE (atype);
2966 if (TYPE_CODE (ftype) == TYPE_CODE_VOID
2967 || TYPE_CODE (atype) == TYPE_CODE_VOID)
2970 switch (TYPE_CODE (ftype))
2975 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
2976 return ada_type_match (TYPE_TARGET_TYPE (ftype),
2977 TYPE_TARGET_TYPE (atype), 0);
2980 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
2982 case TYPE_CODE_ENUM:
2983 case TYPE_CODE_RANGE:
2984 switch (TYPE_CODE (atype))
2987 case TYPE_CODE_ENUM:
2988 case TYPE_CODE_RANGE:
2994 case TYPE_CODE_ARRAY:
2995 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
2996 || ada_is_array_descriptor_type (atype));
2998 case TYPE_CODE_STRUCT:
2999 if (ada_is_array_descriptor_type (ftype))
3000 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3001 || ada_is_array_descriptor_type (atype));
3003 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3004 && !ada_is_array_descriptor_type (atype));
3006 case TYPE_CODE_UNION:
3008 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3012 /* Return non-zero if the formals of FUNC "sufficiently match" the
3013 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3014 may also be an enumeral, in which case it is treated as a 0-
3015 argument function. */
3018 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3021 struct type *func_type = SYMBOL_TYPE (func);
3023 if (SYMBOL_CLASS (func) == LOC_CONST
3024 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3025 return (n_actuals == 0);
3026 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3029 if (TYPE_NFIELDS (func_type) != n_actuals)
3032 for (i = 0; i < n_actuals; i += 1)
3034 if (actuals[i] == NULL)
3038 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type, i));
3039 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3041 if (!ada_type_match (ftype, atype, 1))
3048 /* False iff function type FUNC_TYPE definitely does not produce a value
3049 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3050 FUNC_TYPE is not a valid function type with a non-null return type
3051 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3054 return_match (struct type *func_type, struct type *context_type)
3056 struct type *return_type;
3058 if (func_type == NULL)
3061 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3062 return_type = base_type (TYPE_TARGET_TYPE (func_type));
3064 return_type = base_type (func_type);
3065 if (return_type == NULL)
3068 context_type = base_type (context_type);
3070 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3071 return context_type == NULL || return_type == context_type;
3072 else if (context_type == NULL)
3073 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3075 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3079 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3080 function (if any) that matches the types of the NARGS arguments in
3081 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3082 that returns that type, then eliminate matches that don't. If
3083 CONTEXT_TYPE is void and there is at least one match that does not
3084 return void, eliminate all matches that do.
3086 Asks the user if there is more than one match remaining. Returns -1
3087 if there is no such symbol or none is selected. NAME is used
3088 solely for messages. May re-arrange and modify SYMS in
3089 the process; the index returned is for the modified vector. */
3092 ada_resolve_function (struct ada_symbol_info syms[],
3093 int nsyms, struct value **args, int nargs,
3094 const char *name, struct type *context_type)
3097 int m; /* Number of hits */
3098 struct type *fallback;
3099 struct type *return_type;
3101 return_type = context_type;
3102 if (context_type == NULL)
3103 fallback = builtin_type_void;
3110 for (k = 0; k < nsyms; k += 1)
3112 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
3114 if (ada_args_match (syms[k].sym, args, nargs)
3115 && return_match (type, return_type))
3121 if (m > 0 || return_type == fallback)
3124 return_type = fallback;
3131 printf_filtered (_("Multiple matches for %s\n"), name);
3132 user_select_syms (syms, m, 1);
3138 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3139 in a listing of choices during disambiguation (see sort_choices, below).
3140 The idea is that overloadings of a subprogram name from the
3141 same package should sort in their source order. We settle for ordering
3142 such symbols by their trailing number (__N or $N). */
3145 encoded_ordered_before (char *N0, char *N1)
3149 else if (N0 == NULL)
3154 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3156 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3158 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3159 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3163 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3166 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3168 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3169 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3171 return (strcmp (N0, N1) < 0);
3175 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3179 sort_choices (struct ada_symbol_info syms[], int nsyms)
3182 for (i = 1; i < nsyms; i += 1)
3184 struct ada_symbol_info sym = syms[i];
3187 for (j = i - 1; j >= 0; j -= 1)
3189 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3190 SYMBOL_LINKAGE_NAME (sym.sym)))
3192 syms[j + 1] = syms[j];
3198 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3199 by asking the user (if necessary), returning the number selected,
3200 and setting the first elements of SYMS items. Error if no symbols
3203 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3204 to be re-integrated one of these days. */
3207 user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
3210 int *chosen = (int *) alloca (sizeof (int) * nsyms);
3212 int first_choice = (max_results == 1) ? 1 : 2;
3214 if (max_results < 1)
3215 error (_("Request to select 0 symbols!"));
3219 printf_unfiltered (_("[0] cancel\n"));
3220 if (max_results > 1)
3221 printf_unfiltered (_("[1] all\n"));
3223 sort_choices (syms, nsyms);
3225 for (i = 0; i < nsyms; i += 1)
3227 if (syms[i].sym == NULL)
3230 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3232 struct symtab_and_line sal =
3233 find_function_start_sal (syms[i].sym, 1);
3234 if (sal.symtab == NULL)
3235 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3237 SYMBOL_PRINT_NAME (syms[i].sym),
3240 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3241 SYMBOL_PRINT_NAME (syms[i].sym),
3242 sal.symtab->filename, sal.line);
3248 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3249 && SYMBOL_TYPE (syms[i].sym) != NULL
3250 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
3251 struct symtab *symtab = symtab_for_sym (syms[i].sym);
3253 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
3254 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3256 SYMBOL_PRINT_NAME (syms[i].sym),
3257 symtab->filename, SYMBOL_LINE (syms[i].sym));
3258 else if (is_enumeral
3259 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
3261 printf_unfiltered (("[%d] "), i + first_choice);
3262 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
3264 printf_unfiltered (_("'(%s) (enumeral)\n"),
3265 SYMBOL_PRINT_NAME (syms[i].sym));
3267 else if (symtab != NULL)
3268 printf_unfiltered (is_enumeral
3269 ? _("[%d] %s in %s (enumeral)\n")
3270 : _("[%d] %s at %s:?\n"),
3272 SYMBOL_PRINT_NAME (syms[i].sym),
3275 printf_unfiltered (is_enumeral
3276 ? _("[%d] %s (enumeral)\n")
3277 : _("[%d] %s at ?\n"),
3279 SYMBOL_PRINT_NAME (syms[i].sym));
3283 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3286 for (i = 0; i < n_chosen; i += 1)
3287 syms[i] = syms[chosen[i]];
3292 /* Read and validate a set of numeric choices from the user in the
3293 range 0 .. N_CHOICES-1. Place the results in increasing
3294 order in CHOICES[0 .. N-1], and return N.
3296 The user types choices as a sequence of numbers on one line
3297 separated by blanks, encoding them as follows:
3299 + A choice of 0 means to cancel the selection, throwing an error.
3300 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3301 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3303 The user is not allowed to choose more than MAX_RESULTS values.
3305 ANNOTATION_SUFFIX, if present, is used to annotate the input
3306 prompts (for use with the -f switch). */
3309 get_selections (int *choices, int n_choices, int max_results,
3310 int is_all_choice, char *annotation_suffix)
3315 int first_choice = is_all_choice ? 2 : 1;
3317 prompt = getenv ("PS2");
3321 printf_unfiltered (("%s "), prompt);
3322 gdb_flush (gdb_stdout);
3324 args = command_line_input ((char *) NULL, 0, annotation_suffix);
3327 error_no_arg (_("one or more choice numbers"));
3331 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3332 order, as given in args. Choices are validated. */
3338 while (isspace (*args))
3340 if (*args == '\0' && n_chosen == 0)
3341 error_no_arg (_("one or more choice numbers"));
3342 else if (*args == '\0')
3345 choice = strtol (args, &args2, 10);
3346 if (args == args2 || choice < 0
3347 || choice > n_choices + first_choice - 1)
3348 error (_("Argument must be choice number"));
3352 error (_("cancelled"));
3354 if (choice < first_choice)
3356 n_chosen = n_choices;
3357 for (j = 0; j < n_choices; j += 1)
3361 choice -= first_choice;
3363 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3367 if (j < 0 || choice != choices[j])
3370 for (k = n_chosen - 1; k > j; k -= 1)
3371 choices[k + 1] = choices[k];
3372 choices[j + 1] = choice;
3377 if (n_chosen > max_results)
3378 error (_("Select no more than %d of the above"), max_results);
3383 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3384 on the function identified by SYM and BLOCK, and taking NARGS
3385 arguments. Update *EXPP as needed to hold more space. */
3388 replace_operator_with_call (struct expression **expp, int pc, int nargs,
3389 int oplen, struct symbol *sym,
3390 struct block *block)
3392 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3393 symbol, -oplen for operator being replaced). */
3394 struct expression *newexp = (struct expression *)
3395 xmalloc (sizeof (struct expression)
3396 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
3397 struct expression *exp = *expp;
3399 newexp->nelts = exp->nelts + 7 - oplen;
3400 newexp->language_defn = exp->language_defn;
3401 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
3402 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
3403 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
3405 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3406 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3408 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3409 newexp->elts[pc + 4].block = block;
3410 newexp->elts[pc + 5].symbol = sym;
3416 /* Type-class predicates */
3418 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3422 numeric_type_p (struct type *type)
3428 switch (TYPE_CODE (type))
3433 case TYPE_CODE_RANGE:
3434 return (type == TYPE_TARGET_TYPE (type)
3435 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3442 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3445 integer_type_p (struct type *type)
3451 switch (TYPE_CODE (type))
3455 case TYPE_CODE_RANGE:
3456 return (type == TYPE_TARGET_TYPE (type)
3457 || integer_type_p (TYPE_TARGET_TYPE (type)));
3464 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3467 scalar_type_p (struct type *type)
3473 switch (TYPE_CODE (type))
3476 case TYPE_CODE_RANGE:
3477 case TYPE_CODE_ENUM:
3486 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3489 discrete_type_p (struct type *type)
3495 switch (TYPE_CODE (type))
3498 case TYPE_CODE_RANGE:
3499 case TYPE_CODE_ENUM:
3507 /* Returns non-zero if OP with operands in the vector ARGS could be
3508 a user-defined function. Errs on the side of pre-defined operators
3509 (i.e., result 0). */
3512 possible_user_operator_p (enum exp_opcode op, struct value *args[])
3514 struct type *type0 =
3515 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
3516 struct type *type1 =
3517 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
3531 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
3535 case BINOP_BITWISE_AND:
3536 case BINOP_BITWISE_IOR:
3537 case BINOP_BITWISE_XOR:
3538 return (!(integer_type_p (type0) && integer_type_p (type1)));
3541 case BINOP_NOTEQUAL:
3546 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
3550 ((TYPE_CODE (type0) != TYPE_CODE_ARRAY
3551 && (TYPE_CODE (type0) != TYPE_CODE_PTR
3552 || TYPE_CODE (TYPE_TARGET_TYPE (type0)) != TYPE_CODE_ARRAY))
3553 || (TYPE_CODE (type1) != TYPE_CODE_ARRAY
3554 && (TYPE_CODE (type1) != TYPE_CODE_PTR
3555 || (TYPE_CODE (TYPE_TARGET_TYPE (type1))
3556 != TYPE_CODE_ARRAY))));
3559 return (!(numeric_type_p (type0) && integer_type_p (type1)));
3563 case UNOP_LOGICAL_NOT:
3565 return (!numeric_type_p (type0));
3572 /* NOTE: In the following, we assume that a renaming type's name may
3573 have an ___XD suffix. It would be nice if this went away at some
3576 /* If TYPE encodes a renaming, returns the renaming suffix, which
3577 is XR for an object renaming, XRP for a procedure renaming, XRE for
3578 an exception renaming, and XRS for a subprogram renaming. Returns
3579 NULL if NAME encodes none of these. */
3582 ada_renaming_type (struct type *type)
3584 if (type != NULL && TYPE_CODE (type) == TYPE_CODE_ENUM)
3586 const char *name = type_name_no_tag (type);
3587 const char *suffix = (name == NULL) ? NULL : strstr (name, "___XR");
3589 || (suffix[5] != '\000' && strchr ("PES_", suffix[5]) == NULL))
3598 /* Return non-zero iff SYM encodes an object renaming. */
3601 ada_is_object_renaming (struct symbol *sym)
3603 const char *renaming_type = ada_renaming_type (SYMBOL_TYPE (sym));
3604 return renaming_type != NULL
3605 && (renaming_type[2] == '\0' || renaming_type[2] == '_');
3608 /* Assuming that SYM encodes a non-object renaming, returns the original
3609 name of the renamed entity. The name is good until the end of
3613 ada_simple_renamed_entity (struct symbol *sym)
3616 const char *raw_name;
3620 type = SYMBOL_TYPE (sym);
3621 if (type == NULL || TYPE_NFIELDS (type) < 1)
3622 error (_("Improperly encoded renaming."));
3624 raw_name = TYPE_FIELD_NAME (type, 0);
3625 len = (raw_name == NULL ? 0 : strlen (raw_name)) - 5;
3627 error (_("Improperly encoded renaming."));
3629 result = xmalloc (len + 1);
3630 strncpy (result, raw_name, len);
3631 result[len] = '\000';
3637 /* Evaluation: Function Calls */
3639 /* Return an lvalue containing the value VAL. This is the identity on
3640 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3641 on the stack, using and updating *SP as the stack pointer, and
3642 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3644 static struct value *
3645 ensure_lval (struct value *val, CORE_ADDR *sp)
3647 if (! VALUE_LVAL (val))
3649 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
3651 /* The following is taken from the structure-return code in
3652 call_function_by_hand. FIXME: Therefore, some refactoring seems
3654 if (INNER_THAN (1, 2))
3656 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3657 reserving sufficient space. */
3659 if (gdbarch_frame_align_p (current_gdbarch))
3660 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3661 VALUE_ADDRESS (val) = *sp;
3665 /* Stack grows upward. Align the frame, allocate space, and
3666 then again, re-align the frame. */
3667 if (gdbarch_frame_align_p (current_gdbarch))
3668 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3669 VALUE_ADDRESS (val) = *sp;
3671 if (gdbarch_frame_align_p (current_gdbarch))
3672 *sp = gdbarch_frame_align (current_gdbarch, *sp);
3675 write_memory (VALUE_ADDRESS (val), value_contents_raw (val), len);
3681 /* Return the value ACTUAL, converted to be an appropriate value for a
3682 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3683 allocating any necessary descriptors (fat pointers), or copies of
3684 values not residing in memory, updating it as needed. */
3686 static struct value *
3687 convert_actual (struct value *actual, struct type *formal_type0,
3690 struct type *actual_type = ada_check_typedef (value_type (actual));
3691 struct type *formal_type = ada_check_typedef (formal_type0);
3692 struct type *formal_target =
3693 TYPE_CODE (formal_type) == TYPE_CODE_PTR
3694 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
3695 struct type *actual_target =
3696 TYPE_CODE (actual_type) == TYPE_CODE_PTR
3697 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
3699 if (ada_is_array_descriptor_type (formal_target)
3700 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
3701 return make_array_descriptor (formal_type, actual, sp);
3702 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR)
3704 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
3705 && ada_is_array_descriptor_type (actual_target))
3706 return desc_data (actual);
3707 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
3709 if (VALUE_LVAL (actual) != lval_memory)
3712 actual_type = ada_check_typedef (value_type (actual));
3713 val = allocate_value (actual_type);
3714 memcpy ((char *) value_contents_raw (val),
3715 (char *) value_contents (actual),
3716 TYPE_LENGTH (actual_type));
3717 actual = ensure_lval (val, sp);
3719 return value_addr (actual);
3722 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
3723 return ada_value_ind (actual);
3729 /* Push a descriptor of type TYPE for array value ARR on the stack at
3730 *SP, updating *SP to reflect the new descriptor. Return either
3731 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3732 to-descriptor type rather than a descriptor type), a struct value *
3733 representing a pointer to this descriptor. */
3735 static struct value *
3736 make_array_descriptor (struct type *type, struct value *arr, CORE_ADDR *sp)
3738 struct type *bounds_type = desc_bounds_type (type);
3739 struct type *desc_type = desc_base_type (type);
3740 struct value *descriptor = allocate_value (desc_type);
3741 struct value *bounds = allocate_value (bounds_type);
3744 for (i = ada_array_arity (ada_check_typedef (value_type (arr))); i > 0; i -= 1)
3746 modify_general_field (value_contents_writeable (bounds),
3747 value_as_long (ada_array_bound (arr, i, 0)),
3748 desc_bound_bitpos (bounds_type, i, 0),
3749 desc_bound_bitsize (bounds_type, i, 0));
3750 modify_general_field (value_contents_writeable (bounds),
3751 value_as_long (ada_array_bound (arr, i, 1)),
3752 desc_bound_bitpos (bounds_type, i, 1),
3753 desc_bound_bitsize (bounds_type, i, 1));
3756 bounds = ensure_lval (bounds, sp);
3758 modify_general_field (value_contents_writeable (descriptor),
3759 VALUE_ADDRESS (ensure_lval (arr, sp)),
3760 fat_pntr_data_bitpos (desc_type),
3761 fat_pntr_data_bitsize (desc_type));
3763 modify_general_field (value_contents_writeable (descriptor),
3764 VALUE_ADDRESS (bounds),
3765 fat_pntr_bounds_bitpos (desc_type),
3766 fat_pntr_bounds_bitsize (desc_type));
3768 descriptor = ensure_lval (descriptor, sp);
3770 if (TYPE_CODE (type) == TYPE_CODE_PTR)
3771 return value_addr (descriptor);
3777 /* Assuming a dummy frame has been established on the target, perform any
3778 conversions needed for calling function FUNC on the NARGS actual
3779 parameters in ARGS, other than standard C conversions. Does
3780 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3781 does not match the number of arguments expected. Use *SP as a
3782 stack pointer for additional data that must be pushed, updating its
3786 ada_convert_actuals (struct value *func, int nargs, struct value *args[],
3791 if (TYPE_NFIELDS (value_type (func)) == 0
3792 || nargs != TYPE_NFIELDS (value_type (func)))
3795 for (i = 0; i < nargs; i += 1)
3797 convert_actual (args[i], TYPE_FIELD_TYPE (value_type (func), i), sp);
3800 /* Dummy definitions for an experimental caching module that is not
3801 * used in the public sources. */
3804 lookup_cached_symbol (const char *name, domain_enum namespace,
3805 struct symbol **sym, struct block **block,
3806 struct symtab **symtab)
3812 cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
3813 struct block *block, struct symtab *symtab)
3819 /* Return the result of a standard (literal, C-like) lookup of NAME in
3820 given DOMAIN, visible from lexical block BLOCK. */
3822 static struct symbol *
3823 standard_lookup (const char *name, const struct block *block,
3827 struct symtab *symtab;
3829 if (lookup_cached_symbol (name, domain, &sym, NULL, NULL))
3832 lookup_symbol_in_language (name, block, domain, language_c, 0, &symtab);
3833 cache_symbol (name, domain, sym, block_found, symtab);
3838 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3839 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3840 since they contend in overloading in the same way. */
3842 is_nonfunction (struct ada_symbol_info syms[], int n)
3846 for (i = 0; i < n; i += 1)
3847 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
3848 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
3849 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
3855 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3856 struct types. Otherwise, they may not. */
3859 equiv_types (struct type *type0, struct type *type1)
3863 if (type0 == NULL || type1 == NULL
3864 || TYPE_CODE (type0) != TYPE_CODE (type1))
3866 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
3867 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
3868 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
3869 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
3875 /* True iff SYM0 represents the same entity as SYM1, or one that is
3876 no more defined than that of SYM1. */
3879 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
3883 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
3884 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
3887 switch (SYMBOL_CLASS (sym0))
3893 struct type *type0 = SYMBOL_TYPE (sym0);
3894 struct type *type1 = SYMBOL_TYPE (sym1);
3895 char *name0 = SYMBOL_LINKAGE_NAME (sym0);
3896 char *name1 = SYMBOL_LINKAGE_NAME (sym1);
3897 int len0 = strlen (name0);
3899 TYPE_CODE (type0) == TYPE_CODE (type1)
3900 && (equiv_types (type0, type1)
3901 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
3902 && strncmp (name1 + len0, "___XV", 5) == 0));
3905 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
3906 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
3912 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3913 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3916 add_defn_to_vec (struct obstack *obstackp,
3918 struct block *block, struct symtab *symtab)
3922 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
3924 /* Do not try to complete stub types, as the debugger is probably
3925 already scanning all symbols matching a certain name at the
3926 time when this function is called. Trying to replace the stub
3927 type by its associated full type will cause us to restart a scan
3928 which may lead to an infinite recursion. Instead, the client
3929 collecting the matching symbols will end up collecting several
3930 matches, with at least one of them complete. It can then filter
3931 out the stub ones if needed. */
3933 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
3935 if (lesseq_defined_than (sym, prevDefns[i].sym))
3937 else if (lesseq_defined_than (prevDefns[i].sym, sym))
3939 prevDefns[i].sym = sym;
3940 prevDefns[i].block = block;
3941 prevDefns[i].symtab = symtab;
3947 struct ada_symbol_info info;
3951 info.symtab = symtab;
3952 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
3956 /* Number of ada_symbol_info structures currently collected in
3957 current vector in *OBSTACKP. */
3960 num_defns_collected (struct obstack *obstackp)
3962 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
3965 /* Vector of ada_symbol_info structures currently collected in current
3966 vector in *OBSTACKP. If FINISH, close off the vector and return
3967 its final address. */
3969 static struct ada_symbol_info *
3970 defns_collected (struct obstack *obstackp, int finish)
3973 return obstack_finish (obstackp);
3975 return (struct ada_symbol_info *) obstack_base (obstackp);
3978 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3979 Check the global symbols if GLOBAL, the static symbols if not.
3980 Do wild-card match if WILD. */
3982 static struct partial_symbol *
3983 ada_lookup_partial_symbol (struct partial_symtab *pst, const char *name,
3984 int global, domain_enum namespace, int wild)
3986 struct partial_symbol **start;
3987 int name_len = strlen (name);
3988 int length = (global ? pst->n_global_syms : pst->n_static_syms);
3997 pst->objfile->global_psymbols.list + pst->globals_offset :
3998 pst->objfile->static_psymbols.list + pst->statics_offset);
4002 for (i = 0; i < length; i += 1)
4004 struct partial_symbol *psym = start[i];
4006 if (SYMBOL_DOMAIN (psym) == namespace
4007 && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (psym)))
4021 int M = (U + i) >> 1;
4022 struct partial_symbol *psym = start[M];
4023 if (SYMBOL_LINKAGE_NAME (psym)[0] < name[0])
4025 else if (SYMBOL_LINKAGE_NAME (psym)[0] > name[0])
4027 else if (strcmp (SYMBOL_LINKAGE_NAME (psym), name) < 0)
4038 struct partial_symbol *psym = start[i];
4040 if (SYMBOL_DOMAIN (psym) == namespace)
4042 int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym), name_len);
4050 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)
4064 int M = (U + i) >> 1;
4065 struct partial_symbol *psym = start[M];
4066 if (SYMBOL_LINKAGE_NAME (psym)[0] < '_')
4068 else if (SYMBOL_LINKAGE_NAME (psym)[0] > '_')
4070 else if (strcmp (SYMBOL_LINKAGE_NAME (psym), "_ada_") < 0)
4081 struct partial_symbol *psym = start[i];
4083 if (SYMBOL_DOMAIN (psym) == namespace)
4087 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym)[0];
4090 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym), 5);
4092 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym) + 5,
4102 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)
4112 /* Find a symbol table containing symbol SYM or NULL if none. */
4114 static struct symtab *
4115 symtab_for_sym (struct symbol *sym)
4118 struct objfile *objfile;
4120 struct symbol *tmp_sym;
4121 struct dict_iterator iter;
4124 ALL_SYMTABS (objfile, s)
4126 switch (SYMBOL_CLASS (sym))
4134 case LOC_CONST_BYTES:
4135 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
4136 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4138 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
4139 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4145 switch (SYMBOL_CLASS (sym))
4151 case LOC_REGPARM_ADDR:
4156 case LOC_BASEREG_ARG:
4158 case LOC_COMPUTED_ARG:
4159 for (j = FIRST_LOCAL_BLOCK;
4160 j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s)); j += 1)
4162 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), j);
4163 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4174 /* Return a minimal symbol matching NAME according to Ada decoding
4175 rules. Returns NULL if there is no such minimal symbol. Names
4176 prefixed with "standard__" are handled specially: "standard__" is
4177 first stripped off, and only static and global symbols are searched. */
4179 struct minimal_symbol *
4180 ada_lookup_simple_minsym (const char *name)
4182 struct objfile *objfile;
4183 struct minimal_symbol *msymbol;
4186 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
4188 name += sizeof ("standard__") - 1;
4192 wild_match = (strstr (name, "__") == NULL);
4194 ALL_MSYMBOLS (objfile, msymbol)
4196 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match)
4197 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4204 /* For all subprograms that statically enclose the subprogram of the
4205 selected frame, add symbols matching identifier NAME in DOMAIN
4206 and their blocks to the list of data in OBSTACKP, as for
4207 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4211 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4212 const char *name, domain_enum namespace,
4217 /* FIXME: The next two routines belong in symtab.c */
4220 restore_language (void *lang)
4222 set_language ((enum language) lang);
4225 /* As for lookup_symbol, but performed as if the current language
4229 lookup_symbol_in_language (const char *name, const struct block *block,
4230 domain_enum domain, enum language lang,
4231 int *is_a_field_of_this, struct symtab **symtab)
4233 struct cleanup *old_chain
4234 = make_cleanup (restore_language, (void *) current_language->la_language);
4235 struct symbol *result;
4236 set_language (lang);
4237 result = lookup_symbol (name, block, domain, is_a_field_of_this, symtab);
4238 do_cleanups (old_chain);
4242 /* True if TYPE is definitely an artificial type supplied to a symbol
4243 for which no debugging information was given in the symbol file. */
4246 is_nondebugging_type (struct type *type)
4248 char *name = ada_type_name (type);
4249 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4252 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4253 duplicate other symbols in the list (The only case I know of where
4254 this happens is when object files containing stabs-in-ecoff are
4255 linked with files containing ordinary ecoff debugging symbols (or no
4256 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4257 Returns the number of items in the modified list. */
4260 remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4267 if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
4268 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4269 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4271 for (j = 0; j < nsyms; j += 1)
4274 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4275 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4276 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
4277 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4278 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4279 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
4282 for (k = i + 1; k < nsyms; k += 1)
4283 syms[k - 1] = syms[k];
4296 /* Given a type that corresponds to a renaming entity, use the type name
4297 to extract the scope (package name or function name, fully qualified,
4298 and following the GNAT encoding convention) where this renaming has been
4299 defined. The string returned needs to be deallocated after use. */
4302 xget_renaming_scope (struct type *renaming_type)
4304 /* The renaming types adhere to the following convention:
4305 <scope>__<rename>___<XR extension>.
4306 So, to extract the scope, we search for the "___XR" extension,
4307 and then backtrack until we find the first "__". */
4309 const char *name = type_name_no_tag (renaming_type);
4310 char *suffix = strstr (name, "___XR");
4315 /* Now, backtrack a bit until we find the first "__". Start looking
4316 at suffix - 3, as the <rename> part is at least one character long. */
4318 for (last = suffix - 3; last > name; last--)
4319 if (last[0] == '_' && last[1] == '_')
4322 /* Make a copy of scope and return it. */
4324 scope_len = last - name;
4325 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
4327 strncpy (scope, name, scope_len);
4328 scope[scope_len] = '\0';
4333 /* Return nonzero if NAME corresponds to a package name. */
4336 is_package_name (const char *name)
4338 /* Here, We take advantage of the fact that no symbols are generated
4339 for packages, while symbols are generated for each function.
4340 So the condition for NAME represent a package becomes equivalent
4341 to NAME not existing in our list of symbols. There is only one
4342 small complication with library-level functions (see below). */
4346 /* If it is a function that has not been defined at library level,
4347 then we should be able to look it up in the symbols. */
4348 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4351 /* Library-level function names start with "_ada_". See if function
4352 "_ada_" followed by NAME can be found. */
4354 /* Do a quick check that NAME does not contain "__", since library-level
4355 functions names can not contain "__" in them. */
4356 if (strstr (name, "__") != NULL)
4359 fun_name = xstrprintf ("_ada_%s", name);
4361 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4364 /* Return nonzero if SYM corresponds to a renaming entity that is
4365 visible from FUNCTION_NAME. */
4368 renaming_is_visible (const struct symbol *sym, char *function_name)
4370 char *scope = xget_renaming_scope (SYMBOL_TYPE (sym));
4372 make_cleanup (xfree, scope);
4374 /* If the rename has been defined in a package, then it is visible. */
4375 if (is_package_name (scope))
4378 /* Check that the rename is in the current function scope by checking
4379 that its name starts with SCOPE. */
4381 /* If the function name starts with "_ada_", it means that it is
4382 a library-level function. Strip this prefix before doing the
4383 comparison, as the encoding for the renaming does not contain
4385 if (strncmp (function_name, "_ada_", 5) == 0)
4388 return (strncmp (function_name, scope, strlen (scope)) == 0);
4391 /* Iterates over the SYMS list and remove any entry that corresponds to
4392 a renaming entity that is not visible from the function associated
4396 GNAT emits a type following a specified encoding for each renaming
4397 entity. Unfortunately, STABS currently does not support the definition
4398 of types that are local to a given lexical block, so all renamings types
4399 are emitted at library level. As a consequence, if an application
4400 contains two renaming entities using the same name, and a user tries to
4401 print the value of one of these entities, the result of the ada symbol
4402 lookup will also contain the wrong renaming type.
4404 This function partially covers for this limitation by attempting to
4405 remove from the SYMS list renaming symbols that should be visible
4406 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4407 method with the current information available. The implementation
4408 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4410 - When the user tries to print a rename in a function while there
4411 is another rename entity defined in a package: Normally, the
4412 rename in the function has precedence over the rename in the
4413 package, so the latter should be removed from the list. This is
4414 currently not the case.
4416 - This function will incorrectly remove valid renames if
4417 the CURRENT_BLOCK corresponds to a function which symbol name
4418 has been changed by an "Export" pragma. As a consequence,
4419 the user will be unable to print such rename entities. */
4422 remove_out_of_scope_renamings (struct ada_symbol_info *syms,
4423 int nsyms, struct block *current_block)
4425 struct symbol *current_function;
4426 char *current_function_name;
4429 /* Extract the function name associated to CURRENT_BLOCK.
4430 Abort if unable to do so. */
4432 if (current_block == NULL)
4435 current_function = block_function (current_block);
4436 if (current_function == NULL)
4439 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4440 if (current_function_name == NULL)
4443 /* Check each of the symbols, and remove it from the list if it is
4444 a type corresponding to a renaming that is out of the scope of
4445 the current block. */
4450 if (ada_is_object_renaming (syms[i].sym)
4451 && !renaming_is_visible (syms[i].sym, current_function_name))
4454 for (j = i + 1; j < nsyms; j++)
4455 syms[j - 1] = syms[j];
4465 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4466 scope and in global scopes, returning the number of matches. Sets
4467 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4468 indicating the symbols found and the blocks and symbol tables (if
4469 any) in which they were found. This vector are transient---good only to
4470 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4471 symbol match within the nest of blocks whose innermost member is BLOCK0,
4472 is the one match returned (no other matches in that or
4473 enclosing blocks is returned). If there are any matches in or
4474 surrounding BLOCK0, then these alone are returned. Otherwise, the
4475 search extends to global and file-scope (static) symbol tables.
4476 Names prefixed with "standard__" are handled specially: "standard__"
4477 is first stripped off, and only static and global symbols are searched. */
4480 ada_lookup_symbol_list (const char *name0, const struct block *block0,
4481 domain_enum namespace,
4482 struct ada_symbol_info **results)
4486 struct partial_symtab *ps;
4487 struct blockvector *bv;
4488 struct objfile *objfile;
4489 struct block *block;
4491 struct minimal_symbol *msymbol;
4497 obstack_free (&symbol_list_obstack, NULL);
4498 obstack_init (&symbol_list_obstack);
4502 /* Search specified block and its superiors. */
4504 wild_match = (strstr (name0, "__") == NULL);
4506 block = (struct block *) block0; /* FIXME: No cast ought to be
4507 needed, but adding const will
4508 have a cascade effect. */
4509 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
4513 name = name0 + sizeof ("standard__") - 1;
4517 while (block != NULL)
4520 ada_add_block_symbols (&symbol_list_obstack, block, name,
4521 namespace, NULL, NULL, wild_match);
4523 /* If we found a non-function match, assume that's the one. */
4524 if (is_nonfunction (defns_collected (&symbol_list_obstack, 0),
4525 num_defns_collected (&symbol_list_obstack)))
4528 block = BLOCK_SUPERBLOCK (block);
4531 /* If no luck so far, try to find NAME as a local symbol in some lexically
4532 enclosing subprogram. */
4533 if (num_defns_collected (&symbol_list_obstack) == 0 && block_depth > 2)
4534 add_symbols_from_enclosing_procs (&symbol_list_obstack,
4535 name, namespace, wild_match);
4537 /* If we found ANY matches among non-global symbols, we're done. */
4539 if (num_defns_collected (&symbol_list_obstack) > 0)
4543 if (lookup_cached_symbol (name0, namespace, &sym, &block, &s))
4546 add_defn_to_vec (&symbol_list_obstack, sym, block, s);
4550 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4551 tables, and psymtab's. */
4553 ALL_SYMTABS (objfile, s)
4558 bv = BLOCKVECTOR (s);
4559 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4560 ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
4561 objfile, s, wild_match);
4564 if (namespace == VAR_DOMAIN)
4566 ALL_MSYMBOLS (objfile, msymbol)
4568 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match))
4570 switch (MSYMBOL_TYPE (msymbol))
4572 case mst_solib_trampoline:
4575 s = find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol));
4578 int ndefns0 = num_defns_collected (&symbol_list_obstack);
4580 bv = BLOCKVECTOR (s);
4581 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4582 ada_add_block_symbols (&symbol_list_obstack, block,
4583 SYMBOL_LINKAGE_NAME (msymbol),
4584 namespace, objfile, s, wild_match);
4586 if (num_defns_collected (&symbol_list_obstack) == ndefns0)
4588 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
4589 ada_add_block_symbols (&symbol_list_obstack, block,
4590 SYMBOL_LINKAGE_NAME (msymbol),
4591 namespace, objfile, s,
4600 ALL_PSYMTABS (objfile, ps)
4604 && ada_lookup_partial_symbol (ps, name, 1, namespace, wild_match))
4606 s = PSYMTAB_TO_SYMTAB (ps);
4609 bv = BLOCKVECTOR (s);
4610 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4611 ada_add_block_symbols (&symbol_list_obstack, block, name,
4612 namespace, objfile, s, wild_match);
4616 /* Now add symbols from all per-file blocks if we've gotten no hits
4617 (Not strictly correct, but perhaps better than an error).
4618 Do the symtabs first, then check the psymtabs. */
4620 if (num_defns_collected (&symbol_list_obstack) == 0)
4623 ALL_SYMTABS (objfile, s)
4628 bv = BLOCKVECTOR (s);
4629 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
4630 ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
4631 objfile, s, wild_match);
4634 ALL_PSYMTABS (objfile, ps)
4638 && ada_lookup_partial_symbol (ps, name, 0, namespace, wild_match))
4640 s = PSYMTAB_TO_SYMTAB (ps);
4641 bv = BLOCKVECTOR (s);
4644 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
4645 ada_add_block_symbols (&symbol_list_obstack, block, name,
4646 namespace, objfile, s, wild_match);
4652 ndefns = num_defns_collected (&symbol_list_obstack);
4653 *results = defns_collected (&symbol_list_obstack, 1);
4655 ndefns = remove_extra_symbols (*results, ndefns);
4658 cache_symbol (name0, namespace, NULL, NULL, NULL);
4660 if (ndefns == 1 && cacheIfUnique)
4661 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block,
4662 (*results)[0].symtab);
4664 ndefns = remove_out_of_scope_renamings (*results, ndefns,
4665 (struct block *) block0);
4670 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4671 scope and in global scopes, or NULL if none. NAME is folded and
4672 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4673 choosing the first symbol if there are multiple choices.
4674 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4675 table in which the symbol was found (in both cases, these
4676 assignments occur only if the pointers are non-null). */
4679 ada_lookup_symbol (const char *name, const struct block *block0,
4680 domain_enum namespace, int *is_a_field_of_this,
4681 struct symtab **symtab)
4683 struct ada_symbol_info *candidates;
4686 n_candidates = ada_lookup_symbol_list (ada_encode (ada_fold_name (name)),
4687 block0, namespace, &candidates);
4689 if (n_candidates == 0)
4692 if (is_a_field_of_this != NULL)
4693 *is_a_field_of_this = 0;
4697 *symtab = candidates[0].symtab;
4698 if (*symtab == NULL && candidates[0].block != NULL)
4700 struct objfile *objfile;
4703 struct blockvector *bv;
4705 /* Search the list of symtabs for one which contains the
4706 address of the start of this block. */
4707 ALL_SYMTABS (objfile, s)
4709 bv = BLOCKVECTOR (s);
4710 b = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4711 if (BLOCK_START (b) <= BLOCK_START (candidates[0].block)
4712 && BLOCK_END (b) > BLOCK_START (candidates[0].block))
4715 return fixup_symbol_section (candidates[0].sym, objfile);
4718 /* FIXME: brobecker/2004-11-12: I think that we should never
4719 reach this point. I don't see a reason why we would not
4720 find a symtab for a given block, so I suggest raising an
4721 internal_error exception here. Otherwise, we end up
4722 returning a symbol but no symtab, which certain parts of
4723 the code that rely (indirectly) on this function do not
4724 expect, eventually causing a SEGV. */
4725 return fixup_symbol_section (candidates[0].sym, NULL);
4728 return candidates[0].sym;
4731 static struct symbol *
4732 ada_lookup_symbol_nonlocal (const char *name,
4733 const char *linkage_name,
4734 const struct block *block,
4735 const domain_enum domain, struct symtab **symtab)
4737 if (linkage_name == NULL)
4738 linkage_name = name;
4739 return ada_lookup_symbol (linkage_name, block_static_block (block), domain,
4744 /* True iff STR is a possible encoded suffix of a normal Ada name
4745 that is to be ignored for matching purposes. Suffixes of parallel
4746 names (e.g., XVE) are not included here. Currently, the possible suffixes
4747 are given by either of the regular expression:
4749 (__[0-9]+)?[.$][0-9]+ [nested subprogram suffix, on platforms such
4751 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4752 _E[0-9]+[bs]$ [protected object entry suffixes]
4753 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4757 is_name_suffix (const char *str)
4760 const char *matching;
4761 const int len = strlen (str);
4763 /* (__[0-9]+)?\.[0-9]+ */
4765 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
4768 while (isdigit (matching[0]))
4770 if (matching[0] == '\0')
4774 if (matching[0] == '.' || matching[0] == '$')
4777 while (isdigit (matching[0]))
4779 if (matching[0] == '\0')
4784 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
4787 while (isdigit (matching[0]))
4789 if (matching[0] == '\0')
4794 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4795 with a N at the end. Unfortunately, the compiler uses the same
4796 convention for other internal types it creates. So treating
4797 all entity names that end with an "N" as a name suffix causes
4798 some regressions. For instance, consider the case of an enumerated
4799 type. To support the 'Image attribute, it creates an array whose
4801 Having a single character like this as a suffix carrying some
4802 information is a bit risky. Perhaps we should change the encoding
4803 to be something like "_N" instead. In the meantime, do not do
4804 the following check. */
4805 /* Protected Object Subprograms */
4806 if (len == 1 && str [0] == 'N')
4811 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
4814 while (isdigit (matching[0]))
4816 if ((matching[0] == 'b' || matching[0] == 's')
4817 && matching [1] == '\0')
4821 /* ??? We should not modify STR directly, as we are doing below. This
4822 is fine in this case, but may become problematic later if we find
4823 that this alternative did not work, and want to try matching
4824 another one from the begining of STR. Since we modified it, we
4825 won't be able to find the begining of the string anymore! */
4829 while (str[0] != '_' && str[0] != '\0')
4831 if (str[0] != 'n' && str[0] != 'b')
4836 if (str[0] == '\000')
4840 if (str[1] != '_' || str[2] == '\000')
4844 if (strcmp (str + 3, "JM") == 0)
4846 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4847 the LJM suffix in favor of the JM one. But we will
4848 still accept LJM as a valid suffix for a reasonable
4849 amount of time, just to allow ourselves to debug programs
4850 compiled using an older version of GNAT. */
4851 if (strcmp (str + 3, "LJM") == 0)
4855 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
4856 || str[4] == 'U' || str[4] == 'P')
4858 if (str[4] == 'R' && str[5] != 'T')
4862 if (!isdigit (str[2]))
4864 for (k = 3; str[k] != '\0'; k += 1)
4865 if (!isdigit (str[k]) && str[k] != '_')
4869 if (str[0] == '$' && isdigit (str[1]))
4871 for (k = 2; str[k] != '\0'; k += 1)
4872 if (!isdigit (str[k]) && str[k] != '_')
4879 /* Return nonzero if the given string starts with a dot ('.')
4880 followed by zero or more digits.
4882 Note: brobecker/2003-11-10: A forward declaration has not been
4883 added at the begining of this file yet, because this function
4884 is only used to work around a problem found during wild matching
4885 when trying to match minimal symbol names against symbol names
4886 obtained from dwarf-2 data. This function is therefore currently
4887 only used in wild_match() and is likely to be deleted when the
4888 problem in dwarf-2 is fixed. */
4891 is_dot_digits_suffix (const char *str)
4897 while (isdigit (str[0]))
4899 return (str[0] == '\0');
4902 /* Return non-zero if NAME0 is a valid match when doing wild matching.
4903 Certain symbols appear at first to match, except that they turn out
4904 not to follow the Ada encoding and hence should not be used as a wild
4905 match of a given pattern. */
4908 is_valid_name_for_wild_match (const char *name0)
4910 const char *decoded_name = ada_decode (name0);
4913 for (i=0; decoded_name[i] != '\0'; i++)
4914 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
4920 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4921 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4922 informational suffixes of NAME (i.e., for which is_name_suffix is
4926 wild_match (const char *patn0, int patn_len, const char *name0)
4932 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4933 stored in the symbol table for nested function names is sometimes
4934 different from the name of the associated entity stored in
4935 the dwarf-2 data: This is the case for nested subprograms, where
4936 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4937 while the symbol name from the dwarf-2 data does not.
4939 Although the DWARF-2 standard documents that entity names stored
4940 in the dwarf-2 data should be identical to the name as seen in
4941 the source code, GNAT takes a different approach as we already use
4942 a special encoding mechanism to convey the information so that
4943 a C debugger can still use the information generated to debug
4944 Ada programs. A corollary is that the symbol names in the dwarf-2
4945 data should match the names found in the symbol table. I therefore
4946 consider this issue as a compiler defect.
4948 Until the compiler is properly fixed, we work-around the problem
4949 by ignoring such suffixes during the match. We do so by making
4950 a copy of PATN0 and NAME0, and then by stripping such a suffix
4951 if present. We then perform the match on the resulting strings. */
4954 name_len = strlen (name0);
4956 name = (char *) alloca ((name_len + 1) * sizeof (char));
4957 strcpy (name, name0);
4958 dot = strrchr (name, '.');
4959 if (dot != NULL && is_dot_digits_suffix (dot))
4962 patn = (char *) alloca ((patn_len + 1) * sizeof (char));
4963 strncpy (patn, patn0, patn_len);
4964 patn[patn_len] = '\0';
4965 dot = strrchr (patn, '.');
4966 if (dot != NULL && is_dot_digits_suffix (dot))
4969 patn_len = dot - patn;
4973 /* Now perform the wild match. */
4975 name_len = strlen (name);
4976 if (name_len >= patn_len + 5 && strncmp (name, "_ada_", 5) == 0
4977 && strncmp (patn, name + 5, patn_len) == 0
4978 && is_name_suffix (name + patn_len + 5))
4981 while (name_len >= patn_len)
4983 if (strncmp (patn, name, patn_len) == 0
4984 && is_name_suffix (name + patn_len))
4985 return (is_valid_name_for_wild_match (name0));
4992 && name[0] != '.' && (name[0] != '_' || name[1] != '_'));
4997 if (!islower (name[2]))
5004 if (!islower (name[1]))
5015 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5016 vector *defn_symbols, updating the list of symbols in OBSTACKP
5017 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5018 OBJFILE is the section containing BLOCK.
5019 SYMTAB is recorded with each symbol added. */
5022 ada_add_block_symbols (struct obstack *obstackp,
5023 struct block *block, const char *name,
5024 domain_enum domain, struct objfile *objfile,
5025 struct symtab *symtab, int wild)
5027 struct dict_iterator iter;
5028 int name_len = strlen (name);
5029 /* A matching argument symbol, if any. */
5030 struct symbol *arg_sym;
5031 /* Set true when we find a matching non-argument symbol. */
5040 ALL_BLOCK_SYMBOLS (block, iter, sym)
5042 if (SYMBOL_DOMAIN (sym) == domain
5043 && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (sym)))
5045 switch (SYMBOL_CLASS (sym))
5051 case LOC_REGPARM_ADDR:
5052 case LOC_BASEREG_ARG:
5053 case LOC_COMPUTED_ARG:
5056 case LOC_UNRESOLVED:
5060 add_defn_to_vec (obstackp,
5061 fixup_symbol_section (sym, objfile),
5070 ALL_BLOCK_SYMBOLS (block, iter, sym)
5072 if (SYMBOL_DOMAIN (sym) == domain)
5074 int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym), name_len);
5076 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len))
5078 switch (SYMBOL_CLASS (sym))
5084 case LOC_REGPARM_ADDR:
5085 case LOC_BASEREG_ARG:
5086 case LOC_COMPUTED_ARG:
5089 case LOC_UNRESOLVED:
5093 add_defn_to_vec (obstackp,
5094 fixup_symbol_section (sym, objfile),
5103 if (!found_sym && arg_sym != NULL)
5105 add_defn_to_vec (obstackp,
5106 fixup_symbol_section (arg_sym, objfile),
5115 ALL_BLOCK_SYMBOLS (block, iter, sym)
5117 if (SYMBOL_DOMAIN (sym) == domain)
5121 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5124 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5126 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5131 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5133 switch (SYMBOL_CLASS (sym))
5139 case LOC_REGPARM_ADDR:
5140 case LOC_BASEREG_ARG:
5141 case LOC_COMPUTED_ARG:
5144 case LOC_UNRESOLVED:
5148 add_defn_to_vec (obstackp,
5149 fixup_symbol_section (sym, objfile),
5157 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5158 They aren't parameters, right? */
5159 if (!found_sym && arg_sym != NULL)
5161 add_defn_to_vec (obstackp,
5162 fixup_symbol_section (arg_sym, objfile),
5170 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5171 to be invisible to users. */
5174 ada_is_ignored_field (struct type *type, int field_num)
5176 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5180 const char *name = TYPE_FIELD_NAME (type, field_num);
5181 return (name == NULL
5182 || (name[0] == '_' && strncmp (name, "_parent", 7) != 0));
5186 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5187 pointer or reference type whose ultimate target has a tag field. */
5190 ada_is_tagged_type (struct type *type, int refok)
5192 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
5195 /* True iff TYPE represents the type of X'Tag */
5198 ada_is_tag_type (struct type *type)
5200 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
5204 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
5205 return (name != NULL
5206 && strcmp (name, "ada__tags__dispatch_table") == 0);
5210 /* The type of the tag on VAL. */
5213 ada_tag_type (struct value *val)
5215 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
5218 /* The value of the tag on VAL. */
5221 ada_value_tag (struct value *val)
5223 return ada_value_struct_elt (val, "_tag", "record");
5226 /* The value of the tag on the object of type TYPE whose contents are
5227 saved at VALADDR, if it is non-null, or is at memory address
5230 static struct value *
5231 value_tag_from_contents_and_address (struct type *type,
5232 const gdb_byte *valaddr,
5235 int tag_byte_offset, dummy1, dummy2;
5236 struct type *tag_type;
5237 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
5240 const gdb_byte *valaddr1 = ((valaddr == NULL)
5242 : valaddr + tag_byte_offset);
5243 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
5245 return value_from_contents_and_address (tag_type, valaddr1, address1);
5250 static struct type *
5251 type_from_tag (struct value *tag)
5253 const char *type_name = ada_tag_name (tag);
5254 if (type_name != NULL)
5255 return ada_find_any_type (ada_encode (type_name));
5266 static int ada_tag_name_1 (void *);
5267 static int ada_tag_name_2 (struct tag_args *);
5269 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5270 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5271 The value stored in ARGS->name is valid until the next call to
5275 ada_tag_name_1 (void *args0)
5277 struct tag_args *args = (struct tag_args *) args0;
5278 static char name[1024];
5282 val = ada_value_struct_elt (args->tag, "tsd", NULL);
5284 return ada_tag_name_2 (args);
5285 val = ada_value_struct_elt (val, "expanded_name", NULL);
5288 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5289 for (p = name; *p != '\0'; p += 1)
5296 /* Utility function for ada_tag_name_1 that tries the second
5297 representation for the dispatch table (in which there is no
5298 explicit 'tsd' field in the referent of the tag pointer, and instead
5299 the tsd pointer is stored just before the dispatch table. */
5302 ada_tag_name_2 (struct tag_args *args)
5304 struct type *info_type;
5305 static char name[1024];
5307 struct value *val, *valp;
5310 info_type = ada_find_any_type ("ada__tags__type_specific_data");
5311 if (info_type == NULL)
5313 info_type = lookup_pointer_type (lookup_pointer_type (info_type));
5314 valp = value_cast (info_type, args->tag);
5317 val = value_ind (value_add (valp, value_from_longest (builtin_type_int, -1)));
5320 val = ada_value_struct_elt (val, "expanded_name", NULL);
5323 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
5324 for (p = name; *p != '\0'; p += 1)
5331 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5335 ada_tag_name (struct value *tag)
5337 struct tag_args args;
5338 if (!ada_is_tag_type (value_type (tag)))
5342 catch_errors (ada_tag_name_1, &args, NULL, RETURN_MASK_ALL);
5346 /* The parent type of TYPE, or NULL if none. */
5349 ada_parent_type (struct type *type)
5353 type = ada_check_typedef (type);
5355 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5358 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5359 if (ada_is_parent_field (type, i))
5360 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
5365 /* True iff field number FIELD_NUM of structure type TYPE contains the
5366 parent-type (inherited) fields of a derived type. Assumes TYPE is
5367 a structure type with at least FIELD_NUM+1 fields. */
5370 ada_is_parent_field (struct type *type, int field_num)
5372 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
5373 return (name != NULL
5374 && (strncmp (name, "PARENT", 6) == 0
5375 || strncmp (name, "_parent", 7) == 0));
5378 /* True iff field number FIELD_NUM of structure type TYPE is a
5379 transparent wrapper field (which should be silently traversed when doing
5380 field selection and flattened when printing). Assumes TYPE is a
5381 structure type with at least FIELD_NUM+1 fields. Such fields are always
5385 ada_is_wrapper_field (struct type *type, int field_num)
5387 const char *name = TYPE_FIELD_NAME (type, field_num);
5388 return (name != NULL
5389 && (strncmp (name, "PARENT", 6) == 0
5390 || strcmp (name, "REP") == 0
5391 || strncmp (name, "_parent", 7) == 0
5392 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
5395 /* True iff field number FIELD_NUM of structure or union type TYPE
5396 is a variant wrapper. Assumes TYPE is a structure type with at least
5397 FIELD_NUM+1 fields. */
5400 ada_is_variant_part (struct type *type, int field_num)
5402 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5403 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
5404 || (is_dynamic_field (type, field_num)
5405 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
5406 == TYPE_CODE_UNION)));
5409 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5410 whose discriminants are contained in the record type OUTER_TYPE,
5411 returns the type of the controlling discriminant for the variant. */
5414 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
5416 char *name = ada_variant_discrim_name (var_type);
5418 ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
5420 return builtin_type_int;
5425 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5426 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5427 represents a 'when others' clause; otherwise 0. */
5430 ada_is_others_clause (struct type *type, int field_num)
5432 const char *name = TYPE_FIELD_NAME (type, field_num);
5433 return (name != NULL && name[0] == 'O');
5436 /* Assuming that TYPE0 is the type of the variant part of a record,
5437 returns the name of the discriminant controlling the variant.
5438 The value is valid until the next call to ada_variant_discrim_name. */
5441 ada_variant_discrim_name (struct type *type0)
5443 static char *result = NULL;
5444 static size_t result_len = 0;
5447 const char *discrim_end;
5448 const char *discrim_start;
5450 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
5451 type = TYPE_TARGET_TYPE (type0);
5455 name = ada_type_name (type);
5457 if (name == NULL || name[0] == '\000')
5460 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
5463 if (strncmp (discrim_end, "___XVN", 6) == 0)
5466 if (discrim_end == name)
5469 for (discrim_start = discrim_end; discrim_start != name + 3;
5472 if (discrim_start == name + 1)
5474 if ((discrim_start > name + 3
5475 && strncmp (discrim_start - 3, "___", 3) == 0)
5476 || discrim_start[-1] == '.')
5480 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
5481 strncpy (result, discrim_start, discrim_end - discrim_start);
5482 result[discrim_end - discrim_start] = '\0';
5486 /* Scan STR for a subtype-encoded number, beginning at position K.
5487 Put the position of the character just past the number scanned in
5488 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5489 Return 1 if there was a valid number at the given position, and 0
5490 otherwise. A "subtype-encoded" number consists of the absolute value
5491 in decimal, followed by the letter 'm' to indicate a negative number.
5492 Assumes 0m does not occur. */
5495 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
5499 if (!isdigit (str[k]))
5502 /* Do it the hard way so as not to make any assumption about
5503 the relationship of unsigned long (%lu scan format code) and
5506 while (isdigit (str[k]))
5508 RU = RU * 10 + (str[k] - '0');
5515 *R = (-(LONGEST) (RU - 1)) - 1;
5521 /* NOTE on the above: Technically, C does not say what the results of
5522 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5523 number representable as a LONGEST (although either would probably work
5524 in most implementations). When RU>0, the locution in the then branch
5525 above is always equivalent to the negative of RU. */
5532 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5533 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5534 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5537 ada_in_variant (LONGEST val, struct type *type, int field_num)
5539 const char *name = TYPE_FIELD_NAME (type, field_num);
5552 if (!ada_scan_number (name, p + 1, &W, &p))
5561 if (!ada_scan_number (name, p + 1, &L, &p)
5562 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
5564 if (val >= L && val <= U)
5576 /* FIXME: Lots of redundancy below. Try to consolidate. */
5578 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5579 ARG_TYPE, extract and return the value of one of its (non-static)
5580 fields. FIELDNO says which field. Differs from value_primitive_field
5581 only in that it can handle packed values of arbitrary type. */
5583 static struct value *
5584 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
5585 struct type *arg_type)
5589 arg_type = ada_check_typedef (arg_type);
5590 type = TYPE_FIELD_TYPE (arg_type, fieldno);
5592 /* Handle packed fields. */
5594 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
5596 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
5597 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
5599 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
5600 offset + bit_pos / 8,
5601 bit_pos % 8, bit_size, type);
5604 return value_primitive_field (arg1, offset, fieldno, arg_type);
5607 /* Find field with name NAME in object of type TYPE. If found,
5608 set the following for each argument that is non-null:
5609 - *FIELD_TYPE_P to the field's type;
5610 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
5611 an object of that type;
5612 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
5613 - *BIT_SIZE_P to its size in bits if the field is packed, and
5615 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
5616 fields up to but not including the desired field, or by the total
5617 number of fields if not found. A NULL value of NAME never
5618 matches; the function just counts visible fields in this case.
5620 Returns 1 if found, 0 otherwise. */
5623 find_struct_field (char *name, struct type *type, int offset,
5624 struct type **field_type_p,
5625 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
5630 type = ada_check_typedef (type);
5632 if (field_type_p != NULL)
5633 *field_type_p = NULL;
5634 if (byte_offset_p != NULL)
5636 if (bit_offset_p != NULL)
5638 if (bit_size_p != NULL)
5641 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5643 int bit_pos = TYPE_FIELD_BITPOS (type, i);
5644 int fld_offset = offset + bit_pos / 8;
5645 char *t_field_name = TYPE_FIELD_NAME (type, i);
5647 if (t_field_name == NULL)
5650 else if (name != NULL && field_name_match (t_field_name, name))
5652 int bit_size = TYPE_FIELD_BITSIZE (type, i);
5653 if (field_type_p != NULL)
5654 *field_type_p = TYPE_FIELD_TYPE (type, i);
5655 if (byte_offset_p != NULL)
5656 *byte_offset_p = fld_offset;
5657 if (bit_offset_p != NULL)
5658 *bit_offset_p = bit_pos % 8;
5659 if (bit_size_p != NULL)
5660 *bit_size_p = bit_size;
5663 else if (ada_is_wrapper_field (type, i))
5665 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
5666 field_type_p, byte_offset_p, bit_offset_p,
5667 bit_size_p, index_p))
5670 else if (ada_is_variant_part (type, i))
5672 /* PNH: Wait. Do we ever execute this section, or is ARG always of
5675 struct type *field_type
5676 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
5678 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
5680 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
5682 + TYPE_FIELD_BITPOS (field_type, j) / 8,
5683 field_type_p, byte_offset_p,
5684 bit_offset_p, bit_size_p, index_p))
5688 else if (index_p != NULL)
5694 /* Number of user-visible fields in record type TYPE. */
5697 num_visible_fields (struct type *type)
5701 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
5705 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5706 and search in it assuming it has (class) type TYPE.
5707 If found, return value, else return NULL.
5709 Searches recursively through wrapper fields (e.g., '_parent'). */
5711 static struct value *
5712 ada_search_struct_field (char *name, struct value *arg, int offset,
5716 type = ada_check_typedef (type);
5718 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5720 char *t_field_name = TYPE_FIELD_NAME (type, i);
5722 if (t_field_name == NULL)
5725 else if (field_name_match (t_field_name, name))
5726 return ada_value_primitive_field (arg, offset, i, type);
5728 else if (ada_is_wrapper_field (type, i))
5730 struct value *v = /* Do not let indent join lines here. */
5731 ada_search_struct_field (name, arg,
5732 offset + TYPE_FIELD_BITPOS (type, i) / 8,
5733 TYPE_FIELD_TYPE (type, i));
5738 else if (ada_is_variant_part (type, i))
5740 /* PNH: Do we ever get here? See find_struct_field. */
5742 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
5743 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
5745 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
5747 struct value *v = ada_search_struct_field /* Force line break. */
5749 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
5750 TYPE_FIELD_TYPE (field_type, j));
5759 static struct value *ada_index_struct_field_1 (int *, struct value *,
5760 int, struct type *);
5763 /* Return field #INDEX in ARG, where the index is that returned by
5764 * find_struct_field through its INDEX_P argument. Adjust the address
5765 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
5766 * If found, return value, else return NULL. */
5768 static struct value *
5769 ada_index_struct_field (int index, struct value *arg, int offset,
5772 return ada_index_struct_field_1 (&index, arg, offset, type);
5776 /* Auxiliary function for ada_index_struct_field. Like
5777 * ada_index_struct_field, but takes index from *INDEX_P and modifies
5780 static struct value *
5781 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
5785 type = ada_check_typedef (type);
5787 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5789 if (TYPE_FIELD_NAME (type, i) == NULL)
5791 else if (ada_is_wrapper_field (type, i))
5793 struct value *v = /* Do not let indent join lines here. */
5794 ada_index_struct_field_1 (index_p, arg,
5795 offset + TYPE_FIELD_BITPOS (type, i) / 8,
5796 TYPE_FIELD_TYPE (type, i));
5801 else if (ada_is_variant_part (type, i))
5803 /* PNH: Do we ever get here? See ada_search_struct_field,
5804 find_struct_field. */
5805 error (_("Cannot assign this kind of variant record"));
5807 else if (*index_p == 0)
5808 return ada_value_primitive_field (arg, offset, i, type);
5815 /* Given ARG, a value of type (pointer or reference to a)*
5816 structure/union, extract the component named NAME from the ultimate
5817 target structure/union and return it as a value with its
5818 appropriate type. If ARG is a pointer or reference and the field
5819 is not packed, returns a reference to the field, otherwise the
5820 value of the field (an lvalue if ARG is an lvalue).
5822 The routine searches for NAME among all members of the structure itself
5823 and (recursively) among all members of any wrapper members
5826 ERR is a name (for use in error messages) that identifies the class
5827 of entity that ARG is supposed to be. ERR may be null, indicating
5828 that on error, the function simply returns NULL, and does not
5829 throw an error. (FIXME: True only if ARG is a pointer or reference
5833 ada_value_struct_elt (struct value *arg, char *name, char *err)
5835 struct type *t, *t1;
5839 t1 = t = ada_check_typedef (value_type (arg));
5840 if (TYPE_CODE (t) == TYPE_CODE_REF)
5842 t1 = TYPE_TARGET_TYPE (t);
5848 error (_("Bad value type in a %s."), err);
5850 t1 = ada_check_typedef (t1);
5851 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
5853 arg = coerce_ref (arg);
5858 while (TYPE_CODE (t) == TYPE_CODE_PTR)
5860 t1 = TYPE_TARGET_TYPE (t);
5866 error (_("Bad value type in a %s."), err);
5868 t1 = ada_check_typedef (t1);
5869 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
5871 arg = value_ind (arg);
5878 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
5883 error (_("Attempt to extract a component of a value that is not a %s."),
5888 v = ada_search_struct_field (name, arg, 0, t);
5891 int bit_offset, bit_size, byte_offset;
5892 struct type *field_type;
5895 if (TYPE_CODE (t) == TYPE_CODE_PTR)
5896 address = value_as_address (arg);
5898 address = unpack_pointer (t, value_contents (arg));
5900 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL);
5901 if (find_struct_field (name, t1, 0,
5902 &field_type, &byte_offset, &bit_offset,
5907 if (TYPE_CODE (t) == TYPE_CODE_REF)
5908 arg = ada_coerce_ref (arg);
5910 arg = ada_value_ind (arg);
5911 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
5912 bit_offset, bit_size,
5916 v = value_from_pointer (lookup_reference_type (field_type),
5917 address + byte_offset);
5921 if (v == NULL && err != NULL)
5922 error (_("There is no member named %s."), name);
5927 /* Given a type TYPE, look up the type of the component of type named NAME.
5928 If DISPP is non-null, add its byte displacement from the beginning of a
5929 structure (pointed to by a value) of type TYPE to *DISPP (does not
5930 work for packed fields).
5932 Matches any field whose name has NAME as a prefix, possibly
5935 TYPE can be either a struct or union. If REFOK, TYPE may also
5936 be a (pointer or reference)+ to a struct or union, and the
5937 ultimate target type will be searched.
5939 Looks recursively into variant clauses and parent types.
5941 If NOERR is nonzero, return NULL if NAME is not suitably defined or
5942 TYPE is not a type of the right kind. */
5944 static struct type *
5945 ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
5946 int noerr, int *dispp)
5953 if (refok && type != NULL)
5956 type = ada_check_typedef (type);
5957 if (TYPE_CODE (type) != TYPE_CODE_PTR
5958 && TYPE_CODE (type) != TYPE_CODE_REF)
5960 type = TYPE_TARGET_TYPE (type);
5964 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
5965 && TYPE_CODE (type) != TYPE_CODE_UNION))
5971 target_terminal_ours ();
5972 gdb_flush (gdb_stdout);
5974 error (_("Type (null) is not a structure or union type"));
5977 /* XXX: type_sprint */
5978 fprintf_unfiltered (gdb_stderr, _("Type "));
5979 type_print (type, "", gdb_stderr, -1);
5980 error (_(" is not a structure or union type"));
5985 type = to_static_fixed_type (type);
5987 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5989 char *t_field_name = TYPE_FIELD_NAME (type, i);
5993 if (t_field_name == NULL)
5996 else if (field_name_match (t_field_name, name))
5999 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
6000 return ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6003 else if (ada_is_wrapper_field (type, i))
6006 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
6011 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6016 else if (ada_is_variant_part (type, i))
6019 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
6021 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
6024 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
6029 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
6040 target_terminal_ours ();
6041 gdb_flush (gdb_stdout);
6044 /* XXX: type_sprint */
6045 fprintf_unfiltered (gdb_stderr, _("Type "));
6046 type_print (type, "", gdb_stderr, -1);
6047 error (_(" has no component named <null>"));
6051 /* XXX: type_sprint */
6052 fprintf_unfiltered (gdb_stderr, _("Type "));
6053 type_print (type, "", gdb_stderr, -1);
6054 error (_(" has no component named %s"), name);
6061 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6062 within a value of type OUTER_TYPE that is stored in GDB at
6063 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6064 numbering from 0) is applicable. Returns -1 if none are. */
6067 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
6068 const gdb_byte *outer_valaddr)
6073 struct type *discrim_type;
6074 char *discrim_name = ada_variant_discrim_name (var_type);
6075 LONGEST discrim_val;
6079 ada_lookup_struct_elt_type (outer_type, discrim_name, 1, 1, &disp);
6080 if (discrim_type == NULL)
6082 discrim_val = unpack_long (discrim_type, outer_valaddr + disp);
6085 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
6087 if (ada_is_others_clause (var_type, i))
6089 else if (ada_in_variant (discrim_val, var_type, i))
6093 return others_clause;
6098 /* Dynamic-Sized Records */
6100 /* Strategy: The type ostensibly attached to a value with dynamic size
6101 (i.e., a size that is not statically recorded in the debugging
6102 data) does not accurately reflect the size or layout of the value.
6103 Our strategy is to convert these values to values with accurate,
6104 conventional types that are constructed on the fly. */
6106 /* There is a subtle and tricky problem here. In general, we cannot
6107 determine the size of dynamic records without its data. However,
6108 the 'struct value' data structure, which GDB uses to represent
6109 quantities in the inferior process (the target), requires the size
6110 of the type at the time of its allocation in order to reserve space
6111 for GDB's internal copy of the data. That's why the
6112 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6113 rather than struct value*s.
6115 However, GDB's internal history variables ($1, $2, etc.) are
6116 struct value*s containing internal copies of the data that are not, in
6117 general, the same as the data at their corresponding addresses in
6118 the target. Fortunately, the types we give to these values are all
6119 conventional, fixed-size types (as per the strategy described
6120 above), so that we don't usually have to perform the
6121 'to_fixed_xxx_type' conversions to look at their values.
6122 Unfortunately, there is one exception: if one of the internal
6123 history variables is an array whose elements are unconstrained
6124 records, then we will need to create distinct fixed types for each
6125 element selected. */
6127 /* The upshot of all of this is that many routines take a (type, host
6128 address, target address) triple as arguments to represent a value.
6129 The host address, if non-null, is supposed to contain an internal
6130 copy of the relevant data; otherwise, the program is to consult the
6131 target at the target address. */
6133 /* Assuming that VAL0 represents a pointer value, the result of
6134 dereferencing it. Differs from value_ind in its treatment of
6135 dynamic-sized types. */
6138 ada_value_ind (struct value *val0)
6140 struct value *val = unwrap_value (value_ind (val0));
6141 return ada_to_fixed_value (val);
6144 /* The value resulting from dereferencing any "reference to"
6145 qualifiers on VAL0. */
6147 static struct value *
6148 ada_coerce_ref (struct value *val0)
6150 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
6152 struct value *val = val0;
6153 val = coerce_ref (val);
6154 val = unwrap_value (val);
6155 return ada_to_fixed_value (val);
6161 /* Return OFF rounded upward if necessary to a multiple of
6162 ALIGNMENT (a power of 2). */
6165 align_value (unsigned int off, unsigned int alignment)
6167 return (off + alignment - 1) & ~(alignment - 1);
6170 /* Return the bit alignment required for field #F of template type TYPE. */
6173 field_alignment (struct type *type, int f)
6175 const char *name = TYPE_FIELD_NAME (type, f);
6176 int len = (name == NULL) ? 0 : strlen (name);
6179 if (!isdigit (name[len - 1]))
6182 if (isdigit (name[len - 2]))
6183 align_offset = len - 2;
6185 align_offset = len - 1;
6187 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
6188 return TARGET_CHAR_BIT;
6190 return atoi (name + align_offset) * TARGET_CHAR_BIT;
6193 /* Find a symbol named NAME. Ignores ambiguity. */
6196 ada_find_any_symbol (const char *name)
6200 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
6201 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
6204 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
6208 /* Find a type named NAME. Ignores ambiguity. */
6211 ada_find_any_type (const char *name)
6213 struct symbol *sym = ada_find_any_symbol (name);
6216 return SYMBOL_TYPE (sym);
6221 /* Given a symbol NAME and its associated BLOCK, search all symbols
6222 for its ___XR counterpart, which is the ``renaming'' symbol
6223 associated to NAME. Return this symbol if found, return
6227 ada_find_renaming_symbol (const char *name, struct block *block)
6229 const struct symbol *function_sym = block_function (block);
6232 if (function_sym != NULL)
6234 /* If the symbol is defined inside a function, NAME is not fully
6235 qualified. This means we need to prepend the function name
6236 as well as adding the ``___XR'' suffix to build the name of
6237 the associated renaming symbol. */
6238 char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
6239 /* Function names sometimes contain suffixes used
6240 for instance to qualify nested subprograms. When building
6241 the XR type name, we need to make sure that this suffix is
6242 not included. So do not include any suffix in the function
6243 name length below. */
6244 const int function_name_len = ada_name_prefix_len (function_name);
6245 const int rename_len = function_name_len + 2 /* "__" */
6246 + strlen (name) + 6 /* "___XR\0" */ ;
6248 /* Strip the suffix if necessary. */
6249 function_name[function_name_len] = '\0';
6251 /* Library-level functions are a special case, as GNAT adds
6252 a ``_ada_'' prefix to the function name to avoid namespace
6253 pollution. However, the renaming symbol themselves do not
6254 have this prefix, so we need to skip this prefix if present. */
6255 if (function_name_len > 5 /* "_ada_" */
6256 && strstr (function_name, "_ada_") == function_name)
6257 function_name = function_name + 5;
6259 rename = (char *) alloca (rename_len * sizeof (char));
6260 sprintf (rename, "%s__%s___XR", function_name, name);
6264 const int rename_len = strlen (name) + 6;
6265 rename = (char *) alloca (rename_len * sizeof (char));
6266 sprintf (rename, "%s___XR", name);
6269 return ada_find_any_symbol (rename);
6272 /* Because of GNAT encoding conventions, several GDB symbols may match a
6273 given type name. If the type denoted by TYPE0 is to be preferred to
6274 that of TYPE1 for purposes of type printing, return non-zero;
6275 otherwise return 0. */
6278 ada_prefer_type (struct type *type0, struct type *type1)
6282 else if (type0 == NULL)
6284 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
6286 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
6288 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
6290 else if (ada_is_packed_array_type (type0))
6292 else if (ada_is_array_descriptor_type (type0)
6293 && !ada_is_array_descriptor_type (type1))
6295 else if (ada_renaming_type (type0) != NULL
6296 && ada_renaming_type (type1) == NULL)
6301 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6302 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6305 ada_type_name (struct type *type)
6309 else if (TYPE_NAME (type) != NULL)
6310 return TYPE_NAME (type);
6312 return TYPE_TAG_NAME (type);
6315 /* Find a parallel type to TYPE whose name is formed by appending
6316 SUFFIX to the name of TYPE. */
6319 ada_find_parallel_type (struct type *type, const char *suffix)
6322 static size_t name_len = 0;
6324 char *typename = ada_type_name (type);
6326 if (typename == NULL)
6329 len = strlen (typename);
6331 GROW_VECT (name, name_len, len + strlen (suffix) + 1);
6333 strcpy (name, typename);
6334 strcpy (name + len, suffix);
6336 return ada_find_any_type (name);
6340 /* If TYPE is a variable-size record type, return the corresponding template
6341 type describing its fields. Otherwise, return NULL. */
6343 static struct type *
6344 dynamic_template_type (struct type *type)
6346 type = ada_check_typedef (type);
6348 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
6349 || ada_type_name (type) == NULL)
6353 int len = strlen (ada_type_name (type));
6354 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
6357 return ada_find_parallel_type (type, "___XVE");
6361 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6362 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6365 is_dynamic_field (struct type *templ_type, int field_num)
6367 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
6369 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
6370 && strstr (name, "___XVL") != NULL;
6373 /* The index of the variant field of TYPE, or -1 if TYPE does not
6374 represent a variant record type. */
6377 variant_field_index (struct type *type)
6381 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6384 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
6386 if (ada_is_variant_part (type, f))
6392 /* A record type with no fields. */
6394 static struct type *
6395 empty_record (struct objfile *objfile)
6397 struct type *type = alloc_type (objfile);
6398 TYPE_CODE (type) = TYPE_CODE_STRUCT;
6399 TYPE_NFIELDS (type) = 0;
6400 TYPE_FIELDS (type) = NULL;
6401 TYPE_NAME (type) = "<empty>";
6402 TYPE_TAG_NAME (type) = NULL;
6403 TYPE_FLAGS (type) = 0;
6404 TYPE_LENGTH (type) = 0;
6408 /* An ordinary record type (with fixed-length fields) that describes
6409 the value of type TYPE at VALADDR or ADDRESS (see comments at
6410 the beginning of this section) VAL according to GNAT conventions.
6411 DVAL0 should describe the (portion of a) record that contains any
6412 necessary discriminants. It should be NULL if value_type (VAL) is
6413 an outer-level type (i.e., as opposed to a branch of a variant.) A
6414 variant field (unless unchecked) is replaced by a particular branch
6417 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6418 length are not statically known are discarded. As a consequence,
6419 VALADDR, ADDRESS and DVAL0 are ignored.
6421 NOTE: Limitations: For now, we assume that dynamic fields and
6422 variants occupy whole numbers of bytes. However, they need not be
6426 ada_template_to_fixed_record_type_1 (struct type *type,
6427 const gdb_byte *valaddr,
6428 CORE_ADDR address, struct value *dval0,
6429 int keep_dynamic_fields)
6431 struct value *mark = value_mark ();
6434 int nfields, bit_len;
6437 int fld_bit_len, bit_incr;
6440 /* Compute the number of fields in this record type that are going
6441 to be processed: unless keep_dynamic_fields, this includes only
6442 fields whose position and length are static will be processed. */
6443 if (keep_dynamic_fields)
6444 nfields = TYPE_NFIELDS (type);
6448 while (nfields < TYPE_NFIELDS (type)
6449 && !ada_is_variant_part (type, nfields)
6450 && !is_dynamic_field (type, nfields))
6454 rtype = alloc_type (TYPE_OBJFILE (type));
6455 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6456 INIT_CPLUS_SPECIFIC (rtype);
6457 TYPE_NFIELDS (rtype) = nfields;
6458 TYPE_FIELDS (rtype) = (struct field *)
6459 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6460 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
6461 TYPE_NAME (rtype) = ada_type_name (type);
6462 TYPE_TAG_NAME (rtype) = NULL;
6463 TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE;
6469 for (f = 0; f < nfields; f += 1)
6471 off = align_value (off, field_alignment (type, f))
6472 + TYPE_FIELD_BITPOS (type, f);
6473 TYPE_FIELD_BITPOS (rtype, f) = off;
6474 TYPE_FIELD_BITSIZE (rtype, f) = 0;
6476 if (ada_is_variant_part (type, f))
6479 fld_bit_len = bit_incr = 0;
6481 else if (is_dynamic_field (type, f))
6484 dval = value_from_contents_and_address (rtype, valaddr, address);
6488 TYPE_FIELD_TYPE (rtype, f) =
6491 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
6492 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6493 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
6494 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6495 bit_incr = fld_bit_len =
6496 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6500 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
6501 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6502 if (TYPE_FIELD_BITSIZE (type, f) > 0)
6503 bit_incr = fld_bit_len =
6504 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
6506 bit_incr = fld_bit_len =
6507 TYPE_LENGTH (TYPE_FIELD_TYPE (type, f)) * TARGET_CHAR_BIT;
6509 if (off + fld_bit_len > bit_len)
6510 bit_len = off + fld_bit_len;
6512 TYPE_LENGTH (rtype) =
6513 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
6516 /* We handle the variant part, if any, at the end because of certain
6517 odd cases in which it is re-ordered so as NOT the last field of
6518 the record. This can happen in the presence of representation
6520 if (variant_field >= 0)
6522 struct type *branch_type;
6524 off = TYPE_FIELD_BITPOS (rtype, variant_field);
6527 dval = value_from_contents_and_address (rtype, valaddr, address);
6532 to_fixed_variant_branch_type
6533 (TYPE_FIELD_TYPE (type, variant_field),
6534 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6535 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
6536 if (branch_type == NULL)
6538 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
6539 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
6540 TYPE_NFIELDS (rtype) -= 1;
6544 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
6545 TYPE_FIELD_NAME (rtype, variant_field) = "S";
6547 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
6549 if (off + fld_bit_len > bit_len)
6550 bit_len = off + fld_bit_len;
6551 TYPE_LENGTH (rtype) =
6552 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
6556 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6557 should contain the alignment of that record, which should be a strictly
6558 positive value. If null or negative, then something is wrong, most
6559 probably in the debug info. In that case, we don't round up the size
6560 of the resulting type. If this record is not part of another structure,
6561 the current RTYPE length might be good enough for our purposes. */
6562 if (TYPE_LENGTH (type) <= 0)
6564 if (TYPE_NAME (rtype))
6565 warning (_("Invalid type size for `%s' detected: %d."),
6566 TYPE_NAME (rtype), TYPE_LENGTH (type));
6568 warning (_("Invalid type size for <unnamed> detected: %d."),
6569 TYPE_LENGTH (type));
6573 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
6574 TYPE_LENGTH (type));
6577 value_free_to_mark (mark);
6578 if (TYPE_LENGTH (rtype) > varsize_limit)
6579 error (_("record type with dynamic size is larger than varsize-limit"));
6583 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6586 static struct type *
6587 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
6588 CORE_ADDR address, struct value *dval0)
6590 return ada_template_to_fixed_record_type_1 (type, valaddr,
6594 /* An ordinary record type in which ___XVL-convention fields and
6595 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6596 static approximations, containing all possible fields. Uses
6597 no runtime values. Useless for use in values, but that's OK,
6598 since the results are used only for type determinations. Works on both
6599 structs and unions. Representation note: to save space, we memorize
6600 the result of this function in the TYPE_TARGET_TYPE of the
6603 static struct type *
6604 template_to_static_fixed_type (struct type *type0)
6610 if (TYPE_TARGET_TYPE (type0) != NULL)
6611 return TYPE_TARGET_TYPE (type0);
6613 nfields = TYPE_NFIELDS (type0);
6616 for (f = 0; f < nfields; f += 1)
6618 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type0, f));
6619 struct type *new_type;
6621 if (is_dynamic_field (type0, f))
6622 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
6624 new_type = to_static_fixed_type (field_type);
6625 if (type == type0 && new_type != field_type)
6627 TYPE_TARGET_TYPE (type0) = type = alloc_type (TYPE_OBJFILE (type0));
6628 TYPE_CODE (type) = TYPE_CODE (type0);
6629 INIT_CPLUS_SPECIFIC (type);
6630 TYPE_NFIELDS (type) = nfields;
6631 TYPE_FIELDS (type) = (struct field *)
6632 TYPE_ALLOC (type, nfields * sizeof (struct field));
6633 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
6634 sizeof (struct field) * nfields);
6635 TYPE_NAME (type) = ada_type_name (type0);
6636 TYPE_TAG_NAME (type) = NULL;
6637 TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE;
6638 TYPE_LENGTH (type) = 0;
6640 TYPE_FIELD_TYPE (type, f) = new_type;
6641 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
6646 /* Given an object of type TYPE whose contents are at VALADDR and
6647 whose address in memory is ADDRESS, returns a revision of TYPE --
6648 a non-dynamic-sized record with a variant part -- in which
6649 the variant part is replaced with the appropriate branch. Looks
6650 for discriminant values in DVAL0, which can be NULL if the record
6651 contains the necessary discriminant values. */
6653 static struct type *
6654 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
6655 CORE_ADDR address, struct value *dval0)
6657 struct value *mark = value_mark ();
6660 struct type *branch_type;
6661 int nfields = TYPE_NFIELDS (type);
6662 int variant_field = variant_field_index (type);
6664 if (variant_field == -1)
6668 dval = value_from_contents_and_address (type, valaddr, address);
6672 rtype = alloc_type (TYPE_OBJFILE (type));
6673 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6674 INIT_CPLUS_SPECIFIC (rtype);
6675 TYPE_NFIELDS (rtype) = nfields;
6676 TYPE_FIELDS (rtype) =
6677 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6678 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
6679 sizeof (struct field) * nfields);
6680 TYPE_NAME (rtype) = ada_type_name (type);
6681 TYPE_TAG_NAME (rtype) = NULL;
6682 TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE;
6683 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
6685 branch_type = to_fixed_variant_branch_type
6686 (TYPE_FIELD_TYPE (type, variant_field),
6687 cond_offset_host (valaddr,
6688 TYPE_FIELD_BITPOS (type, variant_field)
6690 cond_offset_target (address,
6691 TYPE_FIELD_BITPOS (type, variant_field)
6692 / TARGET_CHAR_BIT), dval);
6693 if (branch_type == NULL)
6696 for (f = variant_field + 1; f < nfields; f += 1)
6697 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
6698 TYPE_NFIELDS (rtype) -= 1;
6702 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
6703 TYPE_FIELD_NAME (rtype, variant_field) = "S";
6704 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
6705 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
6707 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
6709 value_free_to_mark (mark);
6713 /* An ordinary record type (with fixed-length fields) that describes
6714 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6715 beginning of this section]. Any necessary discriminants' values
6716 should be in DVAL, a record value; it may be NULL if the object
6717 at ADDR itself contains any necessary discriminant values.
6718 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
6719 values from the record are needed. Except in the case that DVAL,
6720 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
6721 unchecked) is replaced by a particular branch of the variant.
6723 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
6724 is questionable and may be removed. It can arise during the
6725 processing of an unconstrained-array-of-record type where all the
6726 variant branches have exactly the same size. This is because in
6727 such cases, the compiler does not bother to use the XVS convention
6728 when encoding the record. I am currently dubious of this
6729 shortcut and suspect the compiler should be altered. FIXME. */
6731 static struct type *
6732 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
6733 CORE_ADDR address, struct value *dval)
6735 struct type *templ_type;
6737 if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6740 templ_type = dynamic_template_type (type0);
6742 if (templ_type != NULL)
6743 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
6744 else if (variant_field_index (type0) >= 0)
6746 if (dval == NULL && valaddr == NULL && address == 0)
6748 return to_record_with_fixed_variant_part (type0, valaddr, address,
6753 TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE;
6759 /* An ordinary record type (with fixed-length fields) that describes
6760 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6761 union type. Any necessary discriminants' values should be in DVAL,
6762 a record value. That is, this routine selects the appropriate
6763 branch of the union at ADDR according to the discriminant value
6764 indicated in the union's type name. */
6766 static struct type *
6767 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
6768 CORE_ADDR address, struct value *dval)
6771 struct type *templ_type;
6772 struct type *var_type;
6774 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
6775 var_type = TYPE_TARGET_TYPE (var_type0);
6777 var_type = var_type0;
6779 templ_type = ada_find_parallel_type (var_type, "___XVU");
6781 if (templ_type != NULL)
6782 var_type = templ_type;
6785 ada_which_variant_applies (var_type,
6786 value_type (dval), value_contents (dval));
6789 return empty_record (TYPE_OBJFILE (var_type));
6790 else if (is_dynamic_field (var_type, which))
6791 return to_fixed_record_type
6792 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
6793 valaddr, address, dval);
6794 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
6796 to_fixed_record_type
6797 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
6799 return TYPE_FIELD_TYPE (var_type, which);
6802 /* Assuming that TYPE0 is an array type describing the type of a value
6803 at ADDR, and that DVAL describes a record containing any
6804 discriminants used in TYPE0, returns a type for the value that
6805 contains no dynamic components (that is, no components whose sizes
6806 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6807 true, gives an error message if the resulting type's size is over
6810 static struct type *
6811 to_fixed_array_type (struct type *type0, struct value *dval,
6814 struct type *index_type_desc;
6815 struct type *result;
6817 if (ada_is_packed_array_type (type0) /* revisit? */
6818 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6821 index_type_desc = ada_find_parallel_type (type0, "___XA");
6822 if (index_type_desc == NULL)
6824 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
6825 /* NOTE: elt_type---the fixed version of elt_type0---should never
6826 depend on the contents of the array in properly constructed
6828 /* Create a fixed version of the array element type.
6829 We're not providing the address of an element here,
6830 and thus the actual object value can not be inspected to do
6831 the conversion. This should not be a problem, since arrays of
6832 unconstrained objects are not allowed. In particular, all
6833 the elements of an array of a tagged type should all be of
6834 the same type specified in the debugging info. No need to
6835 consult the object tag. */
6836 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval);
6838 if (elt_type0 == elt_type)
6841 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
6842 elt_type, TYPE_INDEX_TYPE (type0));
6847 struct type *elt_type0;
6850 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
6851 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
6853 /* NOTE: result---the fixed version of elt_type0---should never
6854 depend on the contents of the array in properly constructed
6856 /* Create a fixed version of the array element type.
6857 We're not providing the address of an element here,
6858 and thus the actual object value can not be inspected to do
6859 the conversion. This should not be a problem, since arrays of
6860 unconstrained objects are not allowed. In particular, all
6861 the elements of an array of a tagged type should all be of
6862 the same type specified in the debugging info. No need to
6863 consult the object tag. */
6864 result = ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval);
6865 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
6867 struct type *range_type =
6868 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i),
6869 dval, TYPE_OBJFILE (type0));
6870 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
6871 result, range_type);
6873 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
6874 error (_("array type with dynamic size is larger than varsize-limit"));
6877 TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE;
6882 /* A standard type (containing no dynamically sized components)
6883 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6884 DVAL describes a record containing any discriminants used in TYPE0,
6885 and may be NULL if there are none, or if the object of type TYPE at
6886 ADDRESS or in VALADDR contains these discriminants.
6888 In the case of tagged types, this function attempts to locate the object's
6889 tag and use it to compute the actual type. However, when ADDRESS is null,
6890 we cannot use it to determine the location of the tag, and therefore
6891 compute the tagged type's actual type. So we return the tagged type
6892 without consulting the tag. */
6895 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
6896 CORE_ADDR address, struct value *dval)
6898 type = ada_check_typedef (type);
6899 switch (TYPE_CODE (type))
6903 case TYPE_CODE_STRUCT:
6905 struct type *static_type = to_static_fixed_type (type);
6907 /* If STATIC_TYPE is a tagged type and we know the object's address,
6908 then we can determine its tag, and compute the object's actual
6911 if (address != 0 && ada_is_tagged_type (static_type, 0))
6913 struct type *real_type =
6914 type_from_tag (value_tag_from_contents_and_address (static_type,
6917 if (real_type != NULL)
6920 return to_fixed_record_type (type, valaddr, address, NULL);
6922 case TYPE_CODE_ARRAY:
6923 return to_fixed_array_type (type, dval, 1);
6924 case TYPE_CODE_UNION:
6928 return to_fixed_variant_branch_type (type, valaddr, address, dval);
6932 /* A standard (static-sized) type corresponding as well as possible to
6933 TYPE0, but based on no runtime data. */
6935 static struct type *
6936 to_static_fixed_type (struct type *type0)
6943 if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6946 type0 = ada_check_typedef (type0);
6948 switch (TYPE_CODE (type0))
6952 case TYPE_CODE_STRUCT:
6953 type = dynamic_template_type (type0);
6955 return template_to_static_fixed_type (type);
6957 return template_to_static_fixed_type (type0);
6958 case TYPE_CODE_UNION:
6959 type = ada_find_parallel_type (type0, "___XVU");
6961 return template_to_static_fixed_type (type);
6963 return template_to_static_fixed_type (type0);
6967 /* A static approximation of TYPE with all type wrappers removed. */
6969 static struct type *
6970 static_unwrap_type (struct type *type)
6972 if (ada_is_aligner_type (type))
6974 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
6975 if (ada_type_name (type1) == NULL)
6976 TYPE_NAME (type1) = ada_type_name (type);
6978 return static_unwrap_type (type1);
6982 struct type *raw_real_type = ada_get_base_type (type);
6983 if (raw_real_type == type)
6986 return to_static_fixed_type (raw_real_type);
6990 /* In some cases, incomplete and private types require
6991 cross-references that are not resolved as records (for example,
6993 type FooP is access Foo;
6995 type Foo is array ...;
6996 ). In these cases, since there is no mechanism for producing
6997 cross-references to such types, we instead substitute for FooP a
6998 stub enumeration type that is nowhere resolved, and whose tag is
6999 the name of the actual type. Call these types "non-record stubs". */
7001 /* A type equivalent to TYPE that is not a non-record stub, if one
7002 exists, otherwise TYPE. */
7005 ada_check_typedef (struct type *type)
7007 CHECK_TYPEDEF (type);
7008 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
7009 || !TYPE_STUB (type)
7010 || TYPE_TAG_NAME (type) == NULL)
7014 char *name = TYPE_TAG_NAME (type);
7015 struct type *type1 = ada_find_any_type (name);
7016 return (type1 == NULL) ? type : type1;
7020 /* A value representing the data at VALADDR/ADDRESS as described by
7021 type TYPE0, but with a standard (static-sized) type that correctly
7022 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7023 type, then return VAL0 [this feature is simply to avoid redundant
7024 creation of struct values]. */
7026 static struct value *
7027 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
7030 struct type *type = ada_to_fixed_type (type0, 0, address, NULL);
7031 if (type == type0 && val0 != NULL)
7034 return value_from_contents_and_address (type, 0, address);
7037 /* A value representing VAL, but with a standard (static-sized) type
7038 that correctly describes it. Does not necessarily create a new
7041 static struct value *
7042 ada_to_fixed_value (struct value *val)
7044 return ada_to_fixed_value_create (value_type (val),
7045 VALUE_ADDRESS (val) + value_offset (val),
7049 /* A value representing VAL, but with a standard (static-sized) type
7050 chosen to approximate the real type of VAL as well as possible, but
7051 without consulting any runtime values. For Ada dynamic-sized
7052 types, therefore, the type of the result is likely to be inaccurate. */
7055 ada_to_static_fixed_value (struct value *val)
7058 to_static_fixed_type (static_unwrap_type (value_type (val)));
7059 if (type == value_type (val))
7062 return coerce_unspec_val_to_type (val, type);
7068 /* Table mapping attribute numbers to names.
7069 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7071 static const char *attribute_names[] = {
7089 ada_attribute_name (enum exp_opcode n)
7091 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
7092 return attribute_names[n - OP_ATR_FIRST + 1];
7094 return attribute_names[0];
7097 /* Evaluate the 'POS attribute applied to ARG. */
7100 pos_atr (struct value *arg)
7102 struct type *type = value_type (arg);
7104 if (!discrete_type_p (type))
7105 error (_("'POS only defined on discrete types"));
7107 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7110 LONGEST v = value_as_long (arg);
7112 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7114 if (v == TYPE_FIELD_BITPOS (type, i))
7117 error (_("enumeration value is invalid: can't find 'POS"));
7120 return value_as_long (arg);
7123 static struct value *
7124 value_pos_atr (struct value *arg)
7126 return value_from_longest (builtin_type_int, pos_atr (arg));
7129 /* Evaluate the TYPE'VAL attribute applied to ARG. */
7131 static struct value *
7132 value_val_atr (struct type *type, struct value *arg)
7134 if (!discrete_type_p (type))
7135 error (_("'VAL only defined on discrete types"));
7136 if (!integer_type_p (value_type (arg)))
7137 error (_("'VAL requires integral argument"));
7139 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
7141 long pos = value_as_long (arg);
7142 if (pos < 0 || pos >= TYPE_NFIELDS (type))
7143 error (_("argument to 'VAL out of range"));
7144 return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
7147 return value_from_longest (type, value_as_long (arg));
7153 /* True if TYPE appears to be an Ada character type.
7154 [At the moment, this is true only for Character and Wide_Character;
7155 It is a heuristic test that could stand improvement]. */
7158 ada_is_character_type (struct type *type)
7160 const char *name = ada_type_name (type);
7163 && (TYPE_CODE (type) == TYPE_CODE_CHAR
7164 || TYPE_CODE (type) == TYPE_CODE_INT
7165 || TYPE_CODE (type) == TYPE_CODE_RANGE)
7166 && (strcmp (name, "character") == 0
7167 || strcmp (name, "wide_character") == 0
7168 || strcmp (name, "unsigned char") == 0);
7171 /* True if TYPE appears to be an Ada string type. */
7174 ada_is_string_type (struct type *type)
7176 type = ada_check_typedef (type);
7178 && TYPE_CODE (type) != TYPE_CODE_PTR
7179 && (ada_is_simple_array_type (type)
7180 || ada_is_array_descriptor_type (type))
7181 && ada_array_arity (type) == 1)
7183 struct type *elttype = ada_array_element_type (type, 1);
7185 return ada_is_character_type (elttype);
7192 /* True if TYPE is a struct type introduced by the compiler to force the
7193 alignment of a value. Such types have a single field with a
7194 distinctive name. */
7197 ada_is_aligner_type (struct type *type)
7199 type = ada_check_typedef (type);
7201 /* If we can find a parallel XVS type, then the XVS type should
7202 be used instead of this type. And hence, this is not an aligner
7204 if (ada_find_parallel_type (type, "___XVS") != NULL)
7207 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
7208 && TYPE_NFIELDS (type) == 1
7209 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
7212 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7213 the parallel type. */
7216 ada_get_base_type (struct type *raw_type)
7218 struct type *real_type_namer;
7219 struct type *raw_real_type;
7221 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
7224 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
7225 if (real_type_namer == NULL
7226 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
7227 || TYPE_NFIELDS (real_type_namer) != 1)
7230 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
7231 if (raw_real_type == NULL)
7234 return raw_real_type;
7237 /* The type of value designated by TYPE, with all aligners removed. */
7240 ada_aligned_type (struct type *type)
7242 if (ada_is_aligner_type (type))
7243 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
7245 return ada_get_base_type (type);
7249 /* The address of the aligned value in an object at address VALADDR
7250 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7253 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
7255 if (ada_is_aligner_type (type))
7256 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
7258 TYPE_FIELD_BITPOS (type,
7259 0) / TARGET_CHAR_BIT);
7266 /* The printed representation of an enumeration literal with encoded
7267 name NAME. The value is good to the next call of ada_enum_name. */
7269 ada_enum_name (const char *name)
7271 static char *result;
7272 static size_t result_len = 0;
7275 /* First, unqualify the enumeration name:
7276 1. Search for the last '.' character. If we find one, then skip
7277 all the preceeding characters, the unqualified name starts
7278 right after that dot.
7279 2. Otherwise, we may be debugging on a target where the compiler
7280 translates dots into "__". Search forward for double underscores,
7281 but stop searching when we hit an overloading suffix, which is
7282 of the form "__" followed by digits. */
7284 tmp = strrchr (name, '.');
7289 while ((tmp = strstr (name, "__")) != NULL)
7291 if (isdigit (tmp[2]))
7301 if (name[1] == 'U' || name[1] == 'W')
7303 if (sscanf (name + 2, "%x", &v) != 1)
7309 GROW_VECT (result, result_len, 16);
7310 if (isascii (v) && isprint (v))
7311 sprintf (result, "'%c'", v);
7312 else if (name[1] == 'U')
7313 sprintf (result, "[\"%02x\"]", v);
7315 sprintf (result, "[\"%04x\"]", v);
7321 tmp = strstr (name, "__");
7323 tmp = strstr (name, "$");
7326 GROW_VECT (result, result_len, tmp - name + 1);
7327 strncpy (result, name, tmp - name);
7328 result[tmp - name] = '\0';
7336 static struct value *
7337 evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos,
7340 return (*exp->language_defn->la_exp_desc->evaluate_exp)
7341 (expect_type, exp, pos, noside);
7344 /* Evaluate the subexpression of EXP starting at *POS as for
7345 evaluate_type, updating *POS to point just past the evaluated
7348 static struct value *
7349 evaluate_subexp_type (struct expression *exp, int *pos)
7351 return (*exp->language_defn->la_exp_desc->evaluate_exp)
7352 (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
7355 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7358 static struct value *
7359 unwrap_value (struct value *val)
7361 struct type *type = ada_check_typedef (value_type (val));
7362 if (ada_is_aligner_type (type))
7364 struct value *v = value_struct_elt (&val, NULL, "F",
7365 NULL, "internal structure");
7366 struct type *val_type = ada_check_typedef (value_type (v));
7367 if (ada_type_name (val_type) == NULL)
7368 TYPE_NAME (val_type) = ada_type_name (type);
7370 return unwrap_value (v);
7374 struct type *raw_real_type =
7375 ada_check_typedef (ada_get_base_type (type));
7377 if (type == raw_real_type)
7381 coerce_unspec_val_to_type
7382 (val, ada_to_fixed_type (raw_real_type, 0,
7383 VALUE_ADDRESS (val) + value_offset (val),
7388 static struct value *
7389 cast_to_fixed (struct type *type, struct value *arg)
7393 if (type == value_type (arg))
7395 else if (ada_is_fixed_point_type (value_type (arg)))
7396 val = ada_float_to_fixed (type,
7397 ada_fixed_to_float (value_type (arg),
7398 value_as_long (arg)));
7402 value_as_double (value_cast (builtin_type_double, value_copy (arg)));
7403 val = ada_float_to_fixed (type, argd);
7406 return value_from_longest (type, val);
7409 static struct value *
7410 cast_from_fixed_to_double (struct value *arg)
7412 DOUBLEST val = ada_fixed_to_float (value_type (arg),
7413 value_as_long (arg));
7414 return value_from_double (builtin_type_double, val);
7417 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7418 return the converted value. */
7420 static struct value *
7421 coerce_for_assign (struct type *type, struct value *val)
7423 struct type *type2 = value_type (val);
7427 type2 = ada_check_typedef (type2);
7428 type = ada_check_typedef (type);
7430 if (TYPE_CODE (type2) == TYPE_CODE_PTR
7431 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7433 val = ada_value_ind (val);
7434 type2 = value_type (val);
7437 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
7438 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7440 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
7441 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
7442 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
7443 error (_("Incompatible types in assignment"));
7444 deprecated_set_value_type (val, type);
7449 static struct value *
7450 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
7453 struct type *type1, *type2;
7456 arg1 = coerce_ref (arg1);
7457 arg2 = coerce_ref (arg2);
7458 type1 = base_type (ada_check_typedef (value_type (arg1)));
7459 type2 = base_type (ada_check_typedef (value_type (arg2)));
7461 if (TYPE_CODE (type1) != TYPE_CODE_INT
7462 || TYPE_CODE (type2) != TYPE_CODE_INT)
7463 return value_binop (arg1, arg2, op);
7472 return value_binop (arg1, arg2, op);
7475 v2 = value_as_long (arg2);
7477 error (_("second operand of %s must not be zero."), op_string (op));
7479 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
7480 return value_binop (arg1, arg2, op);
7482 v1 = value_as_long (arg1);
7487 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
7488 v += v > 0 ? -1 : 1;
7496 /* Should not reach this point. */
7500 val = allocate_value (type1);
7501 store_unsigned_integer (value_contents_raw (val),
7502 TYPE_LENGTH (value_type (val)), v);
7507 ada_value_equal (struct value *arg1, struct value *arg2)
7509 if (ada_is_direct_array_type (value_type (arg1))
7510 || ada_is_direct_array_type (value_type (arg2)))
7512 arg1 = ada_coerce_to_simple_array (arg1);
7513 arg2 = ada_coerce_to_simple_array (arg2);
7514 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
7515 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
7516 error (_("Attempt to compare array with non-array"));
7517 /* FIXME: The following works only for types whose
7518 representations use all bits (no padding or undefined bits)
7519 and do not have user-defined equality. */
7521 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
7522 && memcmp (value_contents (arg1), value_contents (arg2),
7523 TYPE_LENGTH (value_type (arg1))) == 0;
7525 return value_equal (arg1, arg2);
7528 /* Total number of component associations in the aggregate starting at
7529 index PC in EXP. Assumes that index PC is the start of an
7533 num_component_specs (struct expression *exp, int pc)
7536 m = exp->elts[pc + 1].longconst;
7539 for (i = 0; i < m; i += 1)
7541 switch (exp->elts[pc].opcode)
7547 n += exp->elts[pc + 1].longconst;
7550 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
7555 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
7556 component of LHS (a simple array or a record), updating *POS past
7557 the expression, assuming that LHS is contained in CONTAINER. Does
7558 not modify the inferior's memory, nor does it modify LHS (unless
7559 LHS == CONTAINER). */
7562 assign_component (struct value *container, struct value *lhs, LONGEST index,
7563 struct expression *exp, int *pos)
7565 struct value *mark = value_mark ();
7567 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
7569 struct value *index_val = value_from_longest (builtin_type_int, index);
7570 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
7574 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
7575 elt = ada_to_fixed_value (unwrap_value (elt));
7578 if (exp->elts[*pos].opcode == OP_AGGREGATE)
7579 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
7581 value_assign_to_component (container, elt,
7582 ada_evaluate_subexp (NULL, exp, pos,
7585 value_free_to_mark (mark);
7588 /* Assuming that LHS represents an lvalue having a record or array
7589 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
7590 of that aggregate's value to LHS, advancing *POS past the
7591 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
7592 lvalue containing LHS (possibly LHS itself). Does not modify
7593 the inferior's memory, nor does it modify the contents of
7594 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
7596 static struct value *
7597 assign_aggregate (struct value *container,
7598 struct value *lhs, struct expression *exp,
7599 int *pos, enum noside noside)
7601 struct type *lhs_type;
7602 int n = exp->elts[*pos+1].longconst;
7603 LONGEST low_index, high_index;
7606 int max_indices, num_indices;
7607 int is_array_aggregate;
7609 struct value *mark = value_mark ();
7612 if (noside != EVAL_NORMAL)
7615 for (i = 0; i < n; i += 1)
7616 ada_evaluate_subexp (NULL, exp, pos, noside);
7620 container = ada_coerce_ref (container);
7621 if (ada_is_direct_array_type (value_type (container)))
7622 container = ada_coerce_to_simple_array (container);
7623 lhs = ada_coerce_ref (lhs);
7624 if (!deprecated_value_modifiable (lhs))
7625 error (_("Left operand of assignment is not a modifiable lvalue."));
7627 lhs_type = value_type (lhs);
7628 if (ada_is_direct_array_type (lhs_type))
7630 lhs = ada_coerce_to_simple_array (lhs);
7631 lhs_type = value_type (lhs);
7632 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
7633 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
7634 is_array_aggregate = 1;
7636 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
7639 high_index = num_visible_fields (lhs_type) - 1;
7640 is_array_aggregate = 0;
7643 error (_("Left-hand side must be array or record."));
7645 num_specs = num_component_specs (exp, *pos - 3);
7646 max_indices = 4 * num_specs + 4;
7647 indices = alloca (max_indices * sizeof (indices[0]));
7648 indices[0] = indices[1] = low_index - 1;
7649 indices[2] = indices[3] = high_index + 1;
7652 for (i = 0; i < n; i += 1)
7654 switch (exp->elts[*pos].opcode)
7657 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
7658 &num_indices, max_indices,
7659 low_index, high_index);
7662 aggregate_assign_positional (container, lhs, exp, pos, indices,
7663 &num_indices, max_indices,
7664 low_index, high_index);
7668 error (_("Misplaced 'others' clause"));
7669 aggregate_assign_others (container, lhs, exp, pos, indices,
7670 num_indices, low_index, high_index);
7673 error (_("Internal error: bad aggregate clause"));
7680 /* Assign into the component of LHS indexed by the OP_POSITIONAL
7681 construct at *POS, updating *POS past the construct, given that
7682 the positions are relative to lower bound LOW, where HIGH is the
7683 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
7684 updating *NUM_INDICES as needed. CONTAINER is as for
7685 assign_aggregate. */
7687 aggregate_assign_positional (struct value *container,
7688 struct value *lhs, struct expression *exp,
7689 int *pos, LONGEST *indices, int *num_indices,
7690 int max_indices, LONGEST low, LONGEST high)
7692 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
7694 if (ind - 1 == high)
7695 warning ("Extra components in aggregate ignored.");
7698 add_component_interval (ind, ind, indices, num_indices, max_indices);
7700 assign_component (container, lhs, ind, exp, pos);
7703 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
7706 /* Assign into the components of LHS indexed by the OP_CHOICES
7707 construct at *POS, updating *POS past the construct, given that
7708 the allowable indices are LOW..HIGH. Record the indices assigned
7709 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
7710 needed. CONTAINER is as for assign_aggregate. */
7712 aggregate_assign_from_choices (struct value *container,
7713 struct value *lhs, struct expression *exp,
7714 int *pos, LONGEST *indices, int *num_indices,
7715 int max_indices, LONGEST low, LONGEST high)
7718 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
7719 int choice_pos, expr_pc;
7720 int is_array = ada_is_direct_array_type (value_type (lhs));
7722 choice_pos = *pos += 3;
7724 for (j = 0; j < n_choices; j += 1)
7725 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
7727 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
7729 for (j = 0; j < n_choices; j += 1)
7731 LONGEST lower, upper;
7732 enum exp_opcode op = exp->elts[choice_pos].opcode;
7733 if (op == OP_DISCRETE_RANGE)
7736 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
7738 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
7743 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
7754 name = &exp->elts[choice_pos + 2].string;
7757 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
7760 error (_("Invalid record component association."));
7762 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
7764 if (! find_struct_field (name, value_type (lhs), 0,
7765 NULL, NULL, NULL, NULL, &ind))
7766 error (_("Unknown component name: %s."), name);
7767 lower = upper = ind;
7770 if (lower <= upper && (lower < low || upper > high))
7771 error (_("Index in component association out of bounds."));
7773 add_component_interval (lower, upper, indices, num_indices,
7775 while (lower <= upper)
7779 assign_component (container, lhs, lower, exp, &pos1);
7785 /* Assign the value of the expression in the OP_OTHERS construct in
7786 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
7787 have not been previously assigned. The index intervals already assigned
7788 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
7789 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
7791 aggregate_assign_others (struct value *container,
7792 struct value *lhs, struct expression *exp,
7793 int *pos, LONGEST *indices, int num_indices,
7794 LONGEST low, LONGEST high)
7797 int expr_pc = *pos+1;
7799 for (i = 0; i < num_indices - 2; i += 2)
7802 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
7806 assign_component (container, lhs, ind, exp, &pos);
7809 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
7812 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
7813 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
7814 modifying *SIZE as needed. It is an error if *SIZE exceeds
7815 MAX_SIZE. The resulting intervals do not overlap. */
7817 add_component_interval (LONGEST low, LONGEST high,
7818 LONGEST* indices, int *size, int max_size)
7821 for (i = 0; i < *size; i += 2) {
7822 if (high >= indices[i] && low <= indices[i + 1])
7825 for (kh = i + 2; kh < *size; kh += 2)
7826 if (high < indices[kh])
7828 if (low < indices[i])
7830 indices[i + 1] = indices[kh - 1];
7831 if (high > indices[i + 1])
7832 indices[i + 1] = high;
7833 memcpy (indices + i + 2, indices + kh, *size - kh);
7834 *size -= kh - i - 2;
7837 else if (high < indices[i])
7841 if (*size == max_size)
7842 error (_("Internal error: miscounted aggregate components."));
7844 for (j = *size-1; j >= i+2; j -= 1)
7845 indices[j] = indices[j - 2];
7847 indices[i + 1] = high;
7850 static struct value *
7851 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
7852 int *pos, enum noside noside)
7855 int tem, tem2, tem3;
7857 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
7860 struct value **argvec;
7864 op = exp->elts[pc].opcode;
7871 unwrap_value (evaluate_subexp_standard
7872 (expect_type, exp, pos, noside));
7876 struct value *result;
7878 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
7879 /* The result type will have code OP_STRING, bashed there from
7880 OP_ARRAY. Bash it back. */
7881 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
7882 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
7888 type = exp->elts[pc + 1].type;
7889 arg1 = evaluate_subexp (type, exp, pos, noside);
7890 if (noside == EVAL_SKIP)
7892 if (type != ada_check_typedef (value_type (arg1)))
7894 if (ada_is_fixed_point_type (type))
7895 arg1 = cast_to_fixed (type, arg1);
7896 else if (ada_is_fixed_point_type (value_type (arg1)))
7897 arg1 = value_cast (type, cast_from_fixed_to_double (arg1));
7898 else if (VALUE_LVAL (arg1) == lval_memory)
7900 /* This is in case of the really obscure (and undocumented,
7901 but apparently expected) case of (Foo) Bar.all, where Bar
7902 is an integer constant and Foo is a dynamic-sized type.
7903 If we don't do this, ARG1 will simply be relabeled with
7905 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7906 return value_zero (to_static_fixed_type (type), not_lval);
7908 ada_to_fixed_value_create
7909 (type, VALUE_ADDRESS (arg1) + value_offset (arg1), 0);
7912 arg1 = value_cast (type, arg1);
7918 type = exp->elts[pc + 1].type;
7919 return ada_evaluate_subexp (type, exp, pos, noside);
7922 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7923 if (exp->elts[*pos].opcode == OP_AGGREGATE)
7925 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
7926 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
7928 return ada_value_assign (arg1, arg1);
7930 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
7931 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
7933 if (ada_is_fixed_point_type (value_type (arg1)))
7934 arg2 = cast_to_fixed (value_type (arg1), arg2);
7935 else if (ada_is_fixed_point_type (value_type (arg2)))
7937 (_("Fixed-point values must be assigned to fixed-point variables"));
7939 arg2 = coerce_for_assign (value_type (arg1), arg2);
7940 return ada_value_assign (arg1, arg2);
7943 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
7944 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
7945 if (noside == EVAL_SKIP)
7947 if ((ada_is_fixed_point_type (value_type (arg1))
7948 || ada_is_fixed_point_type (value_type (arg2)))
7949 && value_type (arg1) != value_type (arg2))
7950 error (_("Operands of fixed-point addition must have the same type"));
7951 return value_cast (value_type (arg1), value_add (arg1, arg2));
7954 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
7955 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
7956 if (noside == EVAL_SKIP)
7958 if ((ada_is_fixed_point_type (value_type (arg1))
7959 || ada_is_fixed_point_type (value_type (arg2)))
7960 && value_type (arg1) != value_type (arg2))
7961 error (_("Operands of fixed-point subtraction must have the same type"));
7962 return value_cast (value_type (arg1), value_sub (arg1, arg2));
7966 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7967 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7968 if (noside == EVAL_SKIP)
7970 else if (noside == EVAL_AVOID_SIDE_EFFECTS
7971 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
7972 return value_zero (value_type (arg1), not_lval);
7975 if (ada_is_fixed_point_type (value_type (arg1)))
7976 arg1 = cast_from_fixed_to_double (arg1);
7977 if (ada_is_fixed_point_type (value_type (arg2)))
7978 arg2 = cast_from_fixed_to_double (arg2);
7979 return ada_value_binop (arg1, arg2, op);
7984 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7985 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7986 if (noside == EVAL_SKIP)
7988 else if (noside == EVAL_AVOID_SIDE_EFFECTS
7989 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
7990 return value_zero (value_type (arg1), not_lval);
7992 return ada_value_binop (arg1, arg2, op);
7995 case BINOP_NOTEQUAL:
7996 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7997 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
7998 if (noside == EVAL_SKIP)
8000 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8003 tem = ada_value_equal (arg1, arg2);
8004 if (op == BINOP_NOTEQUAL)
8006 return value_from_longest (LA_BOOL_TYPE, (LONGEST) tem);
8009 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8010 if (noside == EVAL_SKIP)
8012 else if (ada_is_fixed_point_type (value_type (arg1)))
8013 return value_cast (value_type (arg1), value_neg (arg1));
8015 return value_neg (arg1);
8019 if (noside == EVAL_SKIP)
8024 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
8025 /* Only encountered when an unresolved symbol occurs in a
8026 context other than a function call, in which case, it is
8028 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8029 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
8030 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8034 (to_static_fixed_type
8035 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
8041 unwrap_value (evaluate_subexp_standard
8042 (expect_type, exp, pos, noside));
8043 return ada_to_fixed_value (arg1);
8049 /* Allocate arg vector, including space for the function to be
8050 called in argvec[0] and a terminating NULL. */
8051 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8053 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
8055 if (exp->elts[*pos].opcode == OP_VAR_VALUE
8056 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
8057 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8058 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
8061 for (tem = 0; tem <= nargs; tem += 1)
8062 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8065 if (noside == EVAL_SKIP)
8069 if (ada_is_packed_array_type (desc_base_type (value_type (argvec[0]))))
8070 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
8071 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
8072 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
8073 && VALUE_LVAL (argvec[0]) == lval_memory))
8074 argvec[0] = value_addr (argvec[0]);
8076 type = ada_check_typedef (value_type (argvec[0]));
8077 if (TYPE_CODE (type) == TYPE_CODE_PTR)
8079 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
8081 case TYPE_CODE_FUNC:
8082 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8084 case TYPE_CODE_ARRAY:
8086 case TYPE_CODE_STRUCT:
8087 if (noside != EVAL_AVOID_SIDE_EFFECTS)
8088 argvec[0] = ada_value_ind (argvec[0]);
8089 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
8092 error (_("cannot subscript or call something of type `%s'"),
8093 ada_type_name (value_type (argvec[0])));
8098 switch (TYPE_CODE (type))
8100 case TYPE_CODE_FUNC:
8101 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8102 return allocate_value (TYPE_TARGET_TYPE (type));
8103 return call_function_by_hand (argvec[0], nargs, argvec + 1);
8104 case TYPE_CODE_STRUCT:
8108 arity = ada_array_arity (type);
8109 type = ada_array_element_type (type, nargs);
8111 error (_("cannot subscript or call a record"));
8113 error (_("wrong number of subscripts; expecting %d"), arity);
8114 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8115 return allocate_value (ada_aligned_type (type));
8117 unwrap_value (ada_value_subscript
8118 (argvec[0], nargs, argvec + 1));
8120 case TYPE_CODE_ARRAY:
8121 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8123 type = ada_array_element_type (type, nargs);
8125 error (_("element type of array unknown"));
8127 return allocate_value (ada_aligned_type (type));
8130 unwrap_value (ada_value_subscript
8131 (ada_coerce_to_simple_array (argvec[0]),
8132 nargs, argvec + 1));
8133 case TYPE_CODE_PTR: /* Pointer to array */
8134 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
8135 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8137 type = ada_array_element_type (type, nargs);
8139 error (_("element type of array unknown"));
8141 return allocate_value (ada_aligned_type (type));
8144 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
8145 nargs, argvec + 1));
8148 error (_("Attempt to index or call something other than an \
8149 array or function"));
8154 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8155 struct value *low_bound_val =
8156 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8157 struct value *high_bound_val =
8158 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8161 low_bound_val = coerce_ref (low_bound_val);
8162 high_bound_val = coerce_ref (high_bound_val);
8163 low_bound = pos_atr (low_bound_val);
8164 high_bound = pos_atr (high_bound_val);
8166 if (noside == EVAL_SKIP)
8169 /* If this is a reference to an aligner type, then remove all
8171 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8172 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
8173 TYPE_TARGET_TYPE (value_type (array)) =
8174 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
8176 if (ada_is_packed_array_type (value_type (array)))
8177 error (_("cannot slice a packed array"));
8179 /* If this is a reference to an array or an array lvalue,
8180 convert to a pointer. */
8181 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
8182 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
8183 && VALUE_LVAL (array) == lval_memory))
8184 array = value_addr (array);
8186 if (noside == EVAL_AVOID_SIDE_EFFECTS
8187 && ada_is_array_descriptor_type (ada_check_typedef
8188 (value_type (array))))
8189 return empty_array (ada_type_of_array (array, 0), low_bound);
8191 array = ada_coerce_to_simple_array_ptr (array);
8193 /* If we have more than one level of pointer indirection,
8194 dereference the value until we get only one level. */
8195 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
8196 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
8198 array = value_ind (array);
8200 /* Make sure we really do have an array type before going further,
8201 to avoid a SEGV when trying to get the index type or the target
8202 type later down the road if the debug info generated by
8203 the compiler is incorrect or incomplete. */
8204 if (!ada_is_simple_array_type (value_type (array)))
8205 error (_("cannot take slice of non-array"));
8207 if (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR)
8209 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
8210 return empty_array (TYPE_TARGET_TYPE (value_type (array)),
8214 struct type *arr_type0 =
8215 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array)),
8217 return ada_value_slice_ptr (array, arr_type0,
8218 longest_to_int (low_bound),
8219 longest_to_int (high_bound));
8222 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8224 else if (high_bound < low_bound)
8225 return empty_array (value_type (array), low_bound);
8227 return ada_value_slice (array, longest_to_int (low_bound),
8228 longest_to_int (high_bound));
8233 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8234 type = exp->elts[pc + 1].type;
8236 if (noside == EVAL_SKIP)
8239 switch (TYPE_CODE (type))
8242 lim_warning (_("Membership test incompletely implemented; \
8243 always returns true"));
8244 return value_from_longest (builtin_type_int, (LONGEST) 1);
8246 case TYPE_CODE_RANGE:
8247 arg2 = value_from_longest (builtin_type_int, TYPE_LOW_BOUND (type));
8248 arg3 = value_from_longest (builtin_type_int,
8249 TYPE_HIGH_BOUND (type));
8251 value_from_longest (builtin_type_int,
8252 (value_less (arg1, arg3)
8253 || value_equal (arg1, arg3))
8254 && (value_less (arg2, arg1)
8255 || value_equal (arg2, arg1)));
8258 case BINOP_IN_BOUNDS:
8260 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8261 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8263 if (noside == EVAL_SKIP)
8266 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8267 return value_zero (builtin_type_int, not_lval);
8269 tem = longest_to_int (exp->elts[pc + 1].longconst);
8271 if (tem < 1 || tem > ada_array_arity (value_type (arg2)))
8272 error (_("invalid dimension number to 'range"));
8274 arg3 = ada_array_bound (arg2, tem, 1);
8275 arg2 = ada_array_bound (arg2, tem, 0);
8278 value_from_longest (builtin_type_int,
8279 (value_less (arg1, arg3)
8280 || value_equal (arg1, arg3))
8281 && (value_less (arg2, arg1)
8282 || value_equal (arg2, arg1)));
8284 case TERNOP_IN_RANGE:
8285 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8286 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8287 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8289 if (noside == EVAL_SKIP)
8293 value_from_longest (builtin_type_int,
8294 (value_less (arg1, arg3)
8295 || value_equal (arg1, arg3))
8296 && (value_less (arg2, arg1)
8297 || value_equal (arg2, arg1)));
8303 struct type *type_arg;
8304 if (exp->elts[*pos].opcode == OP_TYPE)
8306 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
8308 type_arg = exp->elts[pc + 2].type;
8312 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8316 if (exp->elts[*pos].opcode != OP_LONG)
8317 error (_("Invalid operand to '%s"), ada_attribute_name (op));
8318 tem = longest_to_int (exp->elts[*pos + 2].longconst);
8321 if (noside == EVAL_SKIP)
8324 if (type_arg == NULL)
8326 arg1 = ada_coerce_ref (arg1);
8328 if (ada_is_packed_array_type (value_type (arg1)))
8329 arg1 = ada_coerce_to_simple_array (arg1);
8331 if (tem < 1 || tem > ada_array_arity (value_type (arg1)))
8332 error (_("invalid dimension number to '%s"),
8333 ada_attribute_name (op));
8335 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8337 type = ada_index_type (value_type (arg1), tem);
8340 (_("attempt to take bound of something that is not an array"));
8341 return allocate_value (type);
8346 default: /* Should never happen. */
8347 error (_("unexpected attribute encountered"));
8349 return ada_array_bound (arg1, tem, 0);
8351 return ada_array_bound (arg1, tem, 1);
8353 return ada_array_length (arg1, tem);
8356 else if (discrete_type_p (type_arg))
8358 struct type *range_type;
8359 char *name = ada_type_name (type_arg);
8361 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
8363 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
8364 if (range_type == NULL)
8365 range_type = type_arg;
8369 error (_("unexpected attribute encountered"));
8371 return discrete_type_low_bound (range_type);
8373 return discrete_type_high_bound (range_type);
8375 error (_("the 'length attribute applies only to array types"));
8378 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
8379 error (_("unimplemented type attribute"));
8384 if (ada_is_packed_array_type (type_arg))
8385 type_arg = decode_packed_array_type (type_arg);
8387 if (tem < 1 || tem > ada_array_arity (type_arg))
8388 error (_("invalid dimension number to '%s"),
8389 ada_attribute_name (op));
8391 type = ada_index_type (type_arg, tem);
8394 (_("attempt to take bound of something that is not an array"));
8395 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8396 return allocate_value (type);
8401 error (_("unexpected attribute encountered"));
8403 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
8404 return value_from_longest (type, low);
8406 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
8407 return value_from_longest (type, high);
8409 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
8410 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
8411 return value_from_longest (type, high - low + 1);
8417 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8418 if (noside == EVAL_SKIP)
8421 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8422 return value_zero (ada_tag_type (arg1), not_lval);
8424 return ada_value_tag (arg1);
8428 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
8429 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8430 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8431 if (noside == EVAL_SKIP)
8433 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8434 return value_zero (value_type (arg1), not_lval);
8436 return value_binop (arg1, arg2,
8437 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
8439 case OP_ATR_MODULUS:
8441 struct type *type_arg = exp->elts[pc + 2].type;
8442 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
8444 if (noside == EVAL_SKIP)
8447 if (!ada_is_modular_type (type_arg))
8448 error (_("'modulus must be applied to modular type"));
8450 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
8451 ada_modulus (type_arg));
8456 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
8457 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8458 if (noside == EVAL_SKIP)
8460 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8461 return value_zero (builtin_type_int, not_lval);
8463 return value_pos_atr (arg1);
8466 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8467 if (noside == EVAL_SKIP)
8469 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8470 return value_zero (builtin_type_int, not_lval);
8472 return value_from_longest (builtin_type_int,
8474 * TYPE_LENGTH (value_type (arg1)));
8477 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
8478 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8479 type = exp->elts[pc + 2].type;
8480 if (noside == EVAL_SKIP)
8482 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8483 return value_zero (type, not_lval);
8485 return value_val_atr (type, arg1);
8488 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8489 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8490 if (noside == EVAL_SKIP)
8492 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8493 return value_zero (value_type (arg1), not_lval);
8495 return value_binop (arg1, arg2, op);
8498 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8499 if (noside == EVAL_SKIP)
8505 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8506 if (noside == EVAL_SKIP)
8508 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
8509 return value_neg (arg1);
8514 if (expect_type && TYPE_CODE (expect_type) == TYPE_CODE_PTR)
8515 expect_type = TYPE_TARGET_TYPE (ada_check_typedef (expect_type));
8516 arg1 = evaluate_subexp (expect_type, exp, pos, noside);
8517 if (noside == EVAL_SKIP)
8519 type = ada_check_typedef (value_type (arg1));
8520 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8522 if (ada_is_array_descriptor_type (type))
8523 /* GDB allows dereferencing GNAT array descriptors. */
8525 struct type *arrType = ada_type_of_array (arg1, 0);
8526 if (arrType == NULL)
8527 error (_("Attempt to dereference null array pointer."));
8528 return value_at_lazy (arrType, 0);
8530 else if (TYPE_CODE (type) == TYPE_CODE_PTR
8531 || TYPE_CODE (type) == TYPE_CODE_REF
8532 /* In C you can dereference an array to get the 1st elt. */
8533 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
8535 type = to_static_fixed_type
8537 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
8539 return value_zero (type, lval_memory);
8541 else if (TYPE_CODE (type) == TYPE_CODE_INT)
8542 /* GDB allows dereferencing an int. */
8543 return value_zero (builtin_type_int, lval_memory);
8545 error (_("Attempt to take contents of a non-pointer value."));
8547 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
8548 type = ada_check_typedef (value_type (arg1));
8550 if (ada_is_array_descriptor_type (type))
8551 /* GDB allows dereferencing GNAT array descriptors. */
8552 return ada_coerce_to_simple_array (arg1);
8554 return ada_value_ind (arg1);
8556 case STRUCTOP_STRUCT:
8557 tem = longest_to_int (exp->elts[pc + 1].longconst);
8558 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
8559 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8560 if (noside == EVAL_SKIP)
8562 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8564 struct type *type1 = value_type (arg1);
8565 if (ada_is_tagged_type (type1, 1))
8567 type = ada_lookup_struct_elt_type (type1,
8568 &exp->elts[pc + 2].string,
8571 /* In this case, we assume that the field COULD exist
8572 in some extension of the type. Return an object of
8573 "type" void, which will match any formal
8574 (see ada_type_match). */
8575 return value_zero (builtin_type_void, lval_memory);
8579 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
8582 return value_zero (ada_aligned_type (type), lval_memory);
8586 ada_to_fixed_value (unwrap_value
8587 (ada_value_struct_elt
8588 (arg1, &exp->elts[pc + 2].string, "record")));
8590 /* The value is not supposed to be used. This is here to make it
8591 easier to accommodate expressions that contain types. */
8593 if (noside == EVAL_SKIP)
8595 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
8596 return allocate_value (builtin_type_void);
8598 error (_("Attempt to use a type name as an expression"));
8603 case OP_DISCRETE_RANGE:
8606 if (noside == EVAL_NORMAL)
8610 error (_("Undefined name, ambiguous name, or renaming used in "
8611 "component association: %s."), &exp->elts[pc+2].string);
8613 error (_("Aggregates only allowed on the right of an assignment"));
8615 internal_error (__FILE__, __LINE__, "aggregate apparently mangled");
8618 ada_forward_operator_length (exp, pc, &oplen, &nargs);
8620 for (tem = 0; tem < nargs; tem += 1)
8621 ada_evaluate_subexp (NULL, exp, pos, noside);
8626 return value_from_longest (builtin_type_long, (LONGEST) 1);
8632 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
8633 type name that encodes the 'small and 'delta information.
8634 Otherwise, return NULL. */
8637 fixed_type_info (struct type *type)
8639 const char *name = ada_type_name (type);
8640 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
8642 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
8644 const char *tail = strstr (name, "___XF_");
8650 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
8651 return fixed_type_info (TYPE_TARGET_TYPE (type));
8656 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
8659 ada_is_fixed_point_type (struct type *type)
8661 return fixed_type_info (type) != NULL;
8664 /* Return non-zero iff TYPE represents a System.Address type. */
8667 ada_is_system_address_type (struct type *type)
8669 return (TYPE_NAME (type)
8670 && strcmp (TYPE_NAME (type), "system__address") == 0);
8673 /* Assuming that TYPE is the representation of an Ada fixed-point
8674 type, return its delta, or -1 if the type is malformed and the
8675 delta cannot be determined. */
8678 ada_delta (struct type *type)
8680 const char *encoding = fixed_type_info (type);
8683 if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
8686 return (DOUBLEST) num / (DOUBLEST) den;
8689 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
8690 factor ('SMALL value) associated with the type. */
8693 scaling_factor (struct type *type)
8695 const char *encoding = fixed_type_info (type);
8696 unsigned long num0, den0, num1, den1;
8699 n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);
8704 return (DOUBLEST) num1 / (DOUBLEST) den1;
8706 return (DOUBLEST) num0 / (DOUBLEST) den0;
8710 /* Assuming that X is the representation of a value of fixed-point
8711 type TYPE, return its floating-point equivalent. */
8714 ada_fixed_to_float (struct type *type, LONGEST x)
8716 return (DOUBLEST) x *scaling_factor (type);
8719 /* The representation of a fixed-point value of type TYPE
8720 corresponding to the value X. */
8723 ada_float_to_fixed (struct type *type, DOUBLEST x)
8725 return (LONGEST) (x / scaling_factor (type) + 0.5);
8729 /* VAX floating formats */
8731 /* Non-zero iff TYPE represents one of the special VAX floating-point
8735 ada_is_vax_floating_type (struct type *type)
8738 (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
8741 && (TYPE_CODE (type) == TYPE_CODE_INT
8742 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8743 && strncmp (ada_type_name (type) + name_len - 6, "___XF", 5) == 0;
8746 /* The type of special VAX floating-point type this is, assuming
8747 ada_is_vax_floating_point. */
8750 ada_vax_float_type_suffix (struct type *type)
8752 return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
8755 /* A value representing the special debugging function that outputs
8756 VAX floating-point values of the type represented by TYPE. Assumes
8757 ada_is_vax_floating_type (TYPE). */
8760 ada_vax_float_print_function (struct type *type)
8762 switch (ada_vax_float_type_suffix (type))
8765 return get_var_value ("DEBUG_STRING_F", 0);
8767 return get_var_value ("DEBUG_STRING_D", 0);
8769 return get_var_value ("DEBUG_STRING_G", 0);
8771 error (_("invalid VAX floating-point type"));
8778 /* Scan STR beginning at position K for a discriminant name, and
8779 return the value of that discriminant field of DVAL in *PX. If
8780 PNEW_K is not null, put the position of the character beyond the
8781 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
8782 not alter *PX and *PNEW_K if unsuccessful. */
8785 scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
8788 static char *bound_buffer = NULL;
8789 static size_t bound_buffer_len = 0;
8792 struct value *bound_val;
8794 if (dval == NULL || str == NULL || str[k] == '\0')
8797 pend = strstr (str + k, "__");
8801 k += strlen (bound);
8805 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
8806 bound = bound_buffer;
8807 strncpy (bound_buffer, str + k, pend - (str + k));
8808 bound[pend - (str + k)] = '\0';
8812 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
8813 if (bound_val == NULL)
8816 *px = value_as_long (bound_val);
8822 /* Value of variable named NAME in the current environment. If
8823 no such variable found, then if ERR_MSG is null, returns 0, and
8824 otherwise causes an error with message ERR_MSG. */
8826 static struct value *
8827 get_var_value (char *name, char *err_msg)
8829 struct ada_symbol_info *syms;
8832 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
8837 if (err_msg == NULL)
8840 error (("%s"), err_msg);
8843 return value_of_variable (syms[0].sym, syms[0].block);
8846 /* Value of integer variable named NAME in the current environment. If
8847 no such variable found, returns 0, and sets *FLAG to 0. If
8848 successful, sets *FLAG to 1. */
8851 get_int_var_value (char *name, int *flag)
8853 struct value *var_val = get_var_value (name, 0);
8865 return value_as_long (var_val);
8870 /* Return a range type whose base type is that of the range type named
8871 NAME in the current environment, and whose bounds are calculated
8872 from NAME according to the GNAT range encoding conventions.
8873 Extract discriminant values, if needed, from DVAL. If a new type
8874 must be created, allocate in OBJFILE's space. The bounds
8875 information, in general, is encoded in NAME, the base type given in
8876 the named range type. */
8878 static struct type *
8879 to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
8881 struct type *raw_type = ada_find_any_type (name);
8882 struct type *base_type;
8885 if (raw_type == NULL)
8886 base_type = builtin_type_int;
8887 else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
8888 base_type = TYPE_TARGET_TYPE (raw_type);
8890 base_type = raw_type;
8892 subtype_info = strstr (name, "___XD");
8893 if (subtype_info == NULL)
8897 static char *name_buf = NULL;
8898 static size_t name_len = 0;
8899 int prefix_len = subtype_info - name;
8905 GROW_VECT (name_buf, name_len, prefix_len + 5);
8906 strncpy (name_buf, name, prefix_len);
8907 name_buf[prefix_len] = '\0';
8910 bounds_str = strchr (subtype_info, '_');
8913 if (*subtype_info == 'L')
8915 if (!ada_scan_number (bounds_str, n, &L, &n)
8916 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
8918 if (bounds_str[n] == '_')
8920 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
8927 strcpy (name_buf + prefix_len, "___L");
8928 L = get_int_var_value (name_buf, &ok);
8931 lim_warning (_("Unknown lower bound, using 1."));
8936 if (*subtype_info == 'U')
8938 if (!ada_scan_number (bounds_str, n, &U, &n)
8939 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
8945 strcpy (name_buf + prefix_len, "___U");
8946 U = get_int_var_value (name_buf, &ok);
8949 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
8954 if (objfile == NULL)
8955 objfile = TYPE_OBJFILE (base_type);
8956 type = create_range_type (alloc_type (objfile), base_type, L, U);
8957 TYPE_NAME (type) = name;
8962 /* True iff NAME is the name of a range type. */
8965 ada_is_range_type_name (const char *name)
8967 return (name != NULL && strstr (name, "___XD"));
8973 /* True iff TYPE is an Ada modular type. */
8976 ada_is_modular_type (struct type *type)
8978 struct type *subranged_type = base_type (type);
8980 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
8981 && TYPE_CODE (subranged_type) != TYPE_CODE_ENUM
8982 && TYPE_UNSIGNED (subranged_type));
8985 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
8988 ada_modulus (struct type * type)
8990 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
8994 /* Information about operators given special treatment in functions
8996 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
8998 #define ADA_OPERATORS \
8999 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
9000 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
9001 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
9002 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
9003 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
9004 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
9005 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
9006 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
9007 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
9008 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
9009 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
9010 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
9011 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
9012 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
9013 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
9014 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
9015 OP_DEFN (OP_OTHERS, 1, 1, 0) \
9016 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
9017 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
9020 ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp)
9022 switch (exp->elts[pc - 1].opcode)
9025 operator_length_standard (exp, pc, oplenp, argsp);
9028 #define OP_DEFN(op, len, args, binop) \
9029 case op: *oplenp = len; *argsp = args; break;
9035 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
9040 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
9046 ada_op_name (enum exp_opcode opcode)
9051 return op_name_standard (opcode);
9053 #define OP_DEFN(op, len, args, binop) case op: return #op;
9058 return "OP_AGGREGATE";
9060 return "OP_CHOICES";
9066 /* As for operator_length, but assumes PC is pointing at the first
9067 element of the operator, and gives meaningful results only for the
9068 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
9071 ada_forward_operator_length (struct expression *exp, int pc,
9072 int *oplenp, int *argsp)
9074 switch (exp->elts[pc].opcode)
9077 *oplenp = *argsp = 0;
9080 #define OP_DEFN(op, len, args, binop) \
9081 case op: *oplenp = len; *argsp = args; break;
9087 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
9092 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
9098 int len = longest_to_int (exp->elts[pc + 1].longconst);
9099 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
9107 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
9109 enum exp_opcode op = exp->elts[elt].opcode;
9114 ada_forward_operator_length (exp, elt, &oplen, &nargs);
9118 /* Ada attributes ('Foo). */
9125 case OP_ATR_MODULUS:
9134 /* XXX: gdb_sprint_host_address, type_sprint */
9135 fprintf_filtered (stream, _("Type @"));
9136 gdb_print_host_address (exp->elts[pc + 1].type, stream);
9137 fprintf_filtered (stream, " (");
9138 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
9139 fprintf_filtered (stream, ")");
9141 case BINOP_IN_BOUNDS:
9142 fprintf_filtered (stream, " (%d)",
9143 longest_to_int (exp->elts[pc + 2].longconst));
9145 case TERNOP_IN_RANGE:
9150 case OP_DISCRETE_RANGE:
9158 char *name = &exp->elts[elt + 2].string;
9159 int len = longest_to_int (exp->elts[elt + 1].longconst);
9160 fprintf_filtered (stream, "Text: `%.*s'", len, name);
9165 return dump_subexp_body_standard (exp, stream, elt);
9169 for (i = 0; i < nargs; i += 1)
9170 elt = dump_subexp (exp, stream, elt);
9175 /* The Ada extension of print_subexp (q.v.). */
9178 ada_print_subexp (struct expression *exp, int *pos,
9179 struct ui_file *stream, enum precedence prec)
9181 int oplen, nargs, i;
9183 enum exp_opcode op = exp->elts[pc].opcode;
9185 ada_forward_operator_length (exp, pc, &oplen, &nargs);
9192 print_subexp_standard (exp, pos, stream, prec);
9196 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
9199 case BINOP_IN_BOUNDS:
9200 /* XXX: sprint_subexp */
9201 print_subexp (exp, pos, stream, PREC_SUFFIX);
9202 fputs_filtered (" in ", stream);
9203 print_subexp (exp, pos, stream, PREC_SUFFIX);
9204 fputs_filtered ("'range", stream);
9205 if (exp->elts[pc + 1].longconst > 1)
9206 fprintf_filtered (stream, "(%ld)",
9207 (long) exp->elts[pc + 1].longconst);
9210 case TERNOP_IN_RANGE:
9211 if (prec >= PREC_EQUAL)
9212 fputs_filtered ("(", stream);
9213 /* XXX: sprint_subexp */
9214 print_subexp (exp, pos, stream, PREC_SUFFIX);
9215 fputs_filtered (" in ", stream);
9216 print_subexp (exp, pos, stream, PREC_EQUAL);
9217 fputs_filtered (" .. ", stream);
9218 print_subexp (exp, pos, stream, PREC_EQUAL);
9219 if (prec >= PREC_EQUAL)
9220 fputs_filtered (")", stream);
9229 case OP_ATR_MODULUS:
9234 if (exp->elts[*pos].opcode == OP_TYPE)
9236 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
9237 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
9241 print_subexp (exp, pos, stream, PREC_SUFFIX);
9242 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
9246 for (tem = 1; tem < nargs; tem += 1)
9248 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
9249 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
9251 fputs_filtered (")", stream);
9256 type_print (exp->elts[pc + 1].type, "", stream, 0);
9257 fputs_filtered ("'(", stream);
9258 print_subexp (exp, pos, stream, PREC_PREFIX);
9259 fputs_filtered (")", stream);
9263 /* XXX: sprint_subexp */
9264 print_subexp (exp, pos, stream, PREC_SUFFIX);
9265 fputs_filtered (" in ", stream);
9266 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
9269 case OP_DISCRETE_RANGE:
9270 print_subexp (exp, pos, stream, PREC_SUFFIX);
9271 fputs_filtered ("..", stream);
9272 print_subexp (exp, pos, stream, PREC_SUFFIX);
9276 fputs_filtered ("others => ", stream);
9277 print_subexp (exp, pos, stream, PREC_SUFFIX);
9281 for (i = 0; i < nargs-1; i += 1)
9284 fputs_filtered ("|", stream);
9285 print_subexp (exp, pos, stream, PREC_SUFFIX);
9287 fputs_filtered (" => ", stream);
9288 print_subexp (exp, pos, stream, PREC_SUFFIX);
9292 print_subexp (exp, pos, stream, PREC_SUFFIX);
9296 fputs_filtered ("(", stream);
9297 for (i = 0; i < nargs; i += 1)
9300 fputs_filtered (", ", stream);
9301 print_subexp (exp, pos, stream, PREC_SUFFIX);
9303 fputs_filtered (")", stream);
9308 /* Table mapping opcodes into strings for printing operators
9309 and precedences of the operators. */
9311 static const struct op_print ada_op_print_tab[] = {
9312 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
9313 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
9314 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
9315 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
9316 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
9317 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
9318 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
9319 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
9320 {"<=", BINOP_LEQ, PREC_ORDER, 0},
9321 {">=", BINOP_GEQ, PREC_ORDER, 0},
9322 {">", BINOP_GTR, PREC_ORDER, 0},
9323 {"<", BINOP_LESS, PREC_ORDER, 0},
9324 {">>", BINOP_RSH, PREC_SHIFT, 0},
9325 {"<<", BINOP_LSH, PREC_SHIFT, 0},
9326 {"+", BINOP_ADD, PREC_ADD, 0},
9327 {"-", BINOP_SUB, PREC_ADD, 0},
9328 {"&", BINOP_CONCAT, PREC_ADD, 0},
9329 {"*", BINOP_MUL, PREC_MUL, 0},
9330 {"/", BINOP_DIV, PREC_MUL, 0},
9331 {"rem", BINOP_REM, PREC_MUL, 0},
9332 {"mod", BINOP_MOD, PREC_MUL, 0},
9333 {"**", BINOP_EXP, PREC_REPEAT, 0},
9334 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
9335 {"-", UNOP_NEG, PREC_PREFIX, 0},
9336 {"+", UNOP_PLUS, PREC_PREFIX, 0},
9337 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
9338 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
9339 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
9340 {".all", UNOP_IND, PREC_SUFFIX, 1},
9341 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
9342 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
9346 /* Fundamental Ada Types */
9348 /* Create a fundamental Ada type using default reasonable for the current
9351 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
9352 define fundamental types such as "int" or "double". Others (stabs or
9353 DWARF version 2, etc) do define fundamental types. For the formats which
9354 don't provide fundamental types, gdb can create such types using this
9357 FIXME: Some compilers distinguish explicitly signed integral types
9358 (signed short, signed int, signed long) from "regular" integral types
9359 (short, int, long) in the debugging information. There is some dis-
9360 agreement as to how useful this feature is. In particular, gcc does
9361 not support this. Also, only some debugging formats allow the
9362 distinction to be passed on to a debugger. For now, we always just
9363 use "short", "int", or "long" as the type name, for both the implicit
9364 and explicitly signed types. This also makes life easier for the
9365 gdb test suite since we don't have to account for the differences
9366 in output depending upon what the compiler and debugging format
9367 support. We will probably have to re-examine the issue when gdb
9368 starts taking it's fundamental type information directly from the
9369 debugging information supplied by the compiler. fnf@cygnus.com */
9371 static struct type *
9372 ada_create_fundamental_type (struct objfile *objfile, int typeid)
9374 struct type *type = NULL;
9379 /* FIXME: For now, if we are asked to produce a type not in this
9380 language, create the equivalent of a C integer type with the
9381 name "<?type?>". When all the dust settles from the type
9382 reconstruction work, this should probably become an error. */
9383 type = init_type (TYPE_CODE_INT,
9384 TARGET_INT_BIT / TARGET_CHAR_BIT,
9385 0, "<?type?>", objfile);
9386 warning (_("internal error: no Ada fundamental type %d"), typeid);
9389 type = init_type (TYPE_CODE_VOID,
9390 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
9391 0, "void", objfile);
9394 type = init_type (TYPE_CODE_INT,
9395 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
9396 0, "character", objfile);
9398 case FT_SIGNED_CHAR:
9399 type = init_type (TYPE_CODE_INT,
9400 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
9401 0, "signed char", objfile);
9403 case FT_UNSIGNED_CHAR:
9404 type = init_type (TYPE_CODE_INT,
9405 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
9406 TYPE_FLAG_UNSIGNED, "unsigned char", objfile);
9409 type = init_type (TYPE_CODE_INT,
9410 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
9411 0, "short_integer", objfile);
9413 case FT_SIGNED_SHORT:
9414 type = init_type (TYPE_CODE_INT,
9415 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
9416 0, "short_integer", objfile);
9418 case FT_UNSIGNED_SHORT:
9419 type = init_type (TYPE_CODE_INT,
9420 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
9421 TYPE_FLAG_UNSIGNED, "unsigned short", objfile);
9424 type = init_type (TYPE_CODE_INT,
9425 TARGET_INT_BIT / TARGET_CHAR_BIT,
9426 0, "integer", objfile);
9428 case FT_SIGNED_INTEGER:
9429 type = init_type (TYPE_CODE_INT, TARGET_INT_BIT /
9431 0, "integer", objfile); /* FIXME -fnf */
9433 case FT_UNSIGNED_INTEGER:
9434 type = init_type (TYPE_CODE_INT,
9435 TARGET_INT_BIT / TARGET_CHAR_BIT,
9436 TYPE_FLAG_UNSIGNED, "unsigned int", objfile);
9439 type = init_type (TYPE_CODE_INT,
9440 TARGET_LONG_BIT / TARGET_CHAR_BIT,
9441 0, "long_integer", objfile);
9443 case FT_SIGNED_LONG:
9444 type = init_type (TYPE_CODE_INT,
9445 TARGET_LONG_BIT / TARGET_CHAR_BIT,
9446 0, "long_integer", objfile);
9448 case FT_UNSIGNED_LONG:
9449 type = init_type (TYPE_CODE_INT,
9450 TARGET_LONG_BIT / TARGET_CHAR_BIT,
9451 TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
9454 type = init_type (TYPE_CODE_INT,
9455 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
9456 0, "long_long_integer", objfile);
9458 case FT_SIGNED_LONG_LONG:
9459 type = init_type (TYPE_CODE_INT,
9460 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
9461 0, "long_long_integer", objfile);
9463 case FT_UNSIGNED_LONG_LONG:
9464 type = init_type (TYPE_CODE_INT,
9465 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
9466 TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
9469 type = init_type (TYPE_CODE_FLT,
9470 TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
9471 0, "float", objfile);
9473 case FT_DBL_PREC_FLOAT:
9474 type = init_type (TYPE_CODE_FLT,
9475 TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
9476 0, "long_float", objfile);
9478 case FT_EXT_PREC_FLOAT:
9479 type = init_type (TYPE_CODE_FLT,
9480 TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
9481 0, "long_long_float", objfile);
9487 enum ada_primitive_types {
9488 ada_primitive_type_int,
9489 ada_primitive_type_long,
9490 ada_primitive_type_short,
9491 ada_primitive_type_char,
9492 ada_primitive_type_float,
9493 ada_primitive_type_double,
9494 ada_primitive_type_void,
9495 ada_primitive_type_long_long,
9496 ada_primitive_type_long_double,
9497 ada_primitive_type_natural,
9498 ada_primitive_type_positive,
9499 ada_primitive_type_system_address,
9500 nr_ada_primitive_types
9504 ada_language_arch_info (struct gdbarch *current_gdbarch,
9505 struct language_arch_info *lai)
9507 const struct builtin_type *builtin = builtin_type (current_gdbarch);
9508 lai->primitive_type_vector
9509 = GDBARCH_OBSTACK_CALLOC (current_gdbarch, nr_ada_primitive_types + 1,
9511 lai->primitive_type_vector [ada_primitive_type_int] =
9512 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
9513 0, "integer", (struct objfile *) NULL);
9514 lai->primitive_type_vector [ada_primitive_type_long] =
9515 init_type (TYPE_CODE_INT, TARGET_LONG_BIT / TARGET_CHAR_BIT,
9516 0, "long_integer", (struct objfile *) NULL);
9517 lai->primitive_type_vector [ada_primitive_type_short] =
9518 init_type (TYPE_CODE_INT, TARGET_SHORT_BIT / TARGET_CHAR_BIT,
9519 0, "short_integer", (struct objfile *) NULL);
9520 lai->string_char_type =
9521 lai->primitive_type_vector [ada_primitive_type_char] =
9522 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
9523 0, "character", (struct objfile *) NULL);
9524 lai->primitive_type_vector [ada_primitive_type_float] =
9525 init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
9526 0, "float", (struct objfile *) NULL);
9527 lai->primitive_type_vector [ada_primitive_type_double] =
9528 init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
9529 0, "long_float", (struct objfile *) NULL);
9530 lai->primitive_type_vector [ada_primitive_type_long_long] =
9531 init_type (TYPE_CODE_INT, TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
9532 0, "long_long_integer", (struct objfile *) NULL);
9533 lai->primitive_type_vector [ada_primitive_type_long_double] =
9534 init_type (TYPE_CODE_FLT, TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
9535 0, "long_long_float", (struct objfile *) NULL);
9536 lai->primitive_type_vector [ada_primitive_type_natural] =
9537 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
9538 0, "natural", (struct objfile *) NULL);
9539 lai->primitive_type_vector [ada_primitive_type_positive] =
9540 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
9541 0, "positive", (struct objfile *) NULL);
9542 lai->primitive_type_vector [ada_primitive_type_void] = builtin->builtin_void;
9544 lai->primitive_type_vector [ada_primitive_type_system_address] =
9545 lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
9546 (struct objfile *) NULL));
9547 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
9548 = "system__address";
9551 /* Language vector */
9553 /* Not really used, but needed in the ada_language_defn. */
9556 emit_char (int c, struct ui_file *stream, int quoter)
9558 ada_emit_char (c, stream, quoter, 1);
9564 warnings_issued = 0;
9565 return ada_parse ();
9568 static const struct exp_descriptor ada_exp_descriptor = {
9570 ada_operator_length,
9572 ada_dump_subexp_body,
9576 const struct language_defn ada_language_defn = {
9577 "ada", /* Language name */
9582 case_sensitive_on, /* Yes, Ada is case-insensitive, but
9583 that's not quite what this means. */
9585 &ada_exp_descriptor,
9589 ada_printchar, /* Print a character constant */
9590 ada_printstr, /* Function to print string constant */
9591 emit_char, /* Function to print single char (not used) */
9592 ada_create_fundamental_type, /* Create fundamental type in this language */
9593 ada_print_type, /* Print a type using appropriate syntax */
9594 ada_val_print, /* Print a value using appropriate syntax */
9595 ada_value_print, /* Print a top-level value */
9596 NULL, /* Language specific skip_trampoline */
9597 NULL, /* value_of_this */
9598 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
9599 basic_lookup_transparent_type, /* lookup_transparent_type */
9600 ada_la_decode, /* Language specific symbol demangler */
9601 NULL, /* Language specific class_name_from_physname */
9602 ada_op_print_tab, /* expression operators for printing */
9603 0, /* c-style arrays */
9604 1, /* String lower bound */
9606 ada_get_gdb_completer_word_break_characters,
9607 ada_language_arch_info,
9608 ada_print_array_index,
9613 _initialize_ada_language (void)
9615 add_language (&ada_language_defn);
9617 varsize_limit = 65536;
9619 obstack_init (&symbol_list_obstack);
9621 decoded_names_store = htab_create_alloc
9622 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
9623 NULL, xcalloc, xfree);