1 /* Ada language support routines for GDB, the GNU debugger. Copyright
2 1992, 1993, 1994, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
4 This file is part of GDB.
6 This program is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2 of the License, or
9 (at your option) any later version.
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with this program; if not, write to the Free Software
18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
29 #include "expression.h"
30 #include "parser-defs.h"
36 #include "breakpoint.h"
43 struct cleanup* unresolved_names;
45 void extract_string (CORE_ADDR addr, char *buf);
47 static struct type * ada_create_fundamental_type (struct objfile *, int);
49 static void modify_general_field (char *, LONGEST, int, int);
51 static struct type* desc_base_type (struct type*);
53 static struct type* desc_bounds_type (struct type*);
55 static struct value* desc_bounds (struct value*);
57 static int fat_pntr_bounds_bitpos (struct type*);
59 static int fat_pntr_bounds_bitsize (struct type*);
61 static struct type* desc_data_type (struct type*);
63 static struct value* desc_data (struct value*);
65 static int fat_pntr_data_bitpos (struct type*);
67 static int fat_pntr_data_bitsize (struct type*);
69 static struct value* desc_one_bound (struct value*, int, int);
71 static int desc_bound_bitpos (struct type*, int, int);
73 static int desc_bound_bitsize (struct type*, int, int);
75 static struct type* desc_index_type (struct type*, int);
77 static int desc_arity (struct type*);
79 static int ada_type_match (struct type*, struct type*, int);
81 static int ada_args_match (struct symbol*, struct value**, int);
83 static struct value* place_on_stack (struct value*, CORE_ADDR*);
85 static struct value* convert_actual (struct value*, struct type*, CORE_ADDR*);
87 static struct value* make_array_descriptor (struct type*, struct value*, CORE_ADDR*);
89 static void ada_add_block_symbols (struct block*, const char*,
90 namespace_enum, struct objfile*, int);
92 static void fill_in_ada_prototype (struct symbol*);
94 static int is_nonfunction (struct symbol**, int);
96 static void add_defn_to_vec (struct symbol*, struct block*);
98 static struct partial_symbol*
99 ada_lookup_partial_symbol (struct partial_symtab*, const char*,
100 int, namespace_enum, int);
102 static struct symtab* symtab_for_sym (struct symbol*);
104 static struct value* ada_resolve_subexp (struct expression**, int*, int, struct type*);
106 static void replace_operator_with_call (struct expression**, int, int, int,
107 struct symbol*, struct block*);
109 static int possible_user_operator_p (enum exp_opcode, struct value**);
111 static const char* ada_op_name (enum exp_opcode);
113 static int numeric_type_p (struct type*);
115 static int integer_type_p (struct type*);
117 static int scalar_type_p (struct type*);
119 static int discrete_type_p (struct type*);
121 static char* extended_canonical_line_spec (struct symtab_and_line, const char*);
123 static struct value* evaluate_subexp (struct type*, struct expression*, int*, enum noside);
125 static struct value* evaluate_subexp_type (struct expression*, int*);
127 static struct type * ada_create_fundamental_type (struct objfile*, int);
129 static int is_dynamic_field (struct type *, int);
132 to_fixed_variant_branch_type (struct type*, char*, CORE_ADDR, struct value*);
134 static struct type* to_fixed_range_type (char*, struct value*, struct objfile*);
136 static struct type* to_static_fixed_type (struct type*);
138 static struct value* unwrap_value (struct value*);
140 static struct type* packed_array_type (struct type*, long*);
142 static struct type* decode_packed_array_type (struct type*);
144 static struct value* decode_packed_array (struct value*);
146 static struct value* value_subscript_packed (struct value*, int, struct value**);
148 static struct value* coerce_unspec_val_to_type (struct value*, long, struct type*);
150 static struct value* get_var_value (char*, char*);
152 static int lesseq_defined_than (struct symbol*, struct symbol*);
154 static int equiv_types (struct type*, struct type*);
156 static int is_name_suffix (const char*);
158 static int wild_match (const char*, int, const char*);
160 static struct symtabs_and_lines find_sal_from_funcs_and_line (const char*, int, struct symbol**, int);
163 find_line_in_linetable (struct linetable*, int, struct symbol**, int, int*);
165 static int find_next_line_in_linetable (struct linetable*, int, int, int);
167 static struct symtabs_and_lines all_sals_for_line (const char*, int, char***);
169 static void read_all_symtabs (const char*);
171 static int is_plausible_func_for_line (struct symbol*, int);
173 static struct value* ada_coerce_ref (struct value*);
175 static struct value* value_pos_atr (struct value*);
177 static struct value* value_val_atr (struct type*, struct value*);
179 static struct symbol* standard_lookup (const char*, namespace_enum);
181 extern void markTimeStart (int index);
182 extern void markTimeStop (int index);
186 /* Maximum-sized dynamic type. */
187 static unsigned int varsize_limit;
189 static const char* ada_completer_word_break_characters =
190 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
192 /* The name of the symbol to use to get the name of the main subprogram */
193 #define ADA_MAIN_PROGRAM_SYMBOL_NAME "__gnat_ada_main_program_name"
199 * read the string located at ADDR from the inferior and store the
203 extract_string (CORE_ADDR addr, char *buf)
207 /* Loop, reading one byte at a time, until we reach the '\000'
208 end-of-string marker */
211 target_read_memory (addr + char_index * sizeof (char),
212 buf + char_index * sizeof (char),
216 while (buf[char_index - 1] != '\000');
219 /* Assuming *OLD_VECT points to an array of *SIZE objects of size
220 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
221 updating *OLD_VECT and *SIZE as necessary. */
224 grow_vect (old_vect, size, min_size, element_size)
230 if (*size < min_size) {
232 if (*size < min_size)
234 *old_vect = xrealloc (*old_vect, *size * element_size);
238 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
239 suffix of FIELD_NAME beginning "___" */
242 field_name_match (field_name, target)
243 const char *field_name;
246 int len = strlen (target);
248 STREQN (field_name, target, len)
249 && (field_name[len] == '\0'
250 || (STREQN (field_name + len, "___", 3)
251 && ! STREQ (field_name + strlen (field_name) - 6, "___XVN")));
255 /* The length of the prefix of NAME prior to any "___" suffix. */
258 ada_name_prefix_len (name)
265 const char* p = strstr (name, "___");
267 return strlen (name);
273 /* SUFFIX is a suffix of STR. False if STR is null. */
275 is_suffix (const char* str, const char* suffix)
281 len2 = strlen (suffix);
282 return (len1 >= len2 && STREQ (str + len1 - len2, suffix));
285 /* Create a value of type TYPE whose contents come from VALADDR, if it
286 * is non-null, and whose memory address (in the inferior) is
289 value_from_contents_and_address (type, valaddr, address)
294 struct value* v = allocate_value (type);
298 memcpy (VALUE_CONTENTS_RAW (v), valaddr, TYPE_LENGTH (type));
299 VALUE_ADDRESS (v) = address;
301 VALUE_LVAL (v) = lval_memory;
305 /* The contents of value VAL, beginning at offset OFFSET, treated as a
306 value of type TYPE. The result is an lval in memory if VAL is. */
309 coerce_unspec_val_to_type (val, offset, type)
314 CHECK_TYPEDEF (type);
315 if (VALUE_LVAL (val) == lval_memory)
316 return value_at_lazy (type,
317 VALUE_ADDRESS (val) + VALUE_OFFSET (val) + offset, NULL);
320 struct value* result = allocate_value (type);
321 VALUE_LVAL (result) = not_lval;
322 if (VALUE_ADDRESS (val) == 0)
323 memcpy (VALUE_CONTENTS_RAW (result), VALUE_CONTENTS (val) + offset,
324 TYPE_LENGTH (type) > TYPE_LENGTH (VALUE_TYPE (val))
325 ? TYPE_LENGTH (VALUE_TYPE (val)) : TYPE_LENGTH (type));
328 VALUE_ADDRESS (result) =
329 VALUE_ADDRESS (val) + VALUE_OFFSET (val) + offset;
330 VALUE_LAZY (result) = 1;
337 cond_offset_host (valaddr, offset)
344 return valaddr + offset;
348 cond_offset_target (address, offset)
355 return address + offset;
358 /* Perform execute_command on the result of concatenating all
359 arguments up to NULL. */
361 do_command (const char* arg, ...)
372 for (; s != NULL; s = va_arg (ap, const char*))
376 cmd1 = alloca (len+1);
382 execute_command (cmd, 0);
386 /* Language Selection */
388 /* If the main program is in Ada, return language_ada, otherwise return LANG
389 (the main program is in Ada iif the adainit symbol is found).
391 MAIN_PST is not used. */
394 ada_update_initial_language (lang, main_pst)
396 struct partial_symtab* main_pst;
398 if (lookup_minimal_symbol ("adainit", (const char*) NULL,
399 (struct objfile*) NULL) != NULL)
400 /* return language_ada; */
401 /* FIXME: language_ada should be defined in defs.h */
402 return language_unknown;
410 /* Table of Ada operators and their GNAT-mangled names. Last entry is pair
413 const struct ada_opname_map ada_opname_table[] =
415 { "Oadd", "\"+\"", BINOP_ADD },
416 { "Osubtract", "\"-\"", BINOP_SUB },
417 { "Omultiply", "\"*\"", BINOP_MUL },
418 { "Odivide", "\"/\"", BINOP_DIV },
419 { "Omod", "\"mod\"", BINOP_MOD },
420 { "Orem", "\"rem\"", BINOP_REM },
421 { "Oexpon", "\"**\"", BINOP_EXP },
422 { "Olt", "\"<\"", BINOP_LESS },
423 { "Ole", "\"<=\"", BINOP_LEQ },
424 { "Ogt", "\">\"", BINOP_GTR },
425 { "Oge", "\">=\"", BINOP_GEQ },
426 { "Oeq", "\"=\"", BINOP_EQUAL },
427 { "One", "\"/=\"", BINOP_NOTEQUAL },
428 { "Oand", "\"and\"", BINOP_BITWISE_AND },
429 { "Oor", "\"or\"", BINOP_BITWISE_IOR },
430 { "Oxor", "\"xor\"", BINOP_BITWISE_XOR },
431 { "Oconcat", "\"&\"", BINOP_CONCAT },
432 { "Oabs", "\"abs\"", UNOP_ABS },
433 { "Onot", "\"not\"", UNOP_LOGICAL_NOT },
434 { "Oadd", "\"+\"", UNOP_PLUS },
435 { "Osubtract", "\"-\"", UNOP_NEG },
439 /* True if STR should be suppressed in info listings. */
441 is_suppressed_name (str)
444 if (STREQN (str, "_ada_", 5))
446 if (str[0] == '_' || str[0] == '\000')
451 const char* suffix = strstr (str, "___");
452 if (suffix != NULL && suffix[3] != 'X')
455 suffix = str + strlen (str);
456 for (p = suffix-1; p != str; p -= 1)
460 if (p[0] == 'X' && p[-1] != '_')
464 for (i = 0; ada_opname_table[i].mangled != NULL; i += 1)
465 if (STREQN (ada_opname_table[i].mangled, p,
466 strlen (ada_opname_table[i].mangled)))
475 /* The "mangled" form of DEMANGLED, according to GNAT conventions.
476 * The result is valid until the next call to ada_mangle. */
478 ada_mangle (demangled)
479 const char* demangled;
481 static char* mangling_buffer = NULL;
482 static size_t mangling_buffer_size = 0;
486 if (demangled == NULL)
489 GROW_VECT (mangling_buffer, mangling_buffer_size, 2*strlen (demangled) + 10);
492 for (p = demangled; *p != '\0'; p += 1)
496 mangling_buffer[k] = mangling_buffer[k+1] = '_';
501 const struct ada_opname_map* mapping;
503 for (mapping = ada_opname_table;
504 mapping->mangled != NULL &&
505 ! STREQN (mapping->demangled, p, strlen (mapping->demangled));
508 if (mapping->mangled == NULL)
509 error ("invalid Ada operator name: %s", p);
510 strcpy (mangling_buffer+k, mapping->mangled);
511 k += strlen (mapping->mangled);
516 mangling_buffer[k] = *p;
521 mangling_buffer[k] = '\0';
522 return mangling_buffer;
525 /* Return NAME folded to lower case, or, if surrounded by single
526 * quotes, unfolded, but with the quotes stripped away. Result good
529 ada_fold_name (const char* name)
531 static char* fold_buffer = NULL;
532 static size_t fold_buffer_size = 0;
534 int len = strlen (name);
535 GROW_VECT (fold_buffer, fold_buffer_size, len+1);
539 strncpy (fold_buffer, name+1, len-2);
540 fold_buffer[len-2] = '\000';
545 for (i = 0; i <= len; i += 1)
546 fold_buffer[i] = tolower (name[i]);
553 1. Discard final __{DIGIT}+ or ${DIGIT}+
554 2. Convert other instances of embedded "__" to `.'.
555 3. Discard leading _ada_.
556 4. Convert operator names to the appropriate quoted symbols.
557 5. Remove everything after first ___ if it is followed by
559 6. Replace TK__ with __, and a trailing B or TKB with nothing.
560 7. Put symbols that should be suppressed in <...> brackets.
561 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
562 The resulting string is valid until the next call of ada_demangle.
566 ada_demangle (mangled)
574 static char* demangling_buffer = NULL;
575 static size_t demangling_buffer_size = 0;
577 if (STREQN (mangled, "_ada_", 5))
580 if (mangled[0] == '_' || mangled[0] == '<')
583 p = strstr (mangled, "___");
585 len0 = strlen (mangled);
593 if (len0 > 3 && STREQ (mangled + len0 - 3, "TKB"))
595 if (len0 > 1 && STREQ (mangled + len0 - 1, "B"))
598 /* Make demangled big enough for possible expansion by operator name. */
599 GROW_VECT (demangling_buffer, demangling_buffer_size, 2*len0+1);
600 demangled = demangling_buffer;
602 if (isdigit (mangled[len0 - 1])) {
603 for (i = len0-2; i >= 0 && isdigit (mangled[i]); i -= 1)
605 if (i > 1 && mangled[i] == '_' && mangled[i-1] == '_')
607 else if (mangled[i] == '$')
611 for (i = 0, j = 0; i < len0 && ! isalpha (mangled[i]); i += 1, j += 1)
612 demangled[j] = mangled[i];
617 if (at_start_name && mangled[i] == 'O')
620 for (k = 0; ada_opname_table[k].mangled != NULL; k += 1)
622 int op_len = strlen (ada_opname_table[k].mangled);
623 if (STREQN (ada_opname_table[k].mangled+1, mangled+i+1, op_len-1)
624 && ! isalnum (mangled[i + op_len]))
626 strcpy (demangled + j, ada_opname_table[k].demangled);
629 j += strlen (ada_opname_table[k].demangled);
633 if (ada_opname_table[k].mangled != NULL)
638 if (i < len0-4 && STREQN (mangled+i, "TK__", 4))
640 if (mangled[i] == 'X' && i != 0 && isalnum (mangled[i-1]))
644 while (i < len0 && (mangled[i] == 'b' || mangled[i] == 'n'));
648 else if (i < len0-2 && mangled[i] == '_' && mangled[i+1] == '_')
656 demangled[j] = mangled[i];
660 demangled[j] = '\000';
662 for (i = 0; demangled[i] != '\0'; i += 1)
663 if (isupper (demangled[i]) || demangled[i] == ' ')
669 GROW_VECT (demangling_buffer, demangling_buffer_size,
670 strlen (mangled) + 3);
671 demangled = demangling_buffer;
672 if (mangled[0] == '<')
673 strcpy (demangled, mangled);
675 sprintf (demangled, "<%s>", mangled);
680 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
681 * suffixes that encode debugging information or leading _ada_ on
682 * SYM_NAME (see is_name_suffix commentary for the debugging
683 * information that is ignored). If WILD, then NAME need only match a
684 * suffix of SYM_NAME minus the same suffixes. Also returns 0 if
685 * either argument is NULL. */
688 ada_match_name (sym_name, name, wild)
689 const char* sym_name;
693 if (sym_name == NULL || name == NULL)
696 return wild_match (name, strlen (name), sym_name);
698 int len_name = strlen (name);
699 return (STREQN (sym_name, name, len_name)
700 && is_name_suffix (sym_name+len_name))
701 || (STREQN (sym_name, "_ada_", 5)
702 && STREQN (sym_name+5, name, len_name)
703 && is_name_suffix (sym_name+len_name+5));
707 /* True (non-zero) iff in Ada mode, the symbol SYM should be
708 suppressed in info listings. */
711 ada_suppress_symbol_printing (sym)
714 if (SYMBOL_NAMESPACE (sym) == STRUCT_NAMESPACE)
717 return is_suppressed_name (SYMBOL_NAME (sym));
723 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of
724 array descriptors. */
726 static char* bound_name[] = {
727 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
728 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
731 /* Maximum number of array dimensions we are prepared to handle. */
733 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char*)))
735 /* Like modify_field, but allows bitpos > wordlength. */
738 modify_general_field (addr, fieldval, bitpos, bitsize)
743 modify_field (addr + sizeof (LONGEST) * bitpos / (8 * sizeof (LONGEST)),
744 fieldval, bitpos % (8 * sizeof (LONGEST)),
749 /* The desc_* routines return primitive portions of array descriptors
752 /* The descriptor or array type, if any, indicated by TYPE; removes
753 level of indirection, if needed. */
755 desc_base_type (type)
760 CHECK_TYPEDEF (type);
761 if (type != NULL && TYPE_CODE (type) == TYPE_CODE_PTR)
762 return check_typedef (TYPE_TARGET_TYPE (type));
767 /* True iff TYPE indicates a "thin" array pointer type. */
769 is_thin_pntr (struct type* type)
772 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
773 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
776 /* The descriptor type for thin pointer type TYPE. */
778 thin_descriptor_type (struct type* type)
780 struct type* base_type = desc_base_type (type);
781 if (base_type == NULL)
783 if (is_suffix (ada_type_name (base_type), "___XVE"))
787 struct type* alt_type =
788 ada_find_parallel_type (base_type, "___XVE");
789 if (alt_type == NULL)
796 /* A pointer to the array data for thin-pointer value VAL. */
798 thin_data_pntr (struct value* val)
800 struct type* type = VALUE_TYPE (val);
801 if (TYPE_CODE (type) == TYPE_CODE_PTR)
802 return value_cast (desc_data_type (thin_descriptor_type (type)),
805 return value_from_longest (desc_data_type (thin_descriptor_type (type)),
806 VALUE_ADDRESS (val) + VALUE_OFFSET (val));
809 /* True iff TYPE indicates a "thick" array pointer type. */
811 is_thick_pntr (struct type* type)
813 type = desc_base_type (type);
814 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
815 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
818 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
819 pointer to one, the type of its bounds data; otherwise, NULL. */
821 desc_bounds_type (type)
826 type = desc_base_type (type);
830 else if (is_thin_pntr (type))
832 type = thin_descriptor_type (type);
835 r = lookup_struct_elt_type (type, "BOUNDS", 1);
837 return check_typedef (r);
839 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
841 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
843 return check_typedef (TYPE_TARGET_TYPE (check_typedef (r)));
848 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
849 one, a pointer to its bounds data. Otherwise NULL. */
854 struct type* type = check_typedef (VALUE_TYPE (arr));
855 if (is_thin_pntr (type))
857 struct type* bounds_type = desc_bounds_type (thin_descriptor_type (type));
860 if (desc_bounds_type == NULL)
861 error ("Bad GNAT array descriptor");
863 /* NOTE: The following calculation is not really kosher, but
864 since desc_type is an XVE-encoded type (and shouldn't be),
865 the correct calculation is a real pain. FIXME (and fix GCC). */
866 if (TYPE_CODE (type) == TYPE_CODE_PTR)
867 addr = value_as_long (arr);
869 addr = VALUE_ADDRESS (arr) + VALUE_OFFSET (arr);
872 value_from_longest (lookup_pointer_type (bounds_type),
873 addr - TYPE_LENGTH (bounds_type));
876 else if (is_thick_pntr (type))
877 return value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
878 "Bad GNAT array descriptor");
883 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
884 position of the field containing the address of the bounds data. */
886 fat_pntr_bounds_bitpos (type)
889 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
892 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
893 size of the field containing the address of the bounds data. */
895 fat_pntr_bounds_bitsize (type)
898 type = desc_base_type (type);
900 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
901 return TYPE_FIELD_BITSIZE (type, 1);
903 return 8 * TYPE_LENGTH (check_typedef (TYPE_FIELD_TYPE (type, 1)));
906 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
907 pointer to one, the type of its array data (a
908 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
909 ada_type_of_array to get an array type with bounds data. */
911 desc_data_type (type)
914 type = desc_base_type (type);
916 /* NOTE: The following is bogus; see comment in desc_bounds. */
917 if (is_thin_pntr (type))
918 return lookup_pointer_type
919 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type),1)));
920 else if (is_thick_pntr (type))
921 return lookup_struct_elt_type (type, "P_ARRAY", 1);
926 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
932 struct type* type = VALUE_TYPE (arr);
933 if (is_thin_pntr (type))
934 return thin_data_pntr (arr);
935 else if (is_thick_pntr (type))
936 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
937 "Bad GNAT array descriptor");
943 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
944 position of the field containing the address of the data. */
946 fat_pntr_data_bitpos (type)
949 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
952 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
953 size of the field containing the address of the data. */
955 fat_pntr_data_bitsize (type)
958 type = desc_base_type (type);
960 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
961 return TYPE_FIELD_BITSIZE (type, 0);
963 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
966 /* If BOUNDS is an array-bounds structure (or pointer to one), return
967 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
968 bound, if WHICH is 1. The first bound is I=1. */
970 desc_one_bound (bounds, i, which)
971 struct value* bounds;
975 return value_struct_elt (&bounds, NULL, bound_name[2*i+which-2], NULL,
976 "Bad GNAT array descriptor bounds");
979 /* If BOUNDS is an array-bounds structure type, return the bit position
980 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
981 bound, if WHICH is 1. The first bound is I=1. */
983 desc_bound_bitpos (type, i, which)
988 return TYPE_FIELD_BITPOS (desc_base_type (type), 2*i+which-2);
991 /* If BOUNDS is an array-bounds structure type, return the bit field size
992 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
993 bound, if WHICH is 1. The first bound is I=1. */
995 desc_bound_bitsize (type, i, which)
1000 type = desc_base_type (type);
1002 if (TYPE_FIELD_BITSIZE (type, 2*i+which-2) > 0)
1003 return TYPE_FIELD_BITSIZE (type, 2*i+which-2);
1005 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2*i+which-2));
1008 /* If TYPE is the type of an array-bounds structure, the type of its
1009 Ith bound (numbering from 1). Otherwise, NULL. */
1011 desc_index_type (type, i)
1015 type = desc_base_type (type);
1017 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1018 return lookup_struct_elt_type (type, bound_name[2*i-2], 1);
1023 /* The number of index positions in the array-bounds type TYPE. 0
1029 type = desc_base_type (type);
1032 return TYPE_NFIELDS (type) / 2;
1037 /* Non-zero iff type is a simple array type (or pointer to one). */
1039 ada_is_simple_array (type)
1044 CHECK_TYPEDEF (type);
1045 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1046 || (TYPE_CODE (type) == TYPE_CODE_PTR
1047 && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY));
1050 /* Non-zero iff type belongs to a GNAT array descriptor. */
1052 ada_is_array_descriptor (type)
1055 struct type* data_type = desc_data_type (type);
1059 CHECK_TYPEDEF (type);
1062 && ((TYPE_CODE (data_type) == TYPE_CODE_PTR
1063 && TYPE_TARGET_TYPE (data_type) != NULL
1064 && TYPE_CODE (TYPE_TARGET_TYPE (data_type)) == TYPE_CODE_ARRAY)
1066 TYPE_CODE (data_type) == TYPE_CODE_ARRAY)
1067 && desc_arity (desc_bounds_type (type)) > 0;
1070 /* Non-zero iff type is a partially mal-formed GNAT array
1071 descriptor. (FIXME: This is to compensate for some problems with
1072 debugging output from GNAT. Re-examine periodically to see if it
1075 ada_is_bogus_array_descriptor (type)
1080 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1081 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1082 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1083 && ! ada_is_array_descriptor (type);
1087 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1088 (fat pointer) returns the type of the array data described---specifically,
1089 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1090 in from the descriptor; otherwise, they are left unspecified. If
1091 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1092 returns NULL. The result is simply the type of ARR if ARR is not
1095 ada_type_of_array (arr, bounds)
1099 if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1100 return decode_packed_array_type (VALUE_TYPE (arr));
1102 if (! ada_is_array_descriptor (VALUE_TYPE (arr)))
1103 return VALUE_TYPE (arr);
1106 return check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr))));
1109 struct type* elt_type;
1111 struct value* descriptor;
1112 struct objfile *objf = TYPE_OBJFILE (VALUE_TYPE (arr));
1114 elt_type = ada_array_element_type (VALUE_TYPE (arr), -1);
1115 arity = ada_array_arity (VALUE_TYPE (arr));
1117 if (elt_type == NULL || arity == 0)
1118 return check_typedef (VALUE_TYPE (arr));
1120 descriptor = desc_bounds (arr);
1121 if (value_as_long (descriptor) == 0)
1124 struct type* range_type = alloc_type (objf);
1125 struct type* array_type = alloc_type (objf);
1126 struct value* low = desc_one_bound (descriptor, arity, 0);
1127 struct value* high = desc_one_bound (descriptor, arity, 1);
1130 create_range_type (range_type, VALUE_TYPE (low),
1131 (int) value_as_long (low),
1132 (int) value_as_long (high));
1133 elt_type = create_array_type (array_type, elt_type, range_type);
1136 return lookup_pointer_type (elt_type);
1140 /* If ARR does not represent an array, returns ARR unchanged.
1141 Otherwise, returns either a standard GDB array with bounds set
1142 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1143 GDB array. Returns NULL if ARR is a null fat pointer. */
1145 ada_coerce_to_simple_array_ptr (arr)
1148 if (ada_is_array_descriptor (VALUE_TYPE (arr)))
1150 struct type* arrType = ada_type_of_array (arr, 1);
1151 if (arrType == NULL)
1153 return value_cast (arrType, value_copy (desc_data (arr)));
1155 else if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1156 return decode_packed_array (arr);
1161 /* If ARR does not represent an array, returns ARR unchanged.
1162 Otherwise, returns a standard GDB array describing ARR (which may
1163 be ARR itself if it already is in the proper form). */
1165 ada_coerce_to_simple_array (arr)
1168 if (ada_is_array_descriptor (VALUE_TYPE (arr)))
1170 struct value* arrVal = ada_coerce_to_simple_array_ptr (arr);
1172 error ("Bounds unavailable for null array pointer.");
1173 return value_ind (arrVal);
1175 else if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1176 return decode_packed_array (arr);
1181 /* If TYPE represents a GNAT array type, return it translated to an
1182 ordinary GDB array type (possibly with BITSIZE fields indicating
1183 packing). For other types, is the identity. */
1185 ada_coerce_to_simple_array_type (type)
1188 struct value* mark = value_mark ();
1189 struct value* dummy = value_from_longest (builtin_type_long, 0);
1190 struct type* result;
1191 VALUE_TYPE (dummy) = type;
1192 result = ada_type_of_array (dummy, 0);
1193 value_free_to_mark (dummy);
1197 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1199 ada_is_packed_array_type (type)
1204 CHECK_TYPEDEF (type);
1206 ada_type_name (type) != NULL
1207 && strstr (ada_type_name (type), "___XP") != NULL;
1210 /* Given that TYPE is a standard GDB array type with all bounds filled
1211 in, and that the element size of its ultimate scalar constituents
1212 (that is, either its elements, or, if it is an array of arrays, its
1213 elements' elements, etc.) is *ELT_BITS, return an identical type,
1214 but with the bit sizes of its elements (and those of any
1215 constituent arrays) recorded in the BITSIZE components of its
1216 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1219 packed_array_type (type, elt_bits)
1223 struct type* new_elt_type;
1224 struct type* new_type;
1225 LONGEST low_bound, high_bound;
1227 CHECK_TYPEDEF (type);
1228 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1231 new_type = alloc_type (TYPE_OBJFILE (type));
1232 new_elt_type = packed_array_type (check_typedef (TYPE_TARGET_TYPE (type)),
1234 create_array_type (new_type, new_elt_type, TYPE_FIELD_TYPE (type, 0));
1235 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
1236 TYPE_NAME (new_type) = ada_type_name (type);
1238 if (get_discrete_bounds (TYPE_FIELD_TYPE (type, 0),
1239 &low_bound, &high_bound) < 0)
1240 low_bound = high_bound = 0;
1241 if (high_bound < low_bound)
1242 *elt_bits = TYPE_LENGTH (new_type) = 0;
1245 *elt_bits *= (high_bound - low_bound + 1);
1246 TYPE_LENGTH (new_type) =
1247 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
1250 /* TYPE_FLAGS (new_type) |= TYPE_FLAG_FIXED_INSTANCE; */
1251 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
1255 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE).
1258 decode_packed_array_type (type)
1261 struct symbol** syms;
1262 struct block** blocks;
1263 const char* raw_name = ada_type_name (check_typedef (type));
1264 char* name = (char*) alloca (strlen (raw_name) + 1);
1265 char* tail = strstr (raw_name, "___XP");
1266 struct type* shadow_type;
1270 memcpy (name, raw_name, tail - raw_name);
1271 name[tail - raw_name] = '\000';
1273 /* NOTE: Use ada_lookup_symbol_list because of bug in some versions
1274 * of gcc (Solaris, e.g.). FIXME when compiler is fixed. */
1275 n = ada_lookup_symbol_list (name, get_selected_block (NULL),
1276 VAR_NAMESPACE, &syms, &blocks);
1277 for (i = 0; i < n; i += 1)
1278 if (syms[i] != NULL && SYMBOL_CLASS (syms[i]) == LOC_TYPEDEF
1279 && STREQ (name, ada_type_name (SYMBOL_TYPE (syms[i]))))
1283 warning ("could not find bounds information on packed array");
1286 shadow_type = SYMBOL_TYPE (syms[i]);
1288 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
1290 warning ("could not understand bounds information on packed array");
1294 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1296 warning ("could not understand bit size information on packed array");
1300 return packed_array_type (shadow_type, &bits);
1303 /* Given that ARR is a struct value* indicating a GNAT packed array,
1304 returns a simple array that denotes that array. Its type is a
1305 standard GDB array type except that the BITSIZEs of the array
1306 target types are set to the number of bits in each element, and the
1307 type length is set appropriately. */
1309 static struct value*
1310 decode_packed_array (arr)
1313 struct type* type = decode_packed_array_type (VALUE_TYPE (arr));
1317 error ("can't unpack array");
1321 return coerce_unspec_val_to_type (arr, 0, type);
1325 /* The value of the element of packed array ARR at the ARITY indices
1326 given in IND. ARR must be a simple array. */
1328 static struct value*
1329 value_subscript_packed (arr, arity, ind)
1335 int bits, elt_off, bit_off;
1336 long elt_total_bit_offset;
1337 struct type* elt_type;
1341 elt_total_bit_offset = 0;
1342 elt_type = check_typedef (VALUE_TYPE (arr));
1343 for (i = 0; i < arity; i += 1)
1345 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
1346 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
1347 error ("attempt to do packed indexing of something other than a packed array");
1350 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
1351 LONGEST lowerbound, upperbound;
1354 if (get_discrete_bounds (range_type, &lowerbound,
1357 warning ("don't know bounds of array");
1358 lowerbound = upperbound = 0;
1361 idx = value_as_long (value_pos_atr (ind[i]));
1362 if (idx < lowerbound || idx > upperbound)
1363 warning ("packed array index %ld out of bounds", (long) idx);
1364 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
1365 elt_total_bit_offset += (idx - lowerbound) * bits;
1366 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
1369 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
1370 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
1372 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
1374 if (VALUE_LVAL (arr) == lval_internalvar)
1375 VALUE_LVAL (v) = lval_internalvar_component;
1377 VALUE_LVAL (v) = VALUE_LVAL (arr);
1381 /* Non-zero iff TYPE includes negative integer values. */
1384 has_negatives (type)
1387 switch (TYPE_CODE (type)) {
1391 return ! TYPE_UNSIGNED (type);
1392 case TYPE_CODE_RANGE:
1393 return TYPE_LOW_BOUND (type) < 0;
1398 /* Create a new value of type TYPE from the contents of OBJ starting
1399 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1400 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1401 assigning through the result will set the field fetched from. OBJ
1402 may also be NULL, in which case, VALADDR+OFFSET must address the
1403 start of storage containing the packed value. The value returned
1404 in this case is never an lval.
1405 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1408 ada_value_primitive_packed_val (obj, valaddr, offset, bit_offset,
1418 int src, /* Index into the source area. */
1419 targ, /* Index into the target area. */
1421 srcBitsLeft, /* Number of source bits left to move. */
1422 nsrc, ntarg, /* Number of source and target bytes. */
1423 unusedLS, /* Number of bits in next significant
1424 * byte of source that are unused. */
1425 accumSize; /* Number of meaningful bits in accum */
1426 unsigned char* bytes; /* First byte containing data to unpack. */
1427 unsigned char* unpacked;
1428 unsigned long accum; /* Staging area for bits being transferred */
1430 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
1431 /* Transmit bytes from least to most significant; delta is the
1432 * direction the indices move. */
1433 int delta = BITS_BIG_ENDIAN ? -1 : 1;
1435 CHECK_TYPEDEF (type);
1439 v = allocate_value (type);
1440 bytes = (unsigned char*) (valaddr + offset);
1442 else if (VALUE_LAZY (obj))
1445 VALUE_ADDRESS (obj) + VALUE_OFFSET (obj) + offset, NULL);
1446 bytes = (unsigned char*) alloca (len);
1447 read_memory (VALUE_ADDRESS (v), bytes, len);
1451 v = allocate_value (type);
1452 bytes = (unsigned char*) VALUE_CONTENTS (obj) + offset;
1457 VALUE_LVAL (v) = VALUE_LVAL (obj);
1458 if (VALUE_LVAL (obj) == lval_internalvar)
1459 VALUE_LVAL (v) = lval_internalvar_component;
1460 VALUE_ADDRESS (v) = VALUE_ADDRESS (obj) + VALUE_OFFSET (obj) + offset;
1461 VALUE_BITPOS (v) = bit_offset + VALUE_BITPOS (obj);
1462 VALUE_BITSIZE (v) = bit_size;
1463 if (VALUE_BITPOS (v) >= HOST_CHAR_BIT)
1465 VALUE_ADDRESS (v) += 1;
1466 VALUE_BITPOS (v) -= HOST_CHAR_BIT;
1470 VALUE_BITSIZE (v) = bit_size;
1471 unpacked = (unsigned char*) VALUE_CONTENTS (v);
1473 srcBitsLeft = bit_size;
1475 ntarg = TYPE_LENGTH (type);
1479 memset (unpacked, 0, TYPE_LENGTH (type));
1482 else if (BITS_BIG_ENDIAN)
1485 if (has_negatives (type) &&
1486 ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT-1))))
1490 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
1493 switch (TYPE_CODE (type))
1495 case TYPE_CODE_ARRAY:
1496 case TYPE_CODE_UNION:
1497 case TYPE_CODE_STRUCT:
1498 /* Non-scalar values must be aligned at a byte boundary. */
1500 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
1501 /* And are placed at the beginning (most-significant) bytes
1507 targ = TYPE_LENGTH (type) - 1;
1513 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
1516 unusedLS = bit_offset;
1519 if (has_negatives (type) && (bytes[len-1] & (1 << sign_bit_offset)))
1526 /* Mask for removing bits of the next source byte that are not
1527 * part of the value. */
1528 unsigned int unusedMSMask =
1529 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft))-1;
1530 /* Sign-extend bits for this byte. */
1531 unsigned int signMask = sign & ~unusedMSMask;
1533 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
1534 accumSize += HOST_CHAR_BIT - unusedLS;
1535 if (accumSize >= HOST_CHAR_BIT)
1537 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
1538 accumSize -= HOST_CHAR_BIT;
1539 accum >>= HOST_CHAR_BIT;
1543 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
1550 accum |= sign << accumSize;
1551 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
1552 accumSize -= HOST_CHAR_BIT;
1553 accum >>= HOST_CHAR_BIT;
1561 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1562 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1565 move_bits (char* target, int targ_offset, char* source, int src_offset, int n)
1567 unsigned int accum, mask;
1568 int accum_bits, chunk_size;
1570 target += targ_offset / HOST_CHAR_BIT;
1571 targ_offset %= HOST_CHAR_BIT;
1572 source += src_offset / HOST_CHAR_BIT;
1573 src_offset %= HOST_CHAR_BIT;
1574 if (BITS_BIG_ENDIAN)
1576 accum = (unsigned char) *source;
1578 accum_bits = HOST_CHAR_BIT - src_offset;
1583 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
1584 accum_bits += HOST_CHAR_BIT;
1586 chunk_size = HOST_CHAR_BIT - targ_offset;
1589 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
1590 mask = ((1 << chunk_size) - 1) << unused_right;
1593 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
1595 accum_bits -= chunk_size;
1602 accum = (unsigned char) *source >> src_offset;
1604 accum_bits = HOST_CHAR_BIT - src_offset;
1608 accum = accum + ((unsigned char) *source << accum_bits);
1609 accum_bits += HOST_CHAR_BIT;
1611 chunk_size = HOST_CHAR_BIT - targ_offset;
1614 mask = ((1 << chunk_size) - 1) << targ_offset;
1616 (*target & ~mask) | ((accum << targ_offset) & mask);
1618 accum_bits -= chunk_size;
1619 accum >>= chunk_size;
1627 /* Store the contents of FROMVAL into the location of TOVAL.
1628 Return a new value with the location of TOVAL and contents of
1629 FROMVAL. Handles assignment into packed fields that have
1630 floating-point or non-scalar types. */
1632 static struct value*
1633 ada_value_assign (struct value* toval, struct value* fromval)
1635 struct type* type = VALUE_TYPE (toval);
1636 int bits = VALUE_BITSIZE (toval);
1638 if (!toval->modifiable)
1639 error ("Left operand of assignment is not a modifiable lvalue.");
1643 if (VALUE_LVAL (toval) == lval_memory
1645 && (TYPE_CODE (type) == TYPE_CODE_FLT
1646 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
1649 (VALUE_BITPOS (toval) + bits + HOST_CHAR_BIT - 1)
1651 char* buffer = (char*) alloca (len);
1654 if (TYPE_CODE (type) == TYPE_CODE_FLT)
1655 fromval = value_cast (type, fromval);
1657 read_memory (VALUE_ADDRESS (toval) + VALUE_OFFSET (toval), buffer, len);
1658 if (BITS_BIG_ENDIAN)
1659 move_bits (buffer, VALUE_BITPOS (toval),
1660 VALUE_CONTENTS (fromval),
1661 TYPE_LENGTH (VALUE_TYPE (fromval)) * TARGET_CHAR_BIT - bits,
1664 move_bits (buffer, VALUE_BITPOS (toval), VALUE_CONTENTS (fromval),
1666 write_memory (VALUE_ADDRESS (toval) + VALUE_OFFSET (toval), buffer, len);
1668 val = value_copy (toval);
1669 memcpy (VALUE_CONTENTS_RAW (val), VALUE_CONTENTS (fromval),
1670 TYPE_LENGTH (type));
1671 VALUE_TYPE (val) = type;
1676 return value_assign (toval, fromval);
1680 /* The value of the element of array ARR at the ARITY indices given in IND.
1681 ARR may be either a simple array, GNAT array descriptor, or pointer
1685 ada_value_subscript (arr, arity, ind)
1692 struct type* elt_type;
1694 elt = ada_coerce_to_simple_array (arr);
1696 elt_type = check_typedef (VALUE_TYPE (elt));
1697 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
1698 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
1699 return value_subscript_packed (elt, arity, ind);
1701 for (k = 0; k < arity; k += 1)
1703 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
1704 error("too many subscripts (%d expected)", k);
1705 elt = value_subscript (elt, value_pos_atr (ind[k]));
1710 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
1711 value of the element of *ARR at the ARITY indices given in
1712 IND. Does not read the entire array into memory. */
1715 ada_value_ptr_subscript (arr, type, arity, ind)
1723 for (k = 0; k < arity; k += 1)
1728 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1729 error("too many subscripts (%d expected)", k);
1730 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
1732 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
1736 idx = value_sub (ind[k], value_from_longest (builtin_type_int, lwb));
1737 arr = value_add (arr, idx);
1738 type = TYPE_TARGET_TYPE (type);
1741 return value_ind (arr);
1744 /* If type is a record type in the form of a standard GNAT array
1745 descriptor, returns the number of dimensions for type. If arr is a
1746 simple array, returns the number of "array of"s that prefix its
1747 type designation. Otherwise, returns 0. */
1750 ada_array_arity (type)
1758 type = desc_base_type (type);
1761 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1762 return desc_arity (desc_bounds_type (type));
1764 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
1767 type = check_typedef (TYPE_TARGET_TYPE (type));
1773 /* If TYPE is a record type in the form of a standard GNAT array
1774 descriptor or a simple array type, returns the element type for
1775 TYPE after indexing by NINDICES indices, or by all indices if
1776 NINDICES is -1. Otherwise, returns NULL. */
1779 ada_array_element_type (type, nindices)
1783 type = desc_base_type (type);
1785 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1788 struct type* p_array_type;
1790 p_array_type = desc_data_type (type);
1792 k = ada_array_arity (type);
1796 /* Initially p_array_type = elt_type(*)[]...(k times)...[] */
1797 if (nindices >= 0 && k > nindices)
1799 p_array_type = TYPE_TARGET_TYPE (p_array_type);
1800 while (k > 0 && p_array_type != NULL)
1802 p_array_type = check_typedef (TYPE_TARGET_TYPE (p_array_type));
1805 return p_array_type;
1807 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
1809 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
1811 type = TYPE_TARGET_TYPE (type);
1820 /* The type of nth index in arrays of given type (n numbering from 1). Does
1821 not examine memory. */
1824 ada_index_type (type, n)
1828 type = desc_base_type (type);
1830 if (n > ada_array_arity (type))
1833 if (ada_is_simple_array (type))
1837 for (i = 1; i < n; i += 1)
1838 type = TYPE_TARGET_TYPE (type);
1840 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 0));
1843 return desc_index_type (desc_bounds_type (type), n);
1846 /* Given that arr is an array type, returns the lower bound of the
1847 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
1848 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1849 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
1850 bounds type. It works for other arrays with bounds supplied by
1851 run-time quantities other than discriminants. */
1854 ada_array_bound_from_type (arr_type, n, which, typep)
1855 struct type* arr_type;
1858 struct type** typep;
1861 struct type* index_type_desc;
1863 if (ada_is_packed_array_type (arr_type))
1864 arr_type = decode_packed_array_type (arr_type);
1866 if (arr_type == NULL || ! ada_is_simple_array (arr_type))
1869 *typep = builtin_type_int;
1870 return (LONGEST) -which;
1873 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
1874 type = TYPE_TARGET_TYPE (arr_type);
1878 index_type_desc = ada_find_parallel_type (type, "___XA");
1879 if (index_type_desc == NULL)
1881 struct type* range_type;
1882 struct type* index_type;
1886 type = TYPE_TARGET_TYPE (type);
1890 range_type = TYPE_INDEX_TYPE (type);
1891 index_type = TYPE_TARGET_TYPE (range_type);
1892 if (TYPE_CODE (index_type) == TYPE_CODE_UNDEF)
1893 index_type = builtin_type_long;
1895 *typep = index_type;
1897 (LONGEST) (which == 0
1898 ? TYPE_LOW_BOUND (range_type)
1899 : TYPE_HIGH_BOUND (range_type));
1903 struct type* index_type =
1904 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n-1),
1905 NULL, TYPE_OBJFILE (arr_type));
1907 *typep = TYPE_TARGET_TYPE (index_type);
1909 (LONGEST) (which == 0
1910 ? TYPE_LOW_BOUND (index_type)
1911 : TYPE_HIGH_BOUND (index_type));
1915 /* Given that arr is an array value, returns the lower bound of the
1916 nth index (numbering from 1) if which is 0, and the upper bound if
1917 which is 1. This routine will also work for arrays with bounds
1918 supplied by run-time quantities other than discriminants. */
1921 ada_array_bound (arr, n, which)
1926 struct type* arr_type = VALUE_TYPE (arr);
1928 if (ada_is_packed_array_type (arr_type))
1929 return ada_array_bound (decode_packed_array (arr), n, which);
1930 else if (ada_is_simple_array (arr_type))
1933 LONGEST v = ada_array_bound_from_type (arr_type, n, which, &type);
1934 return value_from_longest (type, v);
1937 return desc_one_bound (desc_bounds (arr), n, which);
1940 /* Given that arr is an array value, returns the length of the
1941 nth index. This routine will also work for arrays with bounds
1942 supplied by run-time quantities other than discriminants. Does not
1943 work for arrays indexed by enumeration types with representation
1944 clauses at the moment. */
1947 ada_array_length (arr, n)
1951 struct type* arr_type = check_typedef (VALUE_TYPE (arr));
1952 struct type* index_type_desc;
1954 if (ada_is_packed_array_type (arr_type))
1955 return ada_array_length (decode_packed_array (arr), n);
1957 if (ada_is_simple_array (arr_type))
1961 ada_array_bound_from_type (arr_type, n, 1, &type) -
1962 ada_array_bound_from_type (arr_type, n, 0, NULL) + 1;
1963 return value_from_longest (type, v);
1967 value_from_longest (builtin_type_ada_int,
1968 value_as_long (desc_one_bound (desc_bounds (arr),
1970 - value_as_long (desc_one_bound (desc_bounds (arr),
1976 /* Name resolution */
1978 /* The "demangled" name for the user-definable Ada operator corresponding
1987 for (i = 0; ada_opname_table[i].mangled != NULL; i += 1)
1989 if (ada_opname_table[i].op == op)
1990 return ada_opname_table[i].demangled;
1992 error ("Could not find operator name for opcode");
1996 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
1997 references (OP_UNRESOLVED_VALUES) and converts operators that are
1998 user-defined into appropriate function calls. If CONTEXT_TYPE is
1999 non-null, it provides a preferred result type [at the moment, only
2000 type void has any effect---causing procedures to be preferred over
2001 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2002 return type is preferred. The variable unresolved_names contains a list
2003 of character strings referenced by expout that should be freed.
2004 May change (expand) *EXP. */
2007 ada_resolve (expp, context_type)
2008 struct expression** expp;
2009 struct type* context_type;
2013 ada_resolve_subexp (expp, &pc, 1, context_type);
2016 /* Resolve the operator of the subexpression beginning at
2017 position *POS of *EXPP. "Resolving" consists of replacing
2018 OP_UNRESOLVED_VALUE with an appropriate OP_VAR_VALUE, replacing
2019 built-in operators with function calls to user-defined operators,
2020 where appropriate, and (when DEPROCEDURE_P is non-zero), converting
2021 function-valued variables into parameterless calls. May expand
2022 EXP. The CONTEXT_TYPE functions as in ada_resolve, above. */
2024 static struct value*
2025 ada_resolve_subexp (expp, pos, deprocedure_p, context_type)
2026 struct expression** expp;
2029 struct type* context_type;
2033 struct expression* exp; /* Convenience: == *expp */
2034 enum exp_opcode op = (*expp)->elts[pc].opcode;
2035 struct value** argvec; /* Vector of operand types (alloca'ed). */
2036 int nargs; /* Number of operands */
2042 /* Pass one: resolve operands, saving their types and updating *pos. */
2046 /* case OP_UNRESOLVED_VALUE:*/
2047 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2052 nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
2053 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2054 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
2058 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
2059 for (i = 0; i < nargs-1; i += 1)
2060 argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
2066 ada_resolve_subexp (expp, pos, 0, NULL);
2067 for (i = 1; i < nargs; i += 1)
2068 ada_resolve_subexp (expp, pos, 1, NULL);
2074 /* FIXME: UNOP_QUAL should be defined in expression.h */
2078 ada_resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2082 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
2083 /* case OP_ATTRIBUTE:
2084 nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
2086 for (i = 0; i < nargs; i += 1)
2087 ada_resolve_subexp (expp, pos, 1, NULL);
2094 ada_resolve_subexp (expp, pos, 0, NULL);
2103 arg1 = ada_resolve_subexp (expp, pos, 0, NULL);
2105 ada_resolve_subexp (expp, pos, 1, NULL);
2107 ada_resolve_subexp (expp, pos, 1, VALUE_TYPE (arg1));
2115 error ("Unexpected operator during name resolution");
2130 case BINOP_LOGICAL_AND:
2131 case BINOP_LOGICAL_OR:
2132 case BINOP_BITWISE_AND:
2133 case BINOP_BITWISE_IOR:
2134 case BINOP_BITWISE_XOR:
2137 case BINOP_NOTEQUAL:
2144 case BINOP_SUBSCRIPT:
2152 case UNOP_LOGICAL_NOT:
2169 case OP_INTERNALVAR:
2178 case STRUCTOP_STRUCT:
2181 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2186 nargs = longest_to_int (exp->elts[pc + 2].longconst) + 1;
2187 nargs -= longest_to_int (exp->elts[pc + 1].longconst);
2188 /* A null array contains one dummy element to give the type. */
2194 /* FIXME: TERNOP_MBR should be defined in expression.h */
2200 /* FIXME: BINOP_MBR should be defined in expression.h */
2207 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
2208 for (i = 0; i < nargs; i += 1)
2209 argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
2215 /* Pass two: perform any resolution on principal operator. */
2221 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2222 /* case OP_UNRESOLVED_VALUE:
2224 struct symbol** candidate_syms;
2225 struct block** candidate_blocks;
2228 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 2].name,
2229 exp->elts[pc + 1].block,
2234 if (n_candidates > 1)
2236 /* Types tend to get re-introduced locally, so if there
2237 are any local symbols that are not types, first filter
2240 for (j = 0; j < n_candidates; j += 1)
2241 switch (SYMBOL_CLASS (candidate_syms[j]))
2247 case LOC_REGPARM_ADDR:
2251 case LOC_BASEREG_ARG:
2257 if (j < n_candidates)
2260 while (j < n_candidates)
2262 if (SYMBOL_CLASS (candidate_syms[j]) == LOC_TYPEDEF)
2264 candidate_syms[j] = candidate_syms[n_candidates-1];
2265 candidate_blocks[j] = candidate_blocks[n_candidates-1];
2274 if (n_candidates == 0)
2275 error ("No definition found for %s",
2276 ada_demangle (exp->elts[pc + 2].name));
2277 else if (n_candidates == 1)
2279 else if (deprocedure_p
2280 && ! is_nonfunction (candidate_syms, n_candidates))
2282 i = ada_resolve_function (candidate_syms, candidate_blocks,
2283 n_candidates, NULL, 0,
2284 exp->elts[pc + 2].name, context_type);
2286 error ("Could not find a match for %s",
2287 ada_demangle (exp->elts[pc + 2].name));
2291 printf_filtered ("Multiple matches for %s\n",
2292 ada_demangle (exp->elts[pc+2].name));
2293 user_select_syms (candidate_syms, candidate_blocks,
2298 exp->elts[pc].opcode = exp->elts[pc + 3].opcode = OP_VAR_VALUE;
2299 exp->elts[pc + 1].block = candidate_blocks[i];
2300 exp->elts[pc + 2].symbol = candidate_syms[i];
2301 if (innermost_block == NULL ||
2302 contained_in (candidate_blocks[i], innermost_block))
2303 innermost_block = candidate_blocks[i];
2308 if (deprocedure_p &&
2309 TYPE_CODE (SYMBOL_TYPE (exp->elts[pc+2].symbol)) == TYPE_CODE_FUNC)
2311 replace_operator_with_call (expp, pc, 0, 0,
2312 exp->elts[pc+2].symbol,
2313 exp->elts[pc+1].block);
2320 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2321 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
2323 struct symbol** candidate_syms;
2324 struct block** candidate_blocks;
2327 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 5].name,
2328 exp->elts[pc + 4].block,
2332 if (n_candidates == 1)
2336 i = ada_resolve_function (candidate_syms, candidate_blocks,
2337 n_candidates, argvec, nargs-1,
2338 exp->elts[pc + 5].name, context_type);
2340 error ("Could not find a match for %s",
2341 ada_demangle (exp->elts[pc + 5].name));
2344 exp->elts[pc + 3].opcode = exp->elts[pc + 6].opcode = OP_VAR_VALUE;
2345 exp->elts[pc + 4].block = candidate_blocks[i];
2346 exp->elts[pc + 5].symbol = candidate_syms[i];
2347 if (innermost_block == NULL ||
2348 contained_in (candidate_blocks[i], innermost_block))
2349 innermost_block = candidate_blocks[i];
2361 case BINOP_BITWISE_AND:
2362 case BINOP_BITWISE_IOR:
2363 case BINOP_BITWISE_XOR:
2365 case BINOP_NOTEQUAL:
2373 case UNOP_LOGICAL_NOT:
2375 if (possible_user_operator_p (op, argvec))
2377 struct symbol** candidate_syms;
2378 struct block** candidate_blocks;
2381 n_candidates = ada_lookup_symbol_list (ada_mangle (ada_op_name (op)),
2382 (struct block*) NULL,
2386 i = ada_resolve_function (candidate_syms, candidate_blocks,
2387 n_candidates, argvec, nargs,
2388 ada_op_name (op), NULL);
2392 replace_operator_with_call (expp, pc, nargs, 1,
2393 candidate_syms[i], candidate_blocks[i]);
2400 return evaluate_subexp_type (exp, pos);
2403 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2404 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2406 /* The term "match" here is rather loose. The match is heuristic and
2407 liberal. FIXME: TOO liberal, in fact. */
2410 ada_type_match (ftype, atype, may_deref)
2415 CHECK_TYPEDEF (ftype);
2416 CHECK_TYPEDEF (atype);
2418 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
2419 ftype = TYPE_TARGET_TYPE (ftype);
2420 if (TYPE_CODE (atype) == TYPE_CODE_REF)
2421 atype = TYPE_TARGET_TYPE (atype);
2423 if (TYPE_CODE (ftype) == TYPE_CODE_VOID
2424 || TYPE_CODE (atype) == TYPE_CODE_VOID)
2427 switch (TYPE_CODE (ftype))
2432 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
2433 return ada_type_match (TYPE_TARGET_TYPE (ftype),
2434 TYPE_TARGET_TYPE (atype), 0);
2435 else return (may_deref &&
2436 ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
2438 case TYPE_CODE_ENUM:
2439 case TYPE_CODE_RANGE:
2440 switch (TYPE_CODE (atype))
2443 case TYPE_CODE_ENUM:
2444 case TYPE_CODE_RANGE:
2450 case TYPE_CODE_ARRAY:
2451 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
2452 || ada_is_array_descriptor (atype));
2454 case TYPE_CODE_STRUCT:
2455 if (ada_is_array_descriptor (ftype))
2456 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
2457 || ada_is_array_descriptor (atype));
2459 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
2460 && ! ada_is_array_descriptor (atype));
2462 case TYPE_CODE_UNION:
2464 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
2468 /* Return non-zero if the formals of FUNC "sufficiently match" the
2469 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2470 may also be an enumeral, in which case it is treated as a 0-
2471 argument function. */
2474 ada_args_match (func, actuals, n_actuals)
2475 struct symbol* func;
2476 struct value** actuals;
2480 struct type* func_type = SYMBOL_TYPE (func);
2482 if (SYMBOL_CLASS (func) == LOC_CONST &&
2483 TYPE_CODE (func_type) == TYPE_CODE_ENUM)
2484 return (n_actuals == 0);
2485 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
2488 if (TYPE_NFIELDS (func_type) != n_actuals)
2491 for (i = 0; i < n_actuals; i += 1)
2493 struct type* ftype = check_typedef (TYPE_FIELD_TYPE (func_type, i));
2494 struct type* atype = check_typedef (VALUE_TYPE (actuals[i]));
2496 if (! ada_type_match (TYPE_FIELD_TYPE (func_type, i),
2497 VALUE_TYPE (actuals[i]), 1))
2503 /* False iff function type FUNC_TYPE definitely does not produce a value
2504 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2505 FUNC_TYPE is not a valid function type with a non-null return type
2506 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2509 return_match (func_type, context_type)
2510 struct type* func_type;
2511 struct type* context_type;
2513 struct type* return_type;
2515 if (func_type == NULL)
2518 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2519 /* if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
2520 return_type = base_type (TYPE_TARGET_TYPE (func_type));
2522 return_type = base_type (func_type);*/
2523 if (return_type == NULL)
2526 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2527 /* context_type = base_type (context_type);*/
2529 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
2530 return context_type == NULL || return_type == context_type;
2531 else if (context_type == NULL)
2532 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
2534 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
2538 /* Return the index in SYMS[0..NSYMS-1] of symbol for the
2539 function (if any) that matches the types of the NARGS arguments in
2540 ARGS. If CONTEXT_TYPE is non-null, and there is at least one match
2541 that returns type CONTEXT_TYPE, then eliminate other matches. If
2542 CONTEXT_TYPE is null, prefer a non-void-returning function.
2543 Asks the user if there is more than one match remaining. Returns -1
2544 if there is no such symbol or none is selected. NAME is used
2545 solely for messages. May re-arrange and modify SYMS in
2546 the process; the index returned is for the modified vector. BLOCKS
2547 is modified in parallel to SYMS. */
2550 ada_resolve_function (syms, blocks, nsyms, args, nargs, name, context_type)
2551 struct symbol* syms[];
2552 struct block* blocks[];
2553 struct value** args;
2556 struct type* context_type;
2559 int m; /* Number of hits */
2560 struct type* fallback;
2561 struct type* return_type;
2563 return_type = context_type;
2564 if (context_type == NULL)
2565 fallback = builtin_type_void;
2572 for (k = 0; k < nsyms; k += 1)
2574 struct type* type = check_typedef (SYMBOL_TYPE (syms[k]));
2576 if (ada_args_match (syms[k], args, nargs)
2577 && return_match (SYMBOL_TYPE (syms[k]), return_type))
2581 blocks[m] = blocks[k];
2585 if (m > 0 || return_type == fallback)
2588 return_type = fallback;
2595 printf_filtered ("Multiple matches for %s\n", name);
2596 user_select_syms (syms, blocks, m, 1);
2602 /* Returns true (non-zero) iff demangled name N0 should appear before N1 */
2603 /* in a listing of choices during disambiguation (see sort_choices, below). */
2604 /* The idea is that overloadings of a subprogram name from the */
2605 /* same package should sort in their source order. We settle for ordering */
2606 /* such symbols by their trailing number (__N or $N). */
2608 mangled_ordered_before (char* N0, char* N1)
2612 else if (N0 == NULL)
2617 for (k0 = strlen (N0)-1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
2619 for (k1 = strlen (N1)-1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
2621 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0+1] != '\000'
2622 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1+1] != '\000')
2626 while (N0[n0] == '_' && n0 > 0 && N0[n0-1] == '_')
2629 while (N1[n1] == '_' && n1 > 0 && N1[n1-1] == '_')
2631 if (n0 == n1 && STREQN (N0, N1, n0))
2632 return (atoi (N0+k0+1) < atoi (N1+k1+1));
2634 return (strcmp (N0, N1) < 0);
2638 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by their */
2639 /* mangled names, rearranging BLOCKS[0..NSYMS-1] according to the same */
2642 sort_choices (syms, blocks, nsyms)
2643 struct symbol* syms[];
2644 struct block* blocks[];
2648 for (i = 1; i < nsyms; i += 1)
2650 struct symbol* sym = syms[i];
2651 struct block* block = blocks[i];
2654 for (j = i-1; j >= 0; j -= 1)
2656 if (mangled_ordered_before (SYMBOL_NAME (syms[j]),
2659 syms[j+1] = syms[j];
2660 blocks[j+1] = blocks[j];
2663 blocks[j+1] = block;
2667 /* Given a list of NSYMS symbols in SYMS and corresponding blocks in */
2668 /* BLOCKS, select up to MAX_RESULTS>0 by asking the user (if */
2669 /* necessary), returning the number selected, and setting the first */
2670 /* elements of SYMS and BLOCKS to the selected symbols and */
2671 /* corresponding blocks. Error if no symbols selected. BLOCKS may */
2672 /* be NULL, in which case it is ignored. */
2674 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
2675 to be re-integrated one of these days. */
2678 user_select_syms (syms, blocks, nsyms, max_results)
2679 struct symbol* syms[];
2680 struct block* blocks[];
2685 int* chosen = (int*) alloca (sizeof(int) * nsyms);
2687 int first_choice = (max_results == 1) ? 1 : 2;
2689 if (max_results < 1)
2690 error ("Request to select 0 symbols!");
2694 printf_unfiltered("[0] cancel\n");
2695 if (max_results > 1)
2696 printf_unfiltered("[1] all\n");
2698 sort_choices (syms, blocks, nsyms);
2700 for (i = 0; i < nsyms; i += 1)
2702 if (syms[i] == NULL)
2705 if (SYMBOL_CLASS (syms[i]) == LOC_BLOCK)
2707 struct symtab_and_line sal = find_function_start_sal (syms[i], 1);
2708 printf_unfiltered ("[%d] %s at %s:%d\n",
2710 SYMBOL_SOURCE_NAME (syms[i]),
2712 ? "<no source file available>"
2713 : sal.symtab->filename,
2720 (SYMBOL_CLASS (syms[i]) == LOC_CONST
2721 && SYMBOL_TYPE (syms[i]) != NULL
2722 && TYPE_CODE (SYMBOL_TYPE (syms[i]))
2724 struct symtab* symtab = symtab_for_sym (syms[i]);
2726 if (SYMBOL_LINE (syms[i]) != 0 && symtab != NULL)
2727 printf_unfiltered ("[%d] %s at %s:%d\n",
2729 SYMBOL_SOURCE_NAME (syms[i]),
2730 symtab->filename, SYMBOL_LINE (syms[i]));
2731 else if (is_enumeral &&
2732 TYPE_NAME (SYMBOL_TYPE (syms[i])) != NULL)
2734 printf_unfiltered ("[%d] ", i + first_choice);
2735 ada_print_type (SYMBOL_TYPE (syms[i]), NULL, gdb_stdout, -1, 0);
2736 printf_unfiltered ("'(%s) (enumeral)\n",
2737 SYMBOL_SOURCE_NAME (syms[i]));
2739 else if (symtab != NULL)
2740 printf_unfiltered (is_enumeral
2741 ? "[%d] %s in %s (enumeral)\n"
2742 : "[%d] %s at %s:?\n",
2744 SYMBOL_SOURCE_NAME (syms[i]),
2747 printf_unfiltered (is_enumeral
2748 ? "[%d] %s (enumeral)\n"
2750 i + first_choice, SYMBOL_SOURCE_NAME (syms[i]));
2754 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
2757 for (i = 0; i < n_chosen; i += 1)
2759 syms[i] = syms[chosen[i]];
2761 blocks[i] = blocks[chosen[i]];
2767 /* Read and validate a set of numeric choices from the user in the
2768 range 0 .. N_CHOICES-1. Place the results in increasing
2769 order in CHOICES[0 .. N-1], and return N.
2771 The user types choices as a sequence of numbers on one line
2772 separated by blanks, encoding them as follows:
2774 + A choice of 0 means to cancel the selection, throwing an error.
2775 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
2776 + The user chooses k by typing k+IS_ALL_CHOICE+1.
2778 The user is not allowed to choose more than MAX_RESULTS values.
2780 ANNOTATION_SUFFIX, if present, is used to annotate the input
2781 prompts (for use with the -f switch). */
2784 get_selections (choices, n_choices, max_results, is_all_choice,
2790 char* annotation_suffix;
2796 int first_choice = is_all_choice ? 2 : 1;
2798 prompt = getenv ("PS2");
2802 printf_unfiltered ("%s ", prompt);
2803 gdb_flush (gdb_stdout);
2805 args = command_line_input ((char *) NULL, 0, annotation_suffix);
2808 error_no_arg ("one or more choice numbers");
2812 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
2813 order, as given in args. Choices are validated. */
2819 while (isspace (*args))
2821 if (*args == '\0' && n_chosen == 0)
2822 error_no_arg ("one or more choice numbers");
2823 else if (*args == '\0')
2826 choice = strtol (args, &args2, 10);
2827 if (args == args2 || choice < 0 || choice > n_choices + first_choice - 1)
2828 error ("Argument must be choice number");
2832 error ("cancelled");
2834 if (choice < first_choice)
2836 n_chosen = n_choices;
2837 for (j = 0; j < n_choices; j += 1)
2841 choice -= first_choice;
2843 for (j = n_chosen-1; j >= 0 && choice < choices[j]; j -= 1)
2846 if (j < 0 || choice != choices[j])
2849 for (k = n_chosen-1; k > j; k -= 1)
2850 choices[k+1] = choices[k];
2851 choices[j+1] = choice;
2856 if (n_chosen > max_results)
2857 error ("Select no more than %d of the above", max_results);
2862 /* Replace the operator of length OPLEN at position PC in *EXPP with a call */
2863 /* on the function identified by SYM and BLOCK, and taking NARGS */
2864 /* arguments. Update *EXPP as needed to hold more space. */
2867 replace_operator_with_call (expp, pc, nargs, oplen, sym, block)
2868 struct expression** expp;
2869 int pc, nargs, oplen;
2871 struct block* block;
2873 /* A new expression, with 6 more elements (3 for funcall, 4 for function
2874 symbol, -oplen for operator being replaced). */
2875 struct expression* newexp = (struct expression*)
2876 xmalloc (sizeof (struct expression)
2877 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
2878 struct expression* exp = *expp;
2880 newexp->nelts = exp->nelts + 7 - oplen;
2881 newexp->language_defn = exp->language_defn;
2882 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
2883 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
2884 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
2886 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
2887 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
2889 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
2890 newexp->elts[pc + 4].block = block;
2891 newexp->elts[pc + 5].symbol = sym;
2897 /* Type-class predicates */
2899 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), or */
2903 numeric_type_p (type)
2909 switch (TYPE_CODE (type))
2914 case TYPE_CODE_RANGE:
2915 return (type == TYPE_TARGET_TYPE (type)
2916 || numeric_type_p (TYPE_TARGET_TYPE (type)));
2923 /* True iff TYPE is integral (an INT or RANGE of INTs). */
2926 integer_type_p (type)
2932 switch (TYPE_CODE (type))
2936 case TYPE_CODE_RANGE:
2937 return (type == TYPE_TARGET_TYPE (type)
2938 || integer_type_p (TYPE_TARGET_TYPE (type)));
2945 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
2948 scalar_type_p (type)
2954 switch (TYPE_CODE (type))
2957 case TYPE_CODE_RANGE:
2958 case TYPE_CODE_ENUM:
2967 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
2970 discrete_type_p (type)
2976 switch (TYPE_CODE (type))
2979 case TYPE_CODE_RANGE:
2980 case TYPE_CODE_ENUM:
2988 /* Returns non-zero if OP with operatands in the vector ARGS could be
2989 a user-defined function. Errs on the side of pre-defined operators
2990 (i.e., result 0). */
2993 possible_user_operator_p (op, args)
2995 struct value* args[];
2997 struct type* type0 = check_typedef (VALUE_TYPE (args[0]));
2998 struct type* type1 =
2999 (args[1] == NULL) ? NULL : check_typedef (VALUE_TYPE (args[1]));
3010 return (! (numeric_type_p (type0) && numeric_type_p (type1)));
3014 case BINOP_BITWISE_AND:
3015 case BINOP_BITWISE_IOR:
3016 case BINOP_BITWISE_XOR:
3017 return (! (integer_type_p (type0) && integer_type_p (type1)));
3020 case BINOP_NOTEQUAL:
3025 return (! (scalar_type_p (type0) && scalar_type_p (type1)));
3028 return ((TYPE_CODE (type0) != TYPE_CODE_ARRAY &&
3029 (TYPE_CODE (type0) != TYPE_CODE_PTR ||
3030 TYPE_CODE (TYPE_TARGET_TYPE (type0))
3031 != TYPE_CODE_ARRAY))
3032 || (TYPE_CODE (type1) != TYPE_CODE_ARRAY &&
3033 (TYPE_CODE (type1) != TYPE_CODE_PTR ||
3034 TYPE_CODE (TYPE_TARGET_TYPE (type1))
3035 != TYPE_CODE_ARRAY)));
3038 return (! (numeric_type_p (type0) && integer_type_p (type1)));
3042 case UNOP_LOGICAL_NOT:
3044 return (! numeric_type_p (type0));
3051 /** NOTE: In the following, we assume that a renaming type's name may
3052 * have an ___XD suffix. It would be nice if this went away at some
3055 /* If TYPE encodes a renaming, returns the renaming suffix, which
3056 * is XR for an object renaming, XRP for a procedure renaming, XRE for
3057 * an exception renaming, and XRS for a subprogram renaming. Returns
3058 * NULL if NAME encodes none of these. */
3060 ada_renaming_type (type)
3063 if (type != NULL && TYPE_CODE (type) == TYPE_CODE_ENUM)
3065 const char* name = type_name_no_tag (type);
3066 const char* suffix = (name == NULL) ? NULL : strstr (name, "___XR");
3068 || (suffix[5] != '\000' && strchr ("PES_", suffix[5]) == NULL))
3077 /* Return non-zero iff SYM encodes an object renaming. */
3079 ada_is_object_renaming (sym)
3082 const char* renaming_type = ada_renaming_type (SYMBOL_TYPE (sym));
3083 return renaming_type != NULL
3084 && (renaming_type[2] == '\0' || renaming_type[2] == '_');
3087 /* Assuming that SYM encodes a non-object renaming, returns the original
3088 * name of the renamed entity. The name is good until the end of
3091 ada_simple_renamed_entity (sym)
3095 const char* raw_name;
3099 type = SYMBOL_TYPE (sym);
3100 if (type == NULL || TYPE_NFIELDS (type) < 1)
3101 error ("Improperly encoded renaming.");
3103 raw_name = TYPE_FIELD_NAME (type, 0);
3104 len = (raw_name == NULL ? 0 : strlen (raw_name)) - 5;
3106 error ("Improperly encoded renaming.");
3108 result = xmalloc (len + 1);
3109 /* FIXME: add_name_string_cleanup should be defined in parse.c */
3110 /* add_name_string_cleanup (result);*/
3111 strncpy (result, raw_name, len);
3112 result[len] = '\000';
3117 /* Evaluation: Function Calls */
3119 /* Copy VAL onto the stack, using and updating *SP as the stack
3120 pointer. Return VAL as an lvalue. */
3122 static struct value*
3123 place_on_stack (val, sp)
3127 CORE_ADDR old_sp = *sp;
3130 *sp = push_bytes (*sp, VALUE_CONTENTS_RAW (val),
3131 STACK_ALIGN (TYPE_LENGTH (check_typedef (VALUE_TYPE (val)))));
3133 *sp = push_bytes (*sp, VALUE_CONTENTS_RAW (val),
3134 TYPE_LENGTH (check_typedef (VALUE_TYPE (val))));
3137 VALUE_LVAL (val) = lval_memory;
3138 if (INNER_THAN (1, 2))
3139 VALUE_ADDRESS (val) = *sp;
3141 VALUE_ADDRESS (val) = old_sp;
3146 /* Return the value ACTUAL, converted to be an appropriate value for a
3147 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3148 allocating any necessary descriptors (fat pointers), or copies of
3149 values not residing in memory, updating it as needed. */
3151 static struct value*
3152 convert_actual (actual, formal_type0, sp)
3153 struct value* actual;
3154 struct type* formal_type0;
3157 struct type* actual_type = check_typedef (VALUE_TYPE (actual));
3158 struct type* formal_type = check_typedef (formal_type0);
3159 struct type* formal_target =
3160 TYPE_CODE (formal_type) == TYPE_CODE_PTR
3161 ? check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
3162 struct type* actual_target =
3163 TYPE_CODE (actual_type) == TYPE_CODE_PTR
3164 ? check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
3166 if (ada_is_array_descriptor (formal_target)
3167 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
3168 return make_array_descriptor (formal_type, actual, sp);
3169 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR)
3171 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
3172 && ada_is_array_descriptor (actual_target))
3173 return desc_data (actual);
3174 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
3176 if (VALUE_LVAL (actual) != lval_memory)
3179 actual_type = check_typedef (VALUE_TYPE (actual));
3180 val = allocate_value (actual_type);
3181 memcpy ((char*) VALUE_CONTENTS_RAW (val),
3182 (char*) VALUE_CONTENTS (actual),
3183 TYPE_LENGTH (actual_type));
3184 actual = place_on_stack (val, sp);
3186 return value_addr (actual);
3189 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
3190 return ada_value_ind (actual);
3196 /* Push a descriptor of type TYPE for array value ARR on the stack at
3197 *SP, updating *SP to reflect the new descriptor. Return either
3198 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3199 to-descriptor type rather than a descriptor type), a struct value*
3200 representing a pointer to this descriptor. */
3202 static struct value*
3203 make_array_descriptor (type, arr, sp)
3208 struct type* bounds_type = desc_bounds_type (type);
3209 struct type* desc_type = desc_base_type (type);
3210 struct value* descriptor = allocate_value (desc_type);
3211 struct value* bounds = allocate_value (bounds_type);
3212 CORE_ADDR bounds_addr;
3215 for (i = ada_array_arity (check_typedef (VALUE_TYPE (arr))); i > 0; i -= 1)
3217 modify_general_field (VALUE_CONTENTS (bounds),
3218 value_as_long (ada_array_bound (arr, i, 0)),
3219 desc_bound_bitpos (bounds_type, i, 0),
3220 desc_bound_bitsize (bounds_type, i, 0));
3221 modify_general_field (VALUE_CONTENTS (bounds),
3222 value_as_long (ada_array_bound (arr, i, 1)),
3223 desc_bound_bitpos (bounds_type, i, 1),
3224 desc_bound_bitsize (bounds_type, i, 1));
3227 bounds = place_on_stack (bounds, sp);
3229 modify_general_field (VALUE_CONTENTS (descriptor),
3231 fat_pntr_data_bitpos (desc_type),
3232 fat_pntr_data_bitsize (desc_type));
3233 modify_general_field (VALUE_CONTENTS (descriptor),
3234 VALUE_ADDRESS (bounds),
3235 fat_pntr_bounds_bitpos (desc_type),
3236 fat_pntr_bounds_bitsize (desc_type));
3238 descriptor = place_on_stack (descriptor, sp);
3240 if (TYPE_CODE (type) == TYPE_CODE_PTR)
3241 return value_addr (descriptor);
3247 /* Assuming a dummy frame has been established on the target, perform any
3248 conversions needed for calling function FUNC on the NARGS actual
3249 parameters in ARGS, other than standard C conversions. Does
3250 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3251 does not match the number of arguments expected. Use *SP as a
3252 stack pointer for additional data that must be pushed, updating its
3256 ada_convert_actuals (func, nargs, args, sp)
3259 struct value* args[];
3264 if (TYPE_NFIELDS (VALUE_TYPE (func)) == 0
3265 || nargs != TYPE_NFIELDS (VALUE_TYPE (func)))
3268 for (i = 0; i < nargs; i += 1)
3270 convert_actual (args[i],
3271 TYPE_FIELD_TYPE (VALUE_TYPE (func), i),
3279 /* The vectors of symbols and blocks ultimately returned from */
3280 /* ada_lookup_symbol_list. */
3282 /* Current size of defn_symbols and defn_blocks */
3283 static size_t defn_vector_size = 0;
3285 /* Current number of symbols found. */
3286 static int ndefns = 0;
3288 static struct symbol** defn_symbols = NULL;
3289 static struct block** defn_blocks = NULL;
3291 /* Return the result of a standard (literal, C-like) lookup of NAME in
3292 * given NAMESPACE. */
3294 static struct symbol*
3295 standard_lookup (name, namespace)
3297 namespace_enum namespace;
3300 struct symtab* symtab;
3301 sym = lookup_symbol (name, (struct block*) NULL, namespace, 0, &symtab);
3306 /* Non-zero iff there is at least one non-function/non-enumeral symbol */
3307 /* in SYMS[0..N-1]. We treat enumerals as functions, since they */
3308 /* contend in overloading in the same way. */
3310 is_nonfunction (syms, n)
3311 struct symbol* syms[];
3316 for (i = 0; i < n; i += 1)
3317 if (TYPE_CODE (SYMBOL_TYPE (syms[i])) != TYPE_CODE_FUNC
3318 && TYPE_CODE (SYMBOL_TYPE (syms[i])) != TYPE_CODE_ENUM)
3324 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3325 struct types. Otherwise, they may not. */
3328 equiv_types (type0, type1)
3334 if (type0 == NULL || type1 == NULL
3335 || TYPE_CODE (type0) != TYPE_CODE (type1))
3337 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
3338 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
3339 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
3340 && STREQ (ada_type_name (type0), ada_type_name (type1)))
3346 /* True iff SYM0 represents the same entity as SYM1, or one that is
3347 no more defined than that of SYM1. */
3350 lesseq_defined_than (sym0, sym1)
3351 struct symbol* sym0;
3352 struct symbol* sym1;
3356 if (SYMBOL_NAMESPACE (sym0) != SYMBOL_NAMESPACE (sym1)
3357 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
3360 switch (SYMBOL_CLASS (sym0))
3366 struct type* type0 = SYMBOL_TYPE (sym0);
3367 struct type* type1 = SYMBOL_TYPE (sym1);
3368 char* name0 = SYMBOL_NAME (sym0);
3369 char* name1 = SYMBOL_NAME (sym1);
3370 int len0 = strlen (name0);
3372 TYPE_CODE (type0) == TYPE_CODE (type1)
3373 && (equiv_types (type0, type1)
3374 || (len0 < strlen (name1) && STREQN (name0, name1, len0)
3375 && STREQN (name1 + len0, "___XV", 5)));
3378 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
3379 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
3385 /* Append SYM to the end of defn_symbols, and BLOCK to the end of
3386 defn_blocks, updating ndefns, and expanding defn_symbols and
3387 defn_blocks as needed. Do not include SYM if it is a duplicate. */
3390 add_defn_to_vec (sym, block)
3392 struct block* block;
3397 if (SYMBOL_TYPE (sym) != NULL)
3398 CHECK_TYPEDEF (SYMBOL_TYPE (sym));
3399 for (i = 0; i < ndefns; i += 1)
3401 if (lesseq_defined_than (sym, defn_symbols[i]))
3403 else if (lesseq_defined_than (defn_symbols[i], sym))
3405 defn_symbols[i] = sym;
3406 defn_blocks[i] = block;
3411 tmp = defn_vector_size;
3412 GROW_VECT (defn_symbols, tmp, ndefns+2);
3413 GROW_VECT (defn_blocks, defn_vector_size, ndefns+2);
3415 defn_symbols[ndefns] = sym;
3416 defn_blocks[ndefns] = block;
3420 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3421 Check the global symbols if GLOBAL, the static symbols if not. Do
3422 wild-card match if WILD. */
3424 static struct partial_symbol *
3425 ada_lookup_partial_symbol (pst, name, global, namespace, wild)
3426 struct partial_symtab *pst;
3429 namespace_enum namespace;
3432 struct partial_symbol **start;
3433 int name_len = strlen (name);
3434 int length = (global ? pst->n_global_syms : pst->n_static_syms);
3443 pst->objfile->global_psymbols.list + pst->globals_offset :
3444 pst->objfile->static_psymbols.list + pst->statics_offset );
3448 for (i = 0; i < length; i += 1)
3450 struct partial_symbol* psym = start[i];
3452 if (SYMBOL_NAMESPACE (psym) == namespace &&
3453 wild_match (name, name_len, SYMBOL_NAME (psym)))
3463 i = 0; U = length-1;
3467 struct partial_symbol* psym = start[M];
3468 if (SYMBOL_NAME (psym)[0] < name[0])
3470 else if (SYMBOL_NAME (psym)[0] > name[0])
3472 else if (strcmp (SYMBOL_NAME (psym), name) < 0)
3483 struct partial_symbol *psym = start[i];
3485 if (SYMBOL_NAMESPACE (psym) == namespace)
3487 int cmp = strncmp (name, SYMBOL_NAME (psym), name_len);
3495 && is_name_suffix (SYMBOL_NAME (psym) + name_len))
3504 i = 0; U = length-1;
3508 struct partial_symbol *psym = start[M];
3509 if (SYMBOL_NAME (psym)[0] < '_')
3511 else if (SYMBOL_NAME (psym)[0] > '_')
3513 else if (strcmp (SYMBOL_NAME (psym), "_ada_") < 0)
3524 struct partial_symbol* psym = start[i];
3526 if (SYMBOL_NAMESPACE (psym) == namespace)
3530 cmp = (int) '_' - (int) SYMBOL_NAME (psym)[0];
3533 cmp = strncmp ("_ada_", SYMBOL_NAME (psym), 5);
3535 cmp = strncmp (name, SYMBOL_NAME (psym) + 5, name_len);
3544 && is_name_suffix (SYMBOL_NAME (psym) + name_len + 5))
3555 /* Find a symbol table containing symbol SYM or NULL if none. */
3556 static struct symtab*
3557 symtab_for_sym (sym)
3561 struct objfile *objfile;
3565 ALL_SYMTABS (objfile, s)
3567 switch (SYMBOL_CLASS (sym))
3575 case LOC_CONST_BYTES:
3576 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
3577 for (i = 0; i < BLOCK_NSYMS (b); i += 1)
3578 if (sym == BLOCK_SYM (b, i))
3580 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
3581 for (i = 0; i < BLOCK_NSYMS (b); i += 1)
3582 if (sym == BLOCK_SYM (b, i))
3588 switch (SYMBOL_CLASS (sym))
3594 case LOC_REGPARM_ADDR:
3599 case LOC_BASEREG_ARG:
3600 for (j = FIRST_LOCAL_BLOCK;
3601 j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s)); j += 1)
3603 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), j);
3604 for (i = 0; i < BLOCK_NSYMS (b); i += 1)
3605 if (sym == BLOCK_SYM (b, i))
3616 /* Return a minimal symbol matching NAME according to Ada demangling
3617 rules. Returns NULL if there is no such minimal symbol. */
3619 struct minimal_symbol*
3620 ada_lookup_minimal_symbol (name)
3623 struct objfile* objfile;
3624 struct minimal_symbol* msymbol;
3625 int wild_match = (strstr (name, "__") == NULL);
3627 ALL_MSYMBOLS (objfile, msymbol)
3629 if (ada_match_name (SYMBOL_NAME (msymbol), name, wild_match)
3630 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
3637 /* For all subprograms that statically enclose the subprogram of the
3638 * selected frame, add symbols matching identifier NAME in NAMESPACE
3639 * and their blocks to vectors *defn_symbols and *defn_blocks, as for
3640 * ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
3641 * wildcard prefix. At the moment, this function uses a heuristic to
3642 * find the frames of enclosing subprograms: it treats the
3643 * pointer-sized value at location 0 from the local-variable base of a
3644 * frame as a static link, and then searches up the call stack for a
3645 * frame with that same local-variable base. */
3647 add_symbols_from_enclosing_procs (name, namespace, wild_match)
3649 namespace_enum namespace;
3653 static struct symbol static_link_sym;
3654 static struct symbol *static_link;
3656 struct cleanup* old_chain = make_cleanup (null_cleanup, NULL);
3657 struct frame_info* frame;
3658 struct frame_info* target_frame;
3660 if (static_link == NULL)
3662 /* Initialize the local variable symbol that stands for the
3663 * static link (when it exists). */
3664 static_link = &static_link_sym;
3665 SYMBOL_NAME (static_link) = "";
3666 SYMBOL_LANGUAGE (static_link) = language_unknown;
3667 SYMBOL_CLASS (static_link) = LOC_LOCAL;
3668 SYMBOL_NAMESPACE (static_link) = VAR_NAMESPACE;
3669 SYMBOL_TYPE (static_link) = lookup_pointer_type (builtin_type_void);
3670 SYMBOL_VALUE (static_link) =
3671 - (long) TYPE_LENGTH (SYMBOL_TYPE (static_link));
3674 frame = selected_frame;
3675 while (frame != NULL && ndefns == 0)
3677 struct block* block;
3678 struct value* target_link_val = read_var_value (static_link, frame);
3679 CORE_ADDR target_link;
3681 if (target_link_val == NULL)
3685 target_link = target_link_val;
3688 frame = get_prev_frame (frame);
3689 } while (frame != NULL && FRAME_LOCALS_ADDRESS (frame) != target_link);
3694 block = get_frame_block (frame, 0);
3695 while (block != NULL && block_function (block) != NULL && ndefns == 0)
3697 ada_add_block_symbols (block, name, namespace, NULL, wild_match);
3699 block = BLOCK_SUPERBLOCK (block);
3703 do_cleanups (old_chain);
3707 /* True if TYPE is definitely an artificial type supplied to a symbol
3708 * for which no debugging information was given in the symbol file. */
3710 is_nondebugging_type (type)
3713 char* name = ada_type_name (type);
3714 return (name != NULL && STREQ (name, "<variable, no debug info>"));
3717 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
3718 * duplicate other symbols in the list. (The only case I know of where
3719 * this happens is when object files containing stabs-in-ecoff are
3720 * linked with files containing ordinary ecoff debugging symbols (or no
3721 * debugging symbols)). Modifies SYMS to squeeze out deleted symbols,
3722 * and applies the same modification to BLOCKS to maintain the
3723 * correspondence between SYMS[i] and BLOCKS[i]. Returns the number
3724 * of symbols in the modified list. */
3726 remove_extra_symbols (syms, blocks, nsyms)
3727 struct symbol** syms;
3728 struct block** blocks;
3736 if (SYMBOL_NAME (syms[i]) != NULL && SYMBOL_CLASS (syms[i]) == LOC_STATIC
3737 && is_nondebugging_type (SYMBOL_TYPE (syms[i])))
3739 for (j = 0; j < nsyms; j += 1)
3742 && SYMBOL_NAME (syms[j]) != NULL
3743 && STREQ (SYMBOL_NAME (syms[i]), SYMBOL_NAME (syms[j]))
3744 && SYMBOL_CLASS (syms[i]) == SYMBOL_CLASS (syms[j])
3745 && SYMBOL_VALUE_ADDRESS (syms[i])
3746 == SYMBOL_VALUE_ADDRESS (syms[j]))
3749 for (k = i+1; k < nsyms; k += 1)
3751 syms[k-1] = syms[k];
3752 blocks[k-1] = blocks[k];
3766 /* Find symbols in NAMESPACE matching NAME, in BLOCK0 and enclosing
3767 scope and in global scopes, returning the number of matches. Sets
3768 *SYMS to point to a vector of matching symbols, with *BLOCKS
3769 pointing to the vector of corresponding blocks in which those
3770 symbols reside. These two vectors are transient---good only to the
3771 next call of ada_lookup_symbol_list. Any non-function/non-enumeral symbol
3772 match within the nest of blocks whose innermost member is BLOCK0,
3773 is the outermost match returned (no other matches in that or
3774 enclosing blocks is returned). If there are any matches in or
3775 surrounding BLOCK0, then these alone are returned. */
3778 ada_lookup_symbol_list (name, block0, namespace, syms, blocks)
3780 struct block *block0;
3781 namespace_enum namespace;
3782 struct symbol*** syms;
3783 struct block*** blocks;
3787 struct partial_symtab *ps;
3788 struct blockvector *bv;
3789 struct objfile *objfile;
3791 struct block *block;
3792 struct minimal_symbol *msymbol;
3793 int wild_match = (strstr (name, "__") == NULL);
3803 /* Search specified block and its superiors. */
3806 while (block != NULL)
3808 ada_add_block_symbols (block, name, namespace, NULL, wild_match);
3810 /* If we found a non-function match, assume that's the one. */
3811 if (is_nonfunction (defn_symbols, ndefns))
3814 block = BLOCK_SUPERBLOCK (block);
3817 /* If we found ANY matches in the specified BLOCK, we're done. */
3824 /* Now add symbols from all global blocks: symbol tables, minimal symbol
3825 tables, and psymtab's */
3827 ALL_SYMTABS (objfile, s)
3832 bv = BLOCKVECTOR (s);
3833 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
3834 ada_add_block_symbols (block, name, namespace, objfile, wild_match);
3837 if (namespace == VAR_NAMESPACE)
3839 ALL_MSYMBOLS (objfile, msymbol)
3841 if (ada_match_name (SYMBOL_NAME (msymbol), name, wild_match))
3843 switch (MSYMBOL_TYPE (msymbol))
3845 case mst_solib_trampoline:
3848 s = find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol));
3851 int old_ndefns = ndefns;
3853 bv = BLOCKVECTOR (s);
3854 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
3855 ada_add_block_symbols (block,
3856 SYMBOL_NAME (msymbol),
3857 namespace, objfile, wild_match);
3858 if (ndefns == old_ndefns)
3860 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
3861 ada_add_block_symbols (block,
3862 SYMBOL_NAME (msymbol),
3872 ALL_PSYMTABS (objfile, ps)
3876 && ada_lookup_partial_symbol (ps, name, 1, namespace, wild_match))
3878 s = PSYMTAB_TO_SYMTAB (ps);
3881 bv = BLOCKVECTOR (s);
3882 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
3883 ada_add_block_symbols (block, name, namespace, objfile, wild_match);
3887 /* Now add symbols from all per-file blocks if we've gotten no hits.
3888 (Not strictly correct, but perhaps better than an error).
3889 Do the symtabs first, then check the psymtabs */
3894 ALL_SYMTABS (objfile, s)
3899 bv = BLOCKVECTOR (s);
3900 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
3901 ada_add_block_symbols (block, name, namespace, objfile, wild_match);
3904 ALL_PSYMTABS (objfile, ps)
3908 && ada_lookup_partial_symbol (ps, name, 0, namespace, wild_match))
3910 s = PSYMTAB_TO_SYMTAB(ps);
3911 bv = BLOCKVECTOR (s);
3914 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
3915 ada_add_block_symbols (block, name, namespace,
3916 objfile, wild_match);
3921 /* Finally, we try to find NAME as a local symbol in some lexically
3922 enclosing block. We do this last, expecting this case to be
3926 add_symbols_from_enclosing_procs (name, namespace, wild_match);
3932 ndefns = remove_extra_symbols (defn_symbols, defn_blocks, ndefns);
3935 *syms = defn_symbols;
3936 *blocks = defn_blocks;
3943 /* Return a symbol in NAMESPACE matching NAME, in BLOCK0 and enclosing
3944 * scope and in global scopes, or NULL if none. NAME is folded to
3945 * lower case first, unless it is surrounded in single quotes.
3946 * Otherwise, the result is as for ada_lookup_symbol_list, but is
3947 * disambiguated by user query if needed. */
3950 ada_lookup_symbol (name, block0, namespace)
3952 struct block *block0;
3953 namespace_enum namespace;
3955 struct symbol** candidate_syms;
3956 struct block** candidate_blocks;
3959 n_candidates = ada_lookup_symbol_list (name,
3961 &candidate_syms, &candidate_blocks);
3963 if (n_candidates == 0)
3965 else if (n_candidates != 1)
3966 user_select_syms (candidate_syms, candidate_blocks, n_candidates, 1);
3968 return candidate_syms[0];
3972 /* True iff STR is a possible encoded suffix of a normal Ada name
3973 * that is to be ignored for matching purposes. Suffixes of parallel
3974 * names (e.g., XVE) are not included here. Currently, the possible suffixes
3975 * are given by the regular expression:
3976 * (X[nb]*)?(__[0-9]+|\$[0-9]+|___(LJM|X([FDBUP].*|R[^T]?)))?$
3980 is_name_suffix (str)
3987 while (str[0] != '_' && str[0] != '\0')
3989 if (str[0] != 'n' && str[0] != 'b')
3994 if (str[0] == '\000')
3998 if (str[1] != '_' || str[2] == '\000')
4002 if (STREQ (str+3, "LJM"))
4006 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B' ||
4007 str[4] == 'U' || str[4] == 'P')
4009 if (str[4] == 'R' && str[5] != 'T')
4013 for (k = 2; str[k] != '\0'; k += 1)
4014 if (!isdigit (str[k]))
4018 if (str[0] == '$' && str[1] != '\000')
4020 for (k = 1; str[k] != '\0'; k += 1)
4021 if (!isdigit (str[k]))
4028 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4029 * PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4030 * informational suffixes of NAME (i.e., for which is_name_suffix is
4033 wild_match (patn, patn_len, name)
4041 name_len = strlen (name);
4042 if (name_len >= patn_len+5 && STREQN (name, "_ada_", 5)
4043 && STREQN (patn, name+5, patn_len)
4044 && is_name_suffix (name+patn_len+5))
4047 while (name_len >= patn_len)
4049 if (STREQN (patn, name, patn_len)
4050 && is_name_suffix (name+patn_len))
4053 name += 1; name_len -= 1;
4054 } while (name_len > 0
4055 && name[0] != '.' && (name[0] != '_' || name[1] != '_'));
4060 if (! islower (name[2]))
4062 name += 2; name_len -= 2;
4066 if (! islower (name[1]))
4068 name += 1; name_len -= 1;
4076 /* Add symbols from BLOCK matching identifier NAME in NAMESPACE to
4077 vector *defn_symbols, updating *defn_symbols (if necessary), *SZ (the size of
4078 the vector *defn_symbols), and *ndefns (the number of symbols
4079 currently stored in *defn_symbols). If WILD, treat as NAME with a
4080 wildcard prefix. OBJFILE is the section containing BLOCK. */
4083 ada_add_block_symbols (block, name, namespace, objfile, wild)
4084 struct block* block;
4086 namespace_enum namespace;
4087 struct objfile* objfile;
4091 int name_len = strlen (name);
4092 /* A matching argument symbol, if any. */
4093 struct symbol *arg_sym;
4094 /* Set true when we find a matching non-argument symbol */
4096 int is_sorted = BLOCK_SHOULD_SORT (block);
4098 arg_sym = NULL; found_sym = 0;
4101 for (i = 0; i < BLOCK_NSYMS (block); i += 1)
4103 struct symbol *sym = BLOCK_SYM (block, i);
4105 if (SYMBOL_NAMESPACE (sym) == namespace &&
4106 wild_match (name, name_len, SYMBOL_NAME (sym)))
4108 switch (SYMBOL_CLASS (sym))
4114 case LOC_REGPARM_ADDR:
4115 case LOC_BASEREG_ARG:
4118 case LOC_UNRESOLVED:
4122 fill_in_ada_prototype (sym);
4123 add_defn_to_vec (fixup_symbol_section (sym, objfile), block);
4134 i = 0; U = BLOCK_NSYMS (block)-1;
4138 struct symbol *sym = BLOCK_SYM (block, M);
4139 if (SYMBOL_NAME (sym)[0] < name[0])
4141 else if (SYMBOL_NAME (sym)[0] > name[0])
4143 else if (strcmp (SYMBOL_NAME (sym), name) < 0)
4152 for (; i < BLOCK_NSYMS (block); i += 1)
4154 struct symbol *sym = BLOCK_SYM (block, i);
4156 if (SYMBOL_NAMESPACE (sym) == namespace)
4158 int cmp = strncmp (name, SYMBOL_NAME (sym), name_len);
4166 && is_name_suffix (SYMBOL_NAME (sym) + name_len))
4168 switch (SYMBOL_CLASS (sym))
4174 case LOC_REGPARM_ADDR:
4175 case LOC_BASEREG_ARG:
4178 case LOC_UNRESOLVED:
4182 fill_in_ada_prototype (sym);
4183 add_defn_to_vec (fixup_symbol_section (sym, objfile),
4192 if (! found_sym && arg_sym != NULL)
4194 fill_in_ada_prototype (arg_sym);
4195 add_defn_to_vec (fixup_symbol_section (arg_sym, objfile), block);
4200 arg_sym = NULL; found_sym = 0;
4204 i = 0; U = BLOCK_NSYMS (block)-1;
4208 struct symbol *sym = BLOCK_SYM (block, M);
4209 if (SYMBOL_NAME (sym)[0] < '_')
4211 else if (SYMBOL_NAME (sym)[0] > '_')
4213 else if (strcmp (SYMBOL_NAME (sym), "_ada_") < 0)
4222 for (; i < BLOCK_NSYMS (block); i += 1)
4224 struct symbol *sym = BLOCK_SYM (block, i);
4226 if (SYMBOL_NAMESPACE (sym) == namespace)
4230 cmp = (int) '_' - (int) SYMBOL_NAME (sym)[0];
4233 cmp = strncmp ("_ada_", SYMBOL_NAME (sym), 5);
4235 cmp = strncmp (name, SYMBOL_NAME (sym) + 5, name_len);
4244 && is_name_suffix (SYMBOL_NAME (sym) + name_len + 5))
4246 switch (SYMBOL_CLASS (sym))
4252 case LOC_REGPARM_ADDR:
4253 case LOC_BASEREG_ARG:
4256 case LOC_UNRESOLVED:
4260 fill_in_ada_prototype (sym);
4261 add_defn_to_vec (fixup_symbol_section (sym, objfile),
4269 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4270 They aren't parameters, right? */
4271 if (! found_sym && arg_sym != NULL)
4273 fill_in_ada_prototype (arg_sym);
4274 add_defn_to_vec (fixup_symbol_section (arg_sym, objfile), block);
4280 /* Function Types */
4282 /* Assuming that SYM is the symbol for a function, fill in its type
4283 with prototype information, if it is not already there. */
4286 fill_in_ada_prototype (func)
4287 struct symbol* func;
4297 || TYPE_CODE (SYMBOL_TYPE (func)) != TYPE_CODE_FUNC
4298 || TYPE_FIELDS (SYMBOL_TYPE (func)) != NULL)
4301 /* We make each function type unique, so that each may have its own */
4302 /* parameter types. This particular way of doing so wastes space: */
4303 /* it would be nicer to build the argument types while the original */
4304 /* function type is being built (FIXME). */
4305 rtype = check_typedef (TYPE_TARGET_TYPE (SYMBOL_TYPE (func)));
4306 ftype = alloc_type (TYPE_OBJFILE (SYMBOL_TYPE (func)));
4307 make_function_type (rtype, &ftype);
4308 SYMBOL_TYPE (func) = ftype;
4310 b = SYMBOL_BLOCK_VALUE (func);
4311 nsyms = BLOCK_NSYMS (b);
4315 TYPE_FIELDS (ftype) =
4316 (struct field*) xmalloc (sizeof (struct field) * max_fields);
4317 for (i = 0; i < nsyms; i += 1)
4319 struct symbol *sym = BLOCK_SYM (b, i);
4321 GROW_VECT (TYPE_FIELDS (ftype), max_fields, nargs+1);
4323 switch (SYMBOL_CLASS (sym))
4326 case LOC_REGPARM_ADDR:
4327 TYPE_FIELD_BITPOS (ftype, nargs) = nargs;
4328 TYPE_FIELD_BITSIZE (ftype, nargs) = 0;
4329 TYPE_FIELD_TYPE (ftype, nargs) =
4330 lookup_pointer_type (check_typedef (SYMBOL_TYPE (sym)));
4331 TYPE_FIELD_NAME (ftype, nargs) = SYMBOL_NAME (sym);
4339 case LOC_BASEREG_ARG:
4340 TYPE_FIELD_BITPOS (ftype, nargs) = nargs;
4341 TYPE_FIELD_BITSIZE (ftype, nargs) = 0;
4342 TYPE_FIELD_TYPE (ftype, nargs) = check_typedef (SYMBOL_TYPE (sym));
4343 TYPE_FIELD_NAME (ftype, nargs) = SYMBOL_NAME (sym);
4353 /* Re-allocate fields vector; if there are no fields, make the */
4354 /* fields pointer non-null anyway, to mark that this function type */
4355 /* has been filled in. */
4357 TYPE_NFIELDS (ftype) = nargs;
4360 static struct field dummy_field = {0, 0, 0, 0};
4361 free (TYPE_FIELDS (ftype));
4362 TYPE_FIELDS (ftype) = &dummy_field;
4366 struct field* fields =
4367 (struct field*) TYPE_ALLOC (ftype, nargs * sizeof (struct field));
4368 memcpy ((char*) fields,
4369 (char*) TYPE_FIELDS (ftype),
4370 nargs * sizeof (struct field));
4371 free (TYPE_FIELDS (ftype));
4372 TYPE_FIELDS (ftype) = fields;
4377 /* Breakpoint-related */
4379 char no_symtab_msg[] = "No symbol table is loaded. Use the \"file\" command.";
4381 /* Assuming that LINE is pointing at the beginning of an argument to
4382 'break', return a pointer to the delimiter for the initial segment
4383 of that name. This is the first ':', ' ', or end of LINE.
4386 ada_start_decode_line_1 (line)
4389 /* [NOTE: strpbrk would be more elegant, but I am reluctant to be
4390 the first to use such a library function in GDB code.] */
4392 for (p = line; *p != '\000' && *p != ' ' && *p != ':'; p += 1)
4397 /* *SPEC points to a function and line number spec (as in a break
4398 command), following any initial file name specification.
4400 Return all symbol table/line specfications (sals) consistent with the
4401 information in *SPEC and FILE_TABLE in the
4403 + FILE_TABLE is null, or the sal refers to a line in the file
4404 named by FILE_TABLE.
4405 + If *SPEC points to an argument with a trailing ':LINENUM',
4406 then the sal refers to that line (or one following it as closely as
4408 + If *SPEC does not start with '*', the sal is in a function with
4411 Returns with 0 elements if no matching non-minimal symbols found.
4413 If *SPEC begins with a function name of the form <NAME>, then NAME
4414 is taken as a literal name; otherwise the function name is subject
4415 to the usual mangling.
4417 *SPEC is updated to point after the function/line number specification.
4419 FUNFIRSTLINE is non-zero if we desire the first line of real code
4420 in each function (this is ignored in the presence of a LINENUM spec.).
4422 If CANONICAL is non-NULL, and if any of the sals require a
4423 'canonical line spec', then *CANONICAL is set to point to an array
4424 of strings, corresponding to and equal in length to the returned
4425 list of sals, such that (*CANONICAL)[i] is non-null and contains a
4426 canonical line spec for the ith returned sal, if needed. If no
4427 canonical line specs are required and CANONICAL is non-null,
4428 *CANONICAL is set to NULL.
4430 A 'canonical line spec' is simply a name (in the format of the
4431 breakpoint command) that uniquely identifies a breakpoint position,
4432 with no further contextual information or user selection. It is
4433 needed whenever the file name, function name, and line number
4434 information supplied is insufficient for this unique
4435 identification. Currently overloaded functions, the name '*',
4436 or static functions without a filename yield a canonical line spec.
4437 The array and the line spec strings are allocated on the heap; it
4438 is the caller's responsibility to free them. */
4440 struct symtabs_and_lines
4441 ada_finish_decode_line_1 (spec, file_table, funfirstline, canonical)
4443 struct symtab* file_table;
4447 struct symbol** symbols;
4448 struct block** blocks;
4449 struct block* block;
4450 int n_matches, i, line_num;
4451 struct symtabs_and_lines selected;
4452 struct cleanup* old_chain = make_cleanup (null_cleanup, NULL);
4457 char* unquoted_name;
4459 if (file_table == NULL)
4460 block = get_selected_block (NULL);
4462 block = BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table), STATIC_BLOCK);
4464 if (canonical != NULL)
4465 *canonical = (char**) NULL;
4472 while (**spec != '\000' &&
4473 ! strchr (ada_completer_word_break_characters, **spec))
4479 if (file_table != NULL && (*spec)[0] == ':' && isdigit ((*spec)[1]))
4481 line_num = strtol (*spec + 1, spec, 10);
4482 while (**spec == ' ' || **spec == '\t')
4489 error ("Wild-card function with no line number or file name.");
4491 return all_sals_for_line (file_table->filename, line_num, canonical);
4494 if (name[0] == '\'')
4502 unquoted_name = (char*) alloca (len-1);
4503 memcpy (unquoted_name, name+1, len-2);
4504 unquoted_name[len-2] = '\000';
4509 unquoted_name = (char*) alloca (len+1);
4510 memcpy (unquoted_name, name, len);
4511 unquoted_name[len] = '\000';
4512 lower_name = (char*) alloca (len + 1);
4513 for (i = 0; i < len; i += 1)
4514 lower_name[i] = tolower (name[i]);
4515 lower_name[len] = '\000';
4519 if (lower_name != NULL)
4520 n_matches = ada_lookup_symbol_list (ada_mangle (lower_name), block,
4521 VAR_NAMESPACE, &symbols, &blocks);
4523 n_matches = ada_lookup_symbol_list (unquoted_name, block,
4524 VAR_NAMESPACE, &symbols, &blocks);
4525 if (n_matches == 0 && line_num >= 0)
4526 error ("No line number information found for %s.", unquoted_name);
4527 else if (n_matches == 0)
4529 #ifdef HPPA_COMPILER_BUG
4530 /* FIXME: See comment in symtab.c::decode_line_1 */
4532 volatile struct symtab_and_line val;
4533 #define volatile /*nothing*/
4535 struct symtab_and_line val;
4537 struct minimal_symbol* msymbol;
4542 if (lower_name != NULL)
4543 msymbol = ada_lookup_minimal_symbol (ada_mangle (lower_name));
4544 if (msymbol == NULL)
4545 msymbol = ada_lookup_minimal_symbol (unquoted_name);
4546 if (msymbol != NULL)
4548 val.pc = SYMBOL_VALUE_ADDRESS (msymbol);
4549 val.section = SYMBOL_BFD_SECTION (msymbol);
4552 val.pc += FUNCTION_START_OFFSET;
4553 SKIP_PROLOGUE (val.pc);
4555 selected.sals = (struct symtab_and_line *)
4556 xmalloc (sizeof (struct symtab_and_line));
4557 selected.sals[0] = val;
4562 if (!have_full_symbols () &&
4563 !have_partial_symbols () && !have_minimal_symbols ())
4564 error (no_symtab_msg);
4566 error ("Function \"%s\" not defined.", unquoted_name);
4567 return selected; /* for lint */
4573 find_sal_from_funcs_and_line (file_table->filename, line_num,
4574 symbols, n_matches);
4578 selected.nelts = user_select_syms (symbols, blocks, n_matches, n_matches);
4581 selected.sals = (struct symtab_and_line*)
4582 xmalloc (sizeof (struct symtab_and_line) * selected.nelts);
4583 memset (selected.sals, 0, selected.nelts * sizeof (selected.sals[i]));
4584 make_cleanup (free, selected.sals);
4587 while (i < selected.nelts)
4589 if (SYMBOL_CLASS (symbols[i]) == LOC_BLOCK)
4590 selected.sals[i] = find_function_start_sal (symbols[i], funfirstline);
4591 else if (SYMBOL_LINE (symbols[i]) != 0)
4593 selected.sals[i].symtab = symtab_for_sym (symbols[i]);
4594 selected.sals[i].line = SYMBOL_LINE (symbols[i]);
4596 else if (line_num >= 0)
4598 /* Ignore this choice */
4599 symbols[i] = symbols[selected.nelts-1];
4600 blocks[i] = blocks[selected.nelts-1];
4601 selected.nelts -= 1;
4605 error ("Line number not known for symbol \"%s\"", unquoted_name);
4609 if (canonical != NULL && (line_num >= 0 || n_matches > 1))
4611 *canonical = (char**) xmalloc (sizeof(char*) * selected.nelts);
4612 for (i = 0; i < selected.nelts; i += 1)
4614 extended_canonical_line_spec (selected.sals[i],
4615 SYMBOL_SOURCE_NAME (symbols[i]));
4618 discard_cleanups (old_chain);
4622 /* The (single) sal corresponding to line LINE_NUM in a symbol table
4623 with file name FILENAME that occurs in one of the functions listed
4624 in SYMBOLS[0 .. NSYMS-1]. */
4625 static struct symtabs_and_lines
4626 find_sal_from_funcs_and_line (filename, line_num, symbols, nsyms)
4627 const char* filename;
4629 struct symbol** symbols;
4632 struct symtabs_and_lines sals;
4633 int best_index, best;
4634 struct linetable* best_linetable;
4635 struct objfile* objfile;
4637 struct symtab* best_symtab;
4639 read_all_symtabs (filename);
4641 best_index = 0; best_linetable = NULL; best_symtab = NULL;
4643 ALL_SYMTABS (objfile, s)
4645 struct linetable *l;
4650 if (!STREQ (filename, s->filename))
4653 ind = find_line_in_linetable (l, line_num, symbols, nsyms, &exact);
4663 if (best == 0 || l->item[ind].line < best)
4665 best = l->item[ind].line;
4674 error ("Line number not found in designated function.");
4679 sals.sals = (struct symtab_and_line*) xmalloc (sizeof (sals.sals[0]));
4681 INIT_SAL (&sals.sals[0]);
4683 sals.sals[0].line = best_linetable->item[best_index].line;
4684 sals.sals[0].pc = best_linetable->item[best_index].pc;
4685 sals.sals[0].symtab = best_symtab;
4690 /* Return the index in LINETABLE of the best match for LINE_NUM whose
4691 pc falls within one of the functions denoted by SYMBOLS[0..NSYMS-1].
4692 Set *EXACTP to the 1 if the match is exact, and 0 otherwise. */
4694 find_line_in_linetable (linetable, line_num, symbols, nsyms, exactp)
4695 struct linetable* linetable;
4697 struct symbol** symbols;
4701 int i, len, best_index, best;
4703 if (line_num <= 0 || linetable == NULL)
4706 len = linetable->nitems;
4707 for (i = 0, best_index = -1, best = 0; i < len; i += 1)
4710 struct linetable_entry* item = &(linetable->item[i]);
4712 for (k = 0; k < nsyms; k += 1)
4714 if (symbols[k] != NULL && SYMBOL_CLASS (symbols[k]) == LOC_BLOCK
4715 && item->pc >= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols[k]))
4716 && item->pc < BLOCK_END (SYMBOL_BLOCK_VALUE (symbols[k])))
4723 if (item->line == line_num)
4729 if (item->line > line_num && (best == 0 || item->line < best))
4740 /* Find the smallest k >= LINE_NUM such that k is a line number in
4741 LINETABLE, and k falls strictly within a named function that begins at
4742 or before LINE_NUM. Return -1 if there is no such k. */
4744 nearest_line_number_in_linetable (linetable, line_num)
4745 struct linetable* linetable;
4750 if (line_num <= 0 || linetable == NULL || linetable->nitems == 0)
4752 len = linetable->nitems;
4754 i = 0; best = INT_MAX;
4758 struct linetable_entry* item = &(linetable->item[i]);
4760 if (item->line >= line_num && item->line < best)
4763 CORE_ADDR start, end;
4766 find_pc_partial_function (item->pc, &func_name, &start, &end);
4768 if (func_name != NULL && item->pc < end)
4770 if (item->line == line_num)
4774 struct symbol* sym =
4775 standard_lookup (func_name, VAR_NAMESPACE);
4776 if (is_plausible_func_for_line (sym, line_num))
4782 while (i < len && linetable->item[i].pc < end);
4792 return (best == INT_MAX) ? -1 : best;
4796 /* Return the next higher index, k, into LINETABLE such that k > IND,
4797 entry k in LINETABLE has a line number equal to LINE_NUM, k
4798 corresponds to a PC that is in a function different from that
4799 corresponding to IND, and falls strictly within a named function
4800 that begins at a line at or preceding STARTING_LINE.
4801 Return -1 if there is no such k.
4802 IND == -1 corresponds to no function. */
4805 find_next_line_in_linetable (linetable, line_num, starting_line, ind)
4806 struct linetable* linetable;
4813 if (line_num <= 0 || linetable == NULL || ind >= linetable->nitems)
4815 len = linetable->nitems;
4819 CORE_ADDR start, end;
4821 if (find_pc_partial_function (linetable->item[ind].pc,
4822 (char**) NULL, &start, &end))
4824 while (ind < len && linetable->item[ind].pc < end)
4837 struct linetable_entry* item = &(linetable->item[i]);
4839 if (item->line >= line_num)
4842 CORE_ADDR start, end;
4845 find_pc_partial_function (item->pc, &func_name, &start, &end);
4847 if (func_name != NULL && item->pc < end)
4849 if (item->line == line_num)
4851 struct symbol* sym =
4852 standard_lookup (func_name, VAR_NAMESPACE);
4853 if (is_plausible_func_for_line (sym, starting_line))
4857 while ((i+1) < len && linetable->item[i+1].pc < end)
4869 /* True iff function symbol SYM starts somewhere at or before line #
4872 is_plausible_func_for_line (sym, line_num)
4876 struct symtab_and_line start_sal;
4881 start_sal = find_function_start_sal (sym, 0);
4883 return (start_sal.line != 0 && line_num >= start_sal.line);
4887 debug_print_lines (lt)
4888 struct linetable* lt;
4895 fprintf (stderr, "\t");
4896 for (i = 0; i < lt->nitems; i += 1)
4897 fprintf (stderr, "(%d->%p) ", lt->item[i].line, (void *) lt->item[i].pc);
4898 fprintf (stderr, "\n");
4902 debug_print_block (b)
4906 fprintf (stderr, "Block: %p; [0x%lx, 0x%lx]",
4907 b, BLOCK_START(b), BLOCK_END(b));
4908 if (BLOCK_FUNCTION(b) != NULL)
4909 fprintf (stderr, " Function: %s", SYMBOL_NAME (BLOCK_FUNCTION(b)));
4910 fprintf (stderr, "\n");
4911 fprintf (stderr, "\t Superblock: %p\n", BLOCK_SUPERBLOCK(b));
4912 fprintf (stderr, "\t Symbols:");
4913 for (i = 0; i < BLOCK_NSYMS (b); i += 1)
4915 if (i > 0 && i % 4 == 0)
4916 fprintf (stderr, "\n\t\t ");
4917 fprintf (stderr, " %s", SYMBOL_NAME (BLOCK_SYM (b, i)));
4919 fprintf (stderr, "\n");
4923 debug_print_blocks (bv)
4924 struct blockvector* bv;
4930 for (i = 0; i < BLOCKVECTOR_NBLOCKS (bv); i += 1) {
4931 fprintf (stderr, "%6d. ", i);
4932 debug_print_block (BLOCKVECTOR_BLOCK (bv, i));
4937 debug_print_symtab (s)
4940 fprintf (stderr, "Symtab %p\n File: %s; Dir: %s\n", s,
4941 s->filename, s->dirname);
4942 fprintf (stderr, " Blockvector: %p, Primary: %d\n",
4943 BLOCKVECTOR(s), s->primary);
4944 debug_print_blocks (BLOCKVECTOR(s));
4945 fprintf (stderr, " Line table: %p\n", LINETABLE (s));
4946 debug_print_lines (LINETABLE(s));
4949 /* Read in all symbol tables corresponding to partial symbol tables
4950 with file name FILENAME. */
4952 read_all_symtabs (filename)
4953 const char* filename;
4955 struct partial_symtab* ps;
4956 struct objfile* objfile;
4958 ALL_PSYMTABS (objfile, ps)
4962 if (STREQ (filename, ps->filename))
4963 PSYMTAB_TO_SYMTAB (ps);
4967 /* All sals corresponding to line LINE_NUM in a symbol table from file
4968 FILENAME, as filtered by the user. If CANONICAL is not null, set
4969 it to a corresponding array of canonical line specs. */
4970 static struct symtabs_and_lines
4971 all_sals_for_line (filename, line_num, canonical)
4972 const char* filename;
4976 struct symtabs_and_lines result;
4977 struct objfile* objfile;
4979 struct cleanup* old_chain = make_cleanup (null_cleanup, NULL);
4982 read_all_symtabs (filename);
4984 result.sals = (struct symtab_and_line*) xmalloc (4 * sizeof (result.sals[0]));
4987 make_cleanup (free_current_contents, &result.sals);
4989 ALL_SYMTABS (objfile, s)
4991 int ind, target_line_num;
4995 if (!STREQ (s->filename, filename))
4999 nearest_line_number_in_linetable (LINETABLE (s), line_num);
5000 if (target_line_num == -1)
5007 find_next_line_in_linetable (LINETABLE (s),
5008 target_line_num, line_num, ind);
5013 GROW_VECT (result.sals, len, result.nelts+1);
5014 INIT_SAL (&result.sals[result.nelts]);
5015 result.sals[result.nelts].line = LINETABLE(s)->item[ind].line;
5016 result.sals[result.nelts].pc = LINETABLE(s)->item[ind].pc;
5017 result.sals[result.nelts].symtab = s;
5022 if (canonical != NULL || result.nelts > 1)
5025 char** func_names = (char**) alloca (result.nelts * sizeof (char*));
5026 int first_choice = (result.nelts > 1) ? 2 : 1;
5028 int* choices = (int*) alloca (result.nelts * sizeof (int));
5030 for (k = 0; k < result.nelts; k += 1)
5032 find_pc_partial_function (result.sals[k].pc, &func_names[k],
5033 (CORE_ADDR*) NULL, (CORE_ADDR*) NULL);
5034 if (func_names[k] == NULL)
5035 error ("Could not find function for one or more breakpoints.");
5038 if (result.nelts > 1)
5040 printf_unfiltered("[0] cancel\n");
5041 if (result.nelts > 1)
5042 printf_unfiltered("[1] all\n");
5043 for (k = 0; k < result.nelts; k += 1)
5044 printf_unfiltered ("[%d] %s\n", k + first_choice,
5045 ada_demangle (func_names[k]));
5047 n = get_selections (choices, result.nelts, result.nelts,
5048 result.nelts > 1, "instance-choice");
5050 for (k = 0; k < n; k += 1)
5052 result.sals[k] = result.sals[choices[k]];
5053 func_names[k] = func_names[choices[k]];
5058 if (canonical != NULL)
5060 *canonical = (char**) xmalloc (result.nelts * sizeof (char**));
5061 make_cleanup (free, *canonical);
5062 for (k = 0; k < result.nelts; k += 1)
5065 extended_canonical_line_spec (result.sals[k], func_names[k]);
5066 if ((*canonical)[k] == NULL)
5067 error ("Could not locate one or more breakpoints.");
5068 make_cleanup (free, (*canonical)[k]);
5073 discard_cleanups (old_chain);
5078 /* A canonical line specification of the form FILE:NAME:LINENUM for
5079 symbol table and line data SAL. NULL if insufficient
5080 information. The caller is responsible for releasing any space
5084 extended_canonical_line_spec (sal, name)
5085 struct symtab_and_line sal;
5090 if (sal.symtab == NULL || sal.symtab->filename == NULL ||
5094 r = (char*) xmalloc (strlen (name) + strlen (sal.symtab->filename)
5095 + sizeof(sal.line)*3 + 3);
5096 sprintf (r, "%s:'%s':%d", sal.symtab->filename, name, sal.line);
5101 int begin_bnum = -1;
5103 int begin_annotate_level = 0;
5106 begin_cleanup (void* dummy)
5108 begin_annotate_level = 0;
5112 begin_command (args, from_tty)
5116 struct minimal_symbol *msym;
5117 CORE_ADDR main_program_name_addr;
5118 char main_program_name[1024];
5119 struct cleanup* old_chain = make_cleanup (begin_cleanup, NULL);
5120 begin_annotate_level = 2;
5122 /* Check that there is a program to debug */
5123 if (!have_full_symbols () && !have_partial_symbols ())
5124 error ("No symbol table is loaded. Use the \"file\" command.");
5126 /* Check that we are debugging an Ada program */
5127 /* if (ada_update_initial_language (language_unknown, NULL) != language_ada)
5128 error ("Cannot find the Ada initialization procedure. Is this an Ada main program?");
5130 /* FIXME: language_ada should be defined in defs.h */
5132 /* Get the address of the name of the main procedure */
5133 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
5137 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
5138 if (main_program_name_addr == 0)
5139 error ("Invalid address for Ada main program name.");
5141 /* Read the name of the main procedure */
5142 extract_string (main_program_name_addr, main_program_name);
5144 /* Put a temporary breakpoint in the Ada main program and run */
5145 do_command ("tbreak ", main_program_name, 0);
5146 do_command ("run ", args, 0);
5150 /* If we could not find the symbol containing the name of the
5151 main program, that means that the compiler that was used to build
5152 was not recent enough. In that case, we fallback to the previous
5153 mechanism, which is a little bit less reliable, but has proved to work
5154 in most cases. The only cases where it will fail is when the user
5155 has set some breakpoints which will be hit before the end of the
5156 begin command processing (eg in the initialization code).
5158 The begining of the main Ada subprogram is located by breaking
5159 on the adainit procedure. Since we know that the binder generates
5160 the call to this procedure exactly 2 calls before the call to the
5161 Ada main subprogram, it is then easy to put a breakpoint on this
5162 Ada main subprogram once we hit adainit.
5164 do_command ("tbreak adainit", 0);
5165 do_command ("run ", args, 0);
5166 do_command ("up", 0);
5167 do_command ("tbreak +2", 0);
5168 do_command ("continue", 0);
5169 do_command ("step", 0);
5172 do_cleanups (old_chain);
5176 is_ada_runtime_file (filename)
5179 return (STREQN (filename, "s-", 2) ||
5180 STREQN (filename, "a-", 2) ||
5181 STREQN (filename, "g-", 2) ||
5182 STREQN (filename, "i-", 2));
5185 /* find the first frame that contains debugging information and that is not
5186 part of the Ada run-time, starting from fi and moving upward. */
5189 find_printable_frame (fi, level)
5190 struct frame_info *fi;
5193 struct symtab_and_line sal;
5195 for (; fi != NULL; level += 1, fi = get_prev_frame (fi))
5197 /* If fi is not the innermost frame, that normally means that fi->pc
5198 points to *after* the call instruction, and we want to get the line
5199 containing the call, never the next line. But if the next frame is
5200 a signal_handler_caller or a dummy frame, then the next frame was
5201 not entered as the result of a call, and we want to get the line
5202 containing fi->pc. */
5204 find_pc_line (fi->pc,
5206 && !fi->next->signal_handler_caller
5207 && !frame_in_dummy (fi->next));
5208 if (sal.symtab && !is_ada_runtime_file (sal.symtab->filename))
5210 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
5211 /* libpthread.so contains some debugging information that prevents us
5212 from finding the right frame */
5214 if (sal.symtab->objfile &&
5215 STREQ (sal.symtab->objfile->name, "/usr/shlib/libpthread.so"))
5218 selected_frame = fi;
5227 ada_report_exception_break (b)
5228 struct breakpoint *b;
5231 /* FIXME: break_on_exception should be defined in breakpoint.h */
5232 /* if (b->break_on_exception == 1)
5234 /* Assume that cond has 16 elements, the 15th
5235 being the exception */ /*
5236 if (b->cond && b->cond->nelts == 16)
5238 ui_out_text (uiout, "on ");
5239 ui_out_field_string (uiout, "exception",
5240 SYMBOL_NAME (b->cond->elts[14].symbol));
5243 ui_out_text (uiout, "on all exceptions");
5245 else if (b->break_on_exception == 2)
5246 ui_out_text (uiout, "on unhandled exception");
5247 else if (b->break_on_exception == 3)
5248 ui_out_text (uiout, "on assert failure");
5250 if (b->break_on_exception == 1)
5252 /* Assume that cond has 16 elements, the 15th
5253 being the exception */ /*
5254 if (b->cond && b->cond->nelts == 16)
5256 fputs_filtered ("on ", gdb_stdout);
5257 fputs_filtered (SYMBOL_NAME
5258 (b->cond->elts[14].symbol), gdb_stdout);
5261 fputs_filtered ("on all exceptions", gdb_stdout);
5263 else if (b->break_on_exception == 2)
5264 fputs_filtered ("on unhandled exception", gdb_stdout);
5265 else if (b->break_on_exception == 3)
5266 fputs_filtered ("on assert failure", gdb_stdout);
5272 ada_is_exception_sym (struct symbol* sym)
5274 char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
5276 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
5277 && SYMBOL_CLASS (sym) != LOC_BLOCK
5278 && SYMBOL_CLASS (sym) != LOC_CONST
5279 && type_name != NULL
5280 && STREQ (type_name, "exception"));
5284 ada_maybe_exception_partial_symbol (struct partial_symbol* sym)
5286 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
5287 && SYMBOL_CLASS (sym) != LOC_BLOCK
5288 && SYMBOL_CLASS (sym) != LOC_CONST);
5291 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5292 into equivalent form. Return resulting argument string. Set
5293 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5294 break on unhandled, 3 for assert, 0 otherwise. */
5295 char* ada_breakpoint_rewrite (char* arg, int* break_on_exceptionp)
5299 *break_on_exceptionp = 0;
5300 /* FIXME: language_ada should be defined in defs.h */
5301 /* if (current_language->la_language == language_ada
5302 && STREQN (arg, "exception", 9) &&
5303 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5305 char *tok, *end_tok;
5308 *break_on_exceptionp = 1;
5311 while (*tok == ' ' || *tok == '\t')
5316 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5319 toklen = end_tok - tok;
5321 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5322 "long_integer(e) = long_integer(&)")
5324 make_cleanup (free, arg);
5326 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5327 else if (STREQN (tok, "unhandled", toklen))
5329 *break_on_exceptionp = 2;
5330 strcpy (arg, "__gnat_unhandled_exception");
5334 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5335 "long_integer(e) = long_integer(&%.*s)",
5339 else if (current_language->la_language == language_ada
5340 && STREQN (arg, "assert", 6) &&
5341 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5343 char *tok = arg + 6;
5345 *break_on_exceptionp = 3;
5348 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5349 + strlen (tok) + 1);
5350 make_cleanup (free, arg);
5351 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5360 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5361 to be invisible to users. */
5364 ada_is_ignored_field (type, field_num)
5368 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5372 const char* name = TYPE_FIELD_NAME (type, field_num);
5373 return (name == NULL
5374 || (name[0] == '_' && ! STREQN (name, "_parent", 7)));
5378 /* True iff structure type TYPE has a tag field. */
5381 ada_is_tagged_type (type)
5384 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5387 return (ada_lookup_struct_elt_type (type, "_tag", 1, NULL) != NULL);
5390 /* The type of the tag on VAL. */
5396 return ada_lookup_struct_elt_type (VALUE_TYPE (val), "_tag", 0, NULL);
5399 /* The value of the tag on VAL. */
5405 return ada_value_struct_elt (val, "_tag", "record");
5408 /* The parent type of TYPE, or NULL if none. */
5411 ada_parent_type (type)
5416 CHECK_TYPEDEF (type);
5418 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5421 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5422 if (ada_is_parent_field (type, i))
5423 return check_typedef (TYPE_FIELD_TYPE (type, i));
5428 /* True iff field number FIELD_NUM of structure type TYPE contains the
5429 parent-type (inherited) fields of a derived type. Assumes TYPE is
5430 a structure type with at least FIELD_NUM+1 fields. */
5433 ada_is_parent_field (type, field_num)
5437 const char* name = TYPE_FIELD_NAME (check_typedef (type), field_num);
5438 return (name != NULL &&
5439 (STREQN (name, "PARENT", 6) || STREQN (name, "_parent", 7)));
5442 /* True iff field number FIELD_NUM of structure type TYPE is a
5443 transparent wrapper field (which should be silently traversed when doing
5444 field selection and flattened when printing). Assumes TYPE is a
5445 structure type with at least FIELD_NUM+1 fields. Such fields are always
5449 ada_is_wrapper_field (type, field_num)
5453 const char* name = TYPE_FIELD_NAME (type, field_num);
5454 return (name != NULL
5455 && (STREQN (name, "PARENT", 6) || STREQ (name, "REP")
5456 || STREQN (name, "_parent", 7)
5457 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
5460 /* True iff field number FIELD_NUM of structure or union type TYPE
5461 is a variant wrapper. Assumes TYPE is a structure type with at least
5462 FIELD_NUM+1 fields. */
5465 ada_is_variant_part (type, field_num)
5469 struct type* field_type = TYPE_FIELD_TYPE (type, field_num);
5470 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
5471 || (is_dynamic_field (type, field_num)
5472 && TYPE_CODE (TYPE_TARGET_TYPE (field_type)) == TYPE_CODE_UNION));
5475 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5476 whose discriminants are contained in the record type OUTER_TYPE,
5477 returns the type of the controlling discriminant for the variant. */
5480 ada_variant_discrim_type (var_type, outer_type)
5481 struct type *var_type;
5482 struct type *outer_type;
5484 char* name = ada_variant_discrim_name (var_type);
5486 ada_lookup_struct_elt_type (outer_type, name, 1, NULL);
5488 return builtin_type_int;
5493 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5494 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5495 represents a 'when others' clause; otherwise 0. */
5498 ada_is_others_clause (type, field_num)
5502 const char* name = TYPE_FIELD_NAME (type, field_num);
5503 return (name != NULL && name[0] == 'O');
5506 /* Assuming that TYPE0 is the type of the variant part of a record,
5507 returns the name of the discriminant controlling the variant. The
5508 value is valid until the next call to ada_variant_discrim_name. */
5511 ada_variant_discrim_name (type0)
5514 static char* result = NULL;
5515 static size_t result_len = 0;
5518 const char* discrim_end;
5519 const char* discrim_start;
5521 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
5522 type = TYPE_TARGET_TYPE (type0);
5526 name = ada_type_name (type);
5528 if (name == NULL || name[0] == '\000')
5531 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
5534 if (STREQN (discrim_end, "___XVN", 6))
5537 if (discrim_end == name)
5540 for (discrim_start = discrim_end; discrim_start != name+3;
5543 if (discrim_start == name+1)
5545 if ((discrim_start > name+3 && STREQN (discrim_start-3, "___", 3))
5546 || discrim_start[-1] == '.')
5550 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
5551 strncpy (result, discrim_start, discrim_end - discrim_start);
5552 result[discrim_end-discrim_start] = '\0';
5556 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5557 position of the character just past the number scanned in *NEW_K,
5558 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5559 if there was a valid number at the given position, and 0 otherwise. A
5560 "subtype-encoded" number consists of the absolute value in decimal,
5561 followed by the letter 'm' to indicate a negative number. Assumes 0m
5565 ada_scan_number (str, k, R, new_k)
5573 if (! isdigit (str[k]))
5576 /* Do it the hard way so as not to make any assumption about
5577 the relationship of unsigned long (%lu scan format code) and
5580 while (isdigit (str[k]))
5582 RU = RU*10 + (str[k] - '0');
5589 *R = (- (LONGEST) (RU-1)) - 1;
5595 /* NOTE on the above: Technically, C does not say what the results of
5596 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5597 number representable as a LONGEST (although either would probably work
5598 in most implementations). When RU>0, the locution in the then branch
5599 above is always equivalent to the negative of RU. */
5606 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5607 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5608 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5611 ada_in_variant (val, type, field_num)
5616 const char* name = TYPE_FIELD_NAME (type, field_num);
5629 if (! ada_scan_number (name, p + 1, &W, &p))
5638 if (! ada_scan_number (name, p + 1, &L, &p)
5640 || ! ada_scan_number (name, p + 1, &U, &p))
5642 if (val >= L && val <= U)
5654 /* Given a value ARG1 (offset by OFFSET bytes)
5655 of a struct or union type ARG_TYPE,
5656 extract and return the value of one of its (non-static) fields.
5657 FIELDNO says which field. Differs from value_primitive_field only
5658 in that it can handle packed values of arbitrary type. */
5661 ada_value_primitive_field (arg1, offset, fieldno, arg_type)
5665 struct type *arg_type;
5670 CHECK_TYPEDEF (arg_type);
5671 type = TYPE_FIELD_TYPE (arg_type, fieldno);
5673 /* Handle packed fields */
5675 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
5677 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
5678 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
5680 return ada_value_primitive_packed_val (arg1, VALUE_CONTENTS (arg1),
5681 offset + bit_pos/8, bit_pos % 8,
5685 return value_primitive_field (arg1, offset, fieldno, arg_type);
5689 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5690 and search in it assuming it has (class) type TYPE.
5691 If found, return value, else return NULL.
5693 Searches recursively through wrapper fields (e.g., '_parent'). */
5696 ada_search_struct_field (name, arg, offset, type)
5703 CHECK_TYPEDEF (type);
5705 for (i = TYPE_NFIELDS (type)-1; i >= 0; i -= 1)
5707 char *t_field_name = TYPE_FIELD_NAME (type, i);
5709 if (t_field_name == NULL)
5712 else if (field_name_match (t_field_name, name))
5713 return ada_value_primitive_field (arg, offset, i, type);
5715 else if (ada_is_wrapper_field (type, i))
5718 ada_search_struct_field (name, arg,
5719 offset + TYPE_FIELD_BITPOS (type, i) / 8,
5720 TYPE_FIELD_TYPE (type, i));
5725 else if (ada_is_variant_part (type, i))
5728 struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, i));
5729 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
5731 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
5734 ada_search_struct_field (name, arg,
5736 + TYPE_FIELD_BITPOS (field_type, j)/8,
5737 TYPE_FIELD_TYPE (field_type, j));
5746 /* Given ARG, a value of type (pointer to a)* structure/union,
5747 extract the component named NAME from the ultimate target structure/union
5748 and return it as a value with its appropriate type.
5750 The routine searches for NAME among all members of the structure itself
5751 and (recursively) among all members of any wrapper members
5754 ERR is a name (for use in error messages) that identifies the class
5755 of entity that ARG is supposed to be. */
5758 ada_value_struct_elt (arg, name, err)
5766 arg = ada_coerce_ref (arg);
5767 t = check_typedef (VALUE_TYPE (arg));
5769 /* Follow pointers until we get to a non-pointer. */
5771 while (TYPE_CODE (t) == TYPE_CODE_PTR || TYPE_CODE (t) == TYPE_CODE_REF)
5773 arg = ada_value_ind (arg);
5774 t = check_typedef (VALUE_TYPE (arg));
5777 if ( TYPE_CODE (t) != TYPE_CODE_STRUCT
5778 && TYPE_CODE (t) != TYPE_CODE_UNION)
5779 error ("Attempt to extract a component of a value that is not a %s.", err);
5781 v = ada_search_struct_field (name, arg, 0, t);
5783 error ("There is no member named %s.", name);
5788 /* Given a type TYPE, look up the type of the component of type named NAME.
5789 If DISPP is non-null, add its byte displacement from the beginning of a
5790 structure (pointed to by a value) of type TYPE to *DISPP (does not
5791 work for packed fields).
5793 Matches any field whose name has NAME as a prefix, possibly
5796 TYPE can be either a struct or union, or a pointer or reference to
5797 a struct or union. If it is a pointer or reference, its target
5798 type is automatically used.
5800 Looks recursively into variant clauses and parent types.
5802 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5805 ada_lookup_struct_elt_type (type, name, noerr, dispp)
5818 CHECK_TYPEDEF (type);
5819 if (TYPE_CODE (type) != TYPE_CODE_PTR
5820 && TYPE_CODE (type) != TYPE_CODE_REF)
5822 type = TYPE_TARGET_TYPE (type);
5825 if (TYPE_CODE (type) != TYPE_CODE_STRUCT &&
5826 TYPE_CODE (type) != TYPE_CODE_UNION)
5828 target_terminal_ours ();
5829 gdb_flush (gdb_stdout);
5830 fprintf_unfiltered (gdb_stderr, "Type ");
5831 type_print (type, "", gdb_stderr, -1);
5832 error (" is not a structure or union type");
5835 type = to_static_fixed_type (type);
5837 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5839 char *t_field_name = TYPE_FIELD_NAME (type, i);
5843 if (t_field_name == NULL)
5846 else if (field_name_match (t_field_name, name))
5849 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
5850 return check_typedef (TYPE_FIELD_TYPE (type, i));
5853 else if (ada_is_wrapper_field (type, i))
5856 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
5861 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
5866 else if (ada_is_variant_part (type, i))
5869 struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, i));
5871 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
5874 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
5879 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
5890 target_terminal_ours ();
5891 gdb_flush (gdb_stdout);
5892 fprintf_unfiltered (gdb_stderr, "Type ");
5893 type_print (type, "", gdb_stderr, -1);
5894 fprintf_unfiltered (gdb_stderr, " has no component named ");
5895 error ("%s", name == NULL ? "<null>" : name);
5901 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5902 within a value of type OUTER_TYPE that is stored in GDB at
5903 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5904 numbering from 0) is applicable. Returns -1 if none are. */
5907 ada_which_variant_applies (var_type, outer_type, outer_valaddr)
5908 struct type *var_type;
5909 struct type *outer_type;
5910 char* outer_valaddr;
5915 struct type* discrim_type;
5916 char* discrim_name = ada_variant_discrim_name (var_type);
5917 LONGEST discrim_val;
5921 ada_lookup_struct_elt_type (outer_type, discrim_name, 1, &disp);
5922 if (discrim_type == NULL)
5924 discrim_val = unpack_long (discrim_type, outer_valaddr + disp);
5927 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
5929 if (ada_is_others_clause (var_type, i))
5931 else if (ada_in_variant (discrim_val, var_type, i))
5935 return others_clause;
5940 /* Dynamic-Sized Records */
5942 /* Strategy: The type ostensibly attached to a value with dynamic size
5943 (i.e., a size that is not statically recorded in the debugging
5944 data) does not accurately reflect the size or layout of the value.
5945 Our strategy is to convert these values to values with accurate,
5946 conventional types that are constructed on the fly. */
5948 /* There is a subtle and tricky problem here. In general, we cannot
5949 determine the size of dynamic records without its data. However,
5950 the 'struct value' data structure, which GDB uses to represent
5951 quantities in the inferior process (the target), requires the size
5952 of the type at the time of its allocation in order to reserve space
5953 for GDB's internal copy of the data. That's why the
5954 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5955 rather than struct value*s.
5957 However, GDB's internal history variables ($1, $2, etc.) are
5958 struct value*s containing internal copies of the data that are not, in
5959 general, the same as the data at their corresponding addresses in
5960 the target. Fortunately, the types we give to these values are all
5961 conventional, fixed-size types (as per the strategy described
5962 above), so that we don't usually have to perform the
5963 'to_fixed_xxx_type' conversions to look at their values.
5964 Unfortunately, there is one exception: if one of the internal
5965 history variables is an array whose elements are unconstrained
5966 records, then we will need to create distinct fixed types for each
5967 element selected. */
5969 /* The upshot of all of this is that many routines take a (type, host
5970 address, target address) triple as arguments to represent a value.
5971 The host address, if non-null, is supposed to contain an internal
5972 copy of the relevant data; otherwise, the program is to consult the
5973 target at the target address. */
5975 /* Assuming that VAL0 represents a pointer value, the result of
5976 dereferencing it. Differs from value_ind in its treatment of
5977 dynamic-sized types. */
5980 ada_value_ind (val0)
5983 struct value* val = unwrap_value (value_ind (val0));
5984 return ada_to_fixed_value (VALUE_TYPE (val), 0,
5985 VALUE_ADDRESS (val) + VALUE_OFFSET (val),
5989 /* The value resulting from dereferencing any "reference to"
5990 * qualifiers on VAL0. */
5991 static struct value*
5992 ada_coerce_ref (val0)
5995 if (TYPE_CODE (VALUE_TYPE (val0)) == TYPE_CODE_REF) {
5996 struct value* val = val0;
5998 val = unwrap_value (val);
5999 return ada_to_fixed_value (VALUE_TYPE (val), 0,
6000 VALUE_ADDRESS (val) + VALUE_OFFSET (val),
6006 /* Return OFF rounded upward if necessary to a multiple of
6007 ALIGNMENT (a power of 2). */
6010 align_value (off, alignment)
6012 unsigned int alignment;
6014 return (off + alignment - 1) & ~(alignment - 1);
6017 /* Return the additional bit offset required by field F of template
6021 field_offset (type, f)
6025 int n = TYPE_FIELD_BITPOS (type, f);
6026 /* Kludge (temporary?) to fix problem with dwarf output. */
6028 return (unsigned int) n & 0xffff;
6034 /* Return the bit alignment required for field #F of template type TYPE. */
6037 field_alignment (type, f)
6041 const char* name = TYPE_FIELD_NAME (type, f);
6042 int len = (name == NULL) ? 0 : strlen (name);
6045 if (len < 8 || ! isdigit (name[len-1]))
6046 return TARGET_CHAR_BIT;
6048 if (isdigit (name[len-2]))
6049 align_offset = len - 2;
6051 align_offset = len - 1;
6053 if (align_offset < 7 || ! STREQN ("___XV", name+align_offset-6, 5))
6054 return TARGET_CHAR_BIT;
6056 return atoi (name+align_offset) * TARGET_CHAR_BIT;
6059 /* Find a type named NAME. Ignores ambiguity. */
6061 ada_find_any_type (name)
6066 sym = standard_lookup (name, VAR_NAMESPACE);
6067 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
6068 return SYMBOL_TYPE (sym);
6070 sym = standard_lookup (name, STRUCT_NAMESPACE);
6072 return SYMBOL_TYPE (sym);
6077 /* Because of GNAT encoding conventions, several GDB symbols may match a
6078 given type name. If the type denoted by TYPE0 is to be preferred to
6079 that of TYPE1 for purposes of type printing, return non-zero;
6080 otherwise return 0. */
6082 ada_prefer_type (type0, type1)
6088 else if (type0 == NULL)
6090 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
6092 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
6094 else if (ada_is_packed_array_type (type0))
6096 else if (ada_is_array_descriptor (type0) && ! ada_is_array_descriptor (type1))
6098 else if (ada_renaming_type (type0) != NULL
6099 && ada_renaming_type (type1) == NULL)
6104 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6105 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6107 ada_type_name (type)
6112 else if (TYPE_NAME (type) != NULL)
6113 return TYPE_NAME (type);
6115 return TYPE_TAG_NAME (type);
6118 /* Find a parallel type to TYPE whose name is formed by appending
6119 SUFFIX to the name of TYPE. */
6122 ada_find_parallel_type (type, suffix)
6127 static size_t name_len = 0;
6128 struct symbol** syms;
6129 struct block** blocks;
6132 char* typename = ada_type_name (type);
6134 if (typename == NULL)
6137 len = strlen (typename);
6139 GROW_VECT (name, name_len, len+strlen (suffix)+1);
6141 strcpy (name, typename);
6142 strcpy (name + len, suffix);
6144 return ada_find_any_type (name);
6148 /* If TYPE is a variable-size record type, return the corresponding template
6149 type describing its fields. Otherwise, return NULL. */
6152 dynamic_template_type (type)
6155 CHECK_TYPEDEF (type);
6157 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
6158 || ada_type_name (type) == NULL)
6162 int len = strlen (ada_type_name (type));
6163 if (len > 6 && STREQ (ada_type_name (type) + len - 6, "___XVE"))
6166 return ada_find_parallel_type (type, "___XVE");
6170 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6171 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6174 is_dynamic_field (templ_type, field_num)
6175 struct type* templ_type;
6178 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
6180 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
6181 && strstr (name, "___XVL") != NULL;
6184 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
6185 contains a variant part. */
6188 contains_variant_part (type)
6193 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
6194 || TYPE_NFIELDS (type) <= 0)
6196 return ada_is_variant_part (type, TYPE_NFIELDS (type) - 1);
6199 /* A record type with no fields, . */
6201 empty_record (objfile)
6202 struct objfile* objfile;
6204 struct type* type = alloc_type (objfile);
6205 TYPE_CODE (type) = TYPE_CODE_STRUCT;
6206 TYPE_NFIELDS (type) = 0;
6207 TYPE_FIELDS (type) = NULL;
6208 TYPE_NAME (type) = "<empty>";
6209 TYPE_TAG_NAME (type) = NULL;
6210 TYPE_FLAGS (type) = 0;
6211 TYPE_LENGTH (type) = 0;
6215 /* An ordinary record type (with fixed-length fields) that describes
6216 the value of type TYPE at VALADDR or ADDRESS (see comments at
6217 the beginning of this section) VAL according to GNAT conventions.
6218 DVAL0 should describe the (portion of a) record that contains any
6219 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
6220 an outer-level type (i.e., as opposed to a branch of a variant.) A
6221 variant field (unless unchecked) is replaced by a particular branch
6223 /* NOTE: Limitations: For now, we assume that dynamic fields and
6224 * variants occupy whole numbers of bytes. However, they need not be
6228 template_to_fixed_record_type (type, valaddr, address, dval0)
6232 struct value* dval0;
6235 struct value* mark = value_mark();
6238 int nfields, bit_len;
6242 nfields = TYPE_NFIELDS (type);
6243 rtype = alloc_type (TYPE_OBJFILE (type));
6244 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6245 INIT_CPLUS_SPECIFIC (rtype);
6246 TYPE_NFIELDS (rtype) = nfields;
6247 TYPE_FIELDS (rtype) = (struct field*)
6248 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6249 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
6250 TYPE_NAME (rtype) = ada_type_name (type);
6251 TYPE_TAG_NAME (rtype) = NULL;
6252 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
6254 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE;*/
6256 off = 0; bit_len = 0;
6257 for (f = 0; f < nfields; f += 1)
6259 int fld_bit_len, bit_incr;
6261 align_value (off, field_alignment (type, f))+TYPE_FIELD_BITPOS (type,f);
6262 /* NOTE: used to use field_offset above, but that causes
6263 * problems with really negative bit positions. So, let's
6264 * rediscover why we needed field_offset and fix it properly. */
6265 TYPE_FIELD_BITPOS (rtype, f) = off;
6266 TYPE_FIELD_BITSIZE (rtype, f) = 0;
6268 if (ada_is_variant_part (type, f))
6270 struct type *branch_type;
6274 value_from_contents_and_address (rtype, valaddr, address);
6279 to_fixed_variant_branch_type
6280 (TYPE_FIELD_TYPE (type, f),
6281 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6282 cond_offset_target (address, off / TARGET_CHAR_BIT),
6284 if (branch_type == NULL)
6285 TYPE_NFIELDS (rtype) -= 1;
6288 TYPE_FIELD_TYPE (rtype, f) = branch_type;
6289 TYPE_FIELD_NAME (rtype, f) = "S";
6293 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6295 else if (is_dynamic_field (type, f))
6299 value_from_contents_and_address (rtype, valaddr, address);
6303 TYPE_FIELD_TYPE (rtype, f) =
6306 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
6307 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6308 cond_offset_target (address, off / TARGET_CHAR_BIT),
6310 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6311 bit_incr = fld_bit_len =
6312 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6316 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
6317 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6318 if (TYPE_FIELD_BITSIZE (type, f) > 0)
6319 bit_incr = fld_bit_len =
6320 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
6322 bit_incr = fld_bit_len =
6323 TYPE_LENGTH (TYPE_FIELD_TYPE (type, f)) * TARGET_CHAR_BIT;
6325 if (off + fld_bit_len > bit_len)
6326 bit_len = off + fld_bit_len;
6328 TYPE_LENGTH (rtype) = bit_len / TARGET_CHAR_BIT;
6330 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype), TYPE_LENGTH (type));
6332 value_free_to_mark (mark);
6333 if (TYPE_LENGTH (rtype) > varsize_limit)
6334 error ("record type with dynamic size is larger than varsize-limit");
6338 /* As for template_to_fixed_record_type, but uses no run-time values.
6339 As a result, this type can only be approximate, but that's OK,
6340 since it is used only for type determinations. Works on both
6342 Representation note: to save space, we memoize the result of this
6343 function in the TYPE_TARGET_TYPE of the template type. */
6346 template_to_static_fixed_type (templ_type)
6347 struct type* templ_type;
6353 if (TYPE_TARGET_TYPE (templ_type) != NULL)
6354 return TYPE_TARGET_TYPE (templ_type);
6356 nfields = TYPE_NFIELDS (templ_type);
6357 TYPE_TARGET_TYPE (templ_type) = type = alloc_type (TYPE_OBJFILE (templ_type));
6358 TYPE_CODE (type) = TYPE_CODE (templ_type);
6359 INIT_CPLUS_SPECIFIC (type);
6360 TYPE_NFIELDS (type) = nfields;
6361 TYPE_FIELDS (type) = (struct field*)
6362 TYPE_ALLOC (type, nfields * sizeof (struct field));
6363 memset (TYPE_FIELDS (type), 0, sizeof (struct field) * nfields);
6364 TYPE_NAME (type) = ada_type_name (templ_type);
6365 TYPE_TAG_NAME (type) = NULL;
6366 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6367 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6368 TYPE_LENGTH (type) = 0;
6370 for (f = 0; f < nfields; f += 1)
6372 TYPE_FIELD_BITPOS (type, f) = 0;
6373 TYPE_FIELD_BITSIZE (type, f) = 0;
6375 if (is_dynamic_field (templ_type, f))
6377 TYPE_FIELD_TYPE (type, f) =
6378 to_static_fixed_type (TYPE_TARGET_TYPE
6379 (TYPE_FIELD_TYPE (templ_type, f)));
6380 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (templ_type, f);
6384 TYPE_FIELD_TYPE (type, f) =
6385 check_typedef (TYPE_FIELD_TYPE (templ_type, f));
6386 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (templ_type, f);
6393 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6394 part -- in which the variant part is replaced with the appropriate
6397 to_record_with_fixed_variant_part (type, valaddr, address, dval)
6403 struct value* mark = value_mark();
6405 struct type *branch_type;
6406 int nfields = TYPE_NFIELDS (type);
6411 rtype = alloc_type (TYPE_OBJFILE (type));
6412 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6413 INIT_CPLUS_SPECIFIC (type);
6414 TYPE_NFIELDS (rtype) = TYPE_NFIELDS (type);
6415 TYPE_FIELDS (rtype) =
6416 (struct field*) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6417 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
6418 sizeof (struct field) * nfields);
6419 TYPE_NAME (rtype) = ada_type_name (type);
6420 TYPE_TAG_NAME (rtype) = NULL;
6421 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6422 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6423 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
6426 to_fixed_variant_branch_type
6427 (TYPE_FIELD_TYPE (type, nfields - 1),
6428 cond_offset_host (valaddr,
6429 TYPE_FIELD_BITPOS (type, nfields-1) / TARGET_CHAR_BIT),
6430 cond_offset_target (address,
6431 TYPE_FIELD_BITPOS (type, nfields-1) / TARGET_CHAR_BIT),
6433 if (branch_type == NULL)
6435 TYPE_NFIELDS (rtype) -= 1;
6436 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, nfields - 1));
6440 TYPE_FIELD_TYPE (rtype, nfields-1) = branch_type;
6441 TYPE_FIELD_NAME (rtype, nfields-1) = "S";
6442 TYPE_FIELD_BITSIZE (rtype, nfields-1) = 0;
6443 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
6444 - TYPE_LENGTH (TYPE_FIELD_TYPE (type, nfields - 1));
6450 /* An ordinary record type (with fixed-length fields) that describes
6451 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6452 beginning of this section]. Any necessary discriminants' values
6453 should be in DVAL, a record value; it should be NULL if the object
6454 at ADDR itself contains any necessary discriminant values. A
6455 variant field (unless unchecked) is replaced by a particular branch
6459 to_fixed_record_type (type0, valaddr, address, dval)
6465 struct type* templ_type;
6467 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6468 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6471 templ_type = dynamic_template_type (type0);
6473 if (templ_type != NULL)
6474 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
6475 else if (contains_variant_part (type0))
6476 return to_record_with_fixed_variant_part (type0, valaddr, address, dval);
6479 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6480 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6486 /* An ordinary record type (with fixed-length fields) that describes
6487 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6488 union type. Any necessary discriminants' values should be in DVAL,
6489 a record value. That is, this routine selects the appropriate
6490 branch of the union at ADDR according to the discriminant value
6491 indicated in the union's type name. */
6494 to_fixed_variant_branch_type (var_type0, valaddr, address, dval)
6495 struct type* var_type0;
6501 struct type* templ_type;
6502 struct type* var_type;
6504 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
6505 var_type = TYPE_TARGET_TYPE (var_type0);
6507 var_type = var_type0;
6509 templ_type = ada_find_parallel_type (var_type, "___XVU");
6511 if (templ_type != NULL)
6512 var_type = templ_type;
6515 ada_which_variant_applies (var_type,
6516 VALUE_TYPE (dval), VALUE_CONTENTS (dval));
6519 return empty_record (TYPE_OBJFILE (var_type));
6520 else if (is_dynamic_field (var_type, which))
6522 to_fixed_record_type
6523 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
6524 valaddr, address, dval);
6525 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type, which)))
6527 to_fixed_record_type
6528 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
6530 return TYPE_FIELD_TYPE (var_type, which);
6533 /* Assuming that TYPE0 is an array type describing the type of a value
6534 at ADDR, and that DVAL describes a record containing any
6535 discriminants used in TYPE0, returns a type for the value that
6536 contains no dynamic components (that is, no components whose sizes
6537 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6538 true, gives an error message if the resulting type's size is over
6543 to_fixed_array_type (type0, dval, ignore_too_big)
6548 struct type* index_type_desc;
6549 struct type* result;
6551 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6552 /* if (ada_is_packed_array_type (type0) /* revisit? */ /*
6553 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6556 index_type_desc = ada_find_parallel_type (type0, "___XA");
6557 if (index_type_desc == NULL)
6559 struct type *elt_type0 = check_typedef (TYPE_TARGET_TYPE (type0));
6560 /* NOTE: elt_type---the fixed version of elt_type0---should never
6561 * depend on the contents of the array in properly constructed
6562 * debugging data. */
6563 struct type *elt_type =
6564 ada_to_fixed_type (elt_type0, 0, 0, dval);
6566 if (elt_type0 == elt_type)
6569 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
6570 elt_type, TYPE_INDEX_TYPE (type0));
6575 struct type *elt_type0;
6578 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
6579 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
6581 /* NOTE: result---the fixed version of elt_type0---should never
6582 * depend on the contents of the array in properly constructed
6583 * debugging data. */
6585 ada_to_fixed_type (check_typedef (elt_type0), 0, 0, dval);
6586 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
6588 struct type *range_type =
6589 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i),
6590 dval, TYPE_OBJFILE (type0));
6591 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
6592 result, range_type);
6594 if (! ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
6595 error ("array type with dynamic size is larger than varsize-limit");
6598 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6599 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6604 /* A standard type (containing no dynamically sized components)
6605 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6606 DVAL describes a record containing any discriminants used in TYPE0,
6607 and may be NULL if there are none. */
6610 ada_to_fixed_type (type, valaddr, address, dval)
6616 CHECK_TYPEDEF (type);
6617 switch (TYPE_CODE (type)) {
6620 case TYPE_CODE_STRUCT:
6621 return to_fixed_record_type (type, valaddr, address, NULL);
6622 case TYPE_CODE_ARRAY:
6623 return to_fixed_array_type (type, dval, 0);
6624 case TYPE_CODE_UNION:
6628 return to_fixed_variant_branch_type (type, valaddr, address, dval);
6632 /* A standard (static-sized) type corresponding as well as possible to
6633 TYPE0, but based on no runtime data. */
6636 to_static_fixed_type (type0)
6644 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6645 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6648 CHECK_TYPEDEF (type0);
6650 switch (TYPE_CODE (type0))
6654 case TYPE_CODE_STRUCT:
6655 type = dynamic_template_type (type0);
6657 return template_to_static_fixed_type (type);
6659 case TYPE_CODE_UNION:
6660 type = ada_find_parallel_type (type0, "___XVU");
6662 return template_to_static_fixed_type (type);
6667 /* A static approximation of TYPE with all type wrappers removed. */
6669 static_unwrap_type (type)
6672 if (ada_is_aligner_type (type))
6674 struct type* type1 = TYPE_FIELD_TYPE (check_typedef (type), 0);
6675 if (ada_type_name (type1) == NULL)
6676 TYPE_NAME (type1) = ada_type_name (type);
6678 return static_unwrap_type (type1);
6682 struct type* raw_real_type = ada_get_base_type (type);
6683 if (raw_real_type == type)
6686 return to_static_fixed_type (raw_real_type);
6690 /* In some cases, incomplete and private types require
6691 cross-references that are not resolved as records (for example,
6693 type FooP is access Foo;
6695 type Foo is array ...;
6696 ). In these cases, since there is no mechanism for producing
6697 cross-references to such types, we instead substitute for FooP a
6698 stub enumeration type that is nowhere resolved, and whose tag is
6699 the name of the actual type. Call these types "non-record stubs". */
6701 /* A type equivalent to TYPE that is not a non-record stub, if one
6702 exists, otherwise TYPE. */
6704 ada_completed_type (type)
6707 CHECK_TYPEDEF (type);
6708 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
6709 || (TYPE_FLAGS (type) & TYPE_FLAG_STUB) == 0
6710 || TYPE_TAG_NAME (type) == NULL)
6714 char* name = TYPE_TAG_NAME (type);
6715 struct type* type1 = ada_find_any_type (name);
6716 return (type1 == NULL) ? type : type1;
6720 /* A value representing the data at VALADDR/ADDRESS as described by
6721 type TYPE0, but with a standard (static-sized) type that correctly
6722 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6723 type, then return VAL0 [this feature is simply to avoid redundant
6724 creation of struct values]. */
6727 ada_to_fixed_value (type0, valaddr, address, val0)
6733 struct type* type = ada_to_fixed_type (type0, valaddr, address, NULL);
6734 if (type == type0 && val0 != NULL)
6736 else return value_from_contents_and_address (type, valaddr, address);
6739 /* A value representing VAL, but with a standard (static-sized) type
6740 chosen to approximate the real type of VAL as well as possible, but
6741 without consulting any runtime values. For Ada dynamic-sized
6742 types, therefore, the type of the result is likely to be inaccurate. */
6745 ada_to_static_fixed_value (val)
6749 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val)));
6750 if (type == VALUE_TYPE (val))
6753 return coerce_unspec_val_to_type (val, 0, type);
6762 /* Table mapping attribute numbers to names */
6763 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6765 static const char* attribute_names[] = {
6783 ada_attribute_name (n)
6786 if (n > 0 && n < (int) ATR_END)
6787 return attribute_names[n];
6789 return attribute_names[0];
6792 /* Evaluate the 'POS attribute applied to ARG. */
6794 static struct value*
6798 struct type *type = VALUE_TYPE (arg);
6800 if (! discrete_type_p (type))
6801 error ("'POS only defined on discrete types");
6803 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
6806 LONGEST v = value_as_long (arg);
6808 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6810 if (v == TYPE_FIELD_BITPOS (type, i))
6811 return value_from_longest (builtin_type_ada_int, i);
6813 error ("enumeration value is invalid: can't find 'POS");
6816 return value_from_longest (builtin_type_ada_int, value_as_long (arg));
6819 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6821 static struct value*
6822 value_val_atr (type, arg)
6826 if (! discrete_type_p (type))
6827 error ("'VAL only defined on discrete types");
6828 if (! integer_type_p (VALUE_TYPE (arg)))
6829 error ("'VAL requires integral argument");
6831 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
6833 long pos = value_as_long (arg);
6834 if (pos < 0 || pos >= TYPE_NFIELDS (type))
6835 error ("argument to 'VAL out of range");
6837 value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
6840 return value_from_longest (type, value_as_long (arg));
6846 /* True if TYPE appears to be an Ada character type.
6847 * [At the moment, this is true only for Character and Wide_Character;
6848 * It is a heuristic test that could stand improvement]. */
6851 ada_is_character_type (type)
6854 const char* name = ada_type_name (type);
6857 && (TYPE_CODE (type) == TYPE_CODE_CHAR
6858 || TYPE_CODE (type) == TYPE_CODE_INT
6859 || TYPE_CODE (type) == TYPE_CODE_RANGE)
6860 && (STREQ (name, "character") || STREQ (name, "wide_character")
6861 || STREQ (name, "unsigned char"));
6864 /* True if TYPE appears to be an Ada string type. */
6867 ada_is_string_type (type)
6870 CHECK_TYPEDEF (type);
6872 && TYPE_CODE (type) != TYPE_CODE_PTR
6873 && (ada_is_simple_array (type) || ada_is_array_descriptor (type))
6874 && ada_array_arity (type) == 1)
6876 struct type *elttype = ada_array_element_type (type, 1);
6878 return ada_is_character_type (elttype);
6885 /* True if TYPE is a struct type introduced by the compiler to force the
6886 alignment of a value. Such types have a single field with a
6887 distinctive name. */
6890 ada_is_aligner_type (type)
6893 CHECK_TYPEDEF (type);
6894 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
6895 && TYPE_NFIELDS (type) == 1
6896 && STREQ (TYPE_FIELD_NAME (type, 0), "F"));
6899 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6900 the parallel type. */
6903 ada_get_base_type (raw_type)
6904 struct type* raw_type;
6906 struct type* real_type_namer;
6907 struct type* raw_real_type;
6908 struct type* real_type;
6910 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
6913 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
6914 if (real_type_namer == NULL
6915 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
6916 || TYPE_NFIELDS (real_type_namer) != 1)
6919 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
6920 if (raw_real_type == NULL)
6923 return raw_real_type;
6926 /* The type of value designated by TYPE, with all aligners removed. */
6929 ada_aligned_type (type)
6932 if (ada_is_aligner_type (type))
6933 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
6935 return ada_get_base_type (type);
6939 /* The address of the aligned value in an object at address VALADDR
6940 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6943 ada_aligned_value_addr (type, valaddr)
6947 if (ada_is_aligner_type (type))
6948 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
6950 TYPE_FIELD_BITPOS (type, 0)/TARGET_CHAR_BIT);
6955 /* The printed representation of an enumeration literal with encoded
6956 name NAME. The value is good to the next call of ada_enum_name. */
6958 ada_enum_name (name)
6965 if ((tmp = strstr (name, "__")) != NULL)
6967 else if ((tmp = strchr (name, '.')) != NULL)
6975 static char result[16];
6977 if (name[1] == 'U' || name[1] == 'W')
6979 if (sscanf (name+2, "%x", &v) != 1)
6985 if (isascii (v) && isprint (v))
6986 sprintf (result, "'%c'", v);
6987 else if (name[1] == 'U')
6988 sprintf (result, "[\"%02x\"]", v);
6990 sprintf (result, "[\"%04x\"]", v);
6998 static struct value*
6999 evaluate_subexp (expect_type, exp, pos, noside)
7000 struct type *expect_type;
7001 struct expression *exp;
7005 return (*exp->language_defn->evaluate_exp) (expect_type, exp, pos, noside);
7008 /* Evaluate the subexpression of EXP starting at *POS as for
7009 evaluate_type, updating *POS to point just past the evaluated
7012 static struct value*
7013 evaluate_subexp_type (exp, pos)
7014 struct expression* exp;
7017 return (*exp->language_defn->evaluate_exp)
7018 (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
7021 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7024 static struct value*
7028 struct type* type = check_typedef (VALUE_TYPE (val));
7029 if (ada_is_aligner_type (type))
7031 struct value* v = value_struct_elt (&val, NULL, "F",
7032 NULL, "internal structure");
7033 struct type* val_type = check_typedef (VALUE_TYPE (v));
7034 if (ada_type_name (val_type) == NULL)
7035 TYPE_NAME (val_type) = ada_type_name (type);
7037 return unwrap_value (v);
7041 struct type* raw_real_type =
7042 ada_completed_type (ada_get_base_type (type));
7044 if (type == raw_real_type)
7048 coerce_unspec_val_to_type
7049 (val, 0, ada_to_fixed_type (raw_real_type, 0,
7050 VALUE_ADDRESS (val) + VALUE_OFFSET (val),
7055 static struct value*
7056 cast_to_fixed (type, arg)
7062 if (type == VALUE_TYPE (arg))
7064 else if (ada_is_fixed_point_type (VALUE_TYPE (arg)))
7065 val = ada_float_to_fixed (type,
7066 ada_fixed_to_float (VALUE_TYPE (arg),
7067 value_as_long (arg)));
7071 value_as_double (value_cast (builtin_type_double, value_copy (arg)));
7072 val = ada_float_to_fixed (type, argd);
7075 return value_from_longest (type, val);
7078 static struct value*
7079 cast_from_fixed_to_double (arg)
7082 DOUBLEST val = ada_fixed_to_float (VALUE_TYPE (arg),
7083 value_as_long (arg));
7084 return value_from_double (builtin_type_double, val);
7087 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7088 * return the converted value. */
7089 static struct value*
7090 coerce_for_assign (type, val)
7094 struct type* type2 = VALUE_TYPE (val);
7098 CHECK_TYPEDEF (type2);
7099 CHECK_TYPEDEF (type);
7101 if (TYPE_CODE (type2) == TYPE_CODE_PTR && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7103 val = ada_value_ind (val);
7104 type2 = VALUE_TYPE (val);
7107 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
7108 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7110 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
7111 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
7112 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
7113 error ("Incompatible types in assignment");
7114 VALUE_TYPE (val) = type;
7120 ada_evaluate_subexp (expect_type, exp, pos, noside)
7121 struct type *expect_type;
7122 struct expression *exp;
7127 enum ada_attribute atr;
7128 int tem, tem2, tem3;
7130 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
7133 struct value* *argvec;
7135 pc = *pos; *pos += 1;
7136 op = exp->elts[pc].opcode;
7142 return unwrap_value (evaluate_subexp_standard (expect_type, exp, pos, noside));
7146 type = exp->elts[pc + 1].type;
7147 arg1 = evaluate_subexp (type, exp, pos, noside);
7148 if (noside == EVAL_SKIP)
7150 if (type != check_typedef (VALUE_TYPE (arg1)))
7152 if (ada_is_fixed_point_type (type))
7153 arg1 = cast_to_fixed (type, arg1);
7154 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
7155 arg1 = value_cast (type, cast_from_fixed_to_double (arg1));
7156 else if (VALUE_LVAL (arg1) == lval_memory)
7158 /* This is in case of the really obscure (and undocumented,
7159 but apparently expected) case of (Foo) Bar.all, where Bar
7160 is an integer constant and Foo is a dynamic-sized type.
7161 If we don't do this, ARG1 will simply be relabeled with
7163 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7164 return value_zero (to_static_fixed_type (type), not_lval);
7167 (type, 0, VALUE_ADDRESS (arg1) + VALUE_OFFSET (arg1), 0);
7170 arg1 = value_cast (type, arg1);
7174 /* FIXME: UNOP_QUAL should be defined in expression.h */
7177 type = exp->elts[pc + 1].type;
7178 return ada_evaluate_subexp (type, exp, pos, noside);
7181 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7182 arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
7183 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
7185 if (binop_user_defined_p (op, arg1, arg2))
7186 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
7189 if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
7190 arg2 = cast_to_fixed (VALUE_TYPE (arg1), arg2);
7191 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
7192 error ("Fixed-point values must be assigned to fixed-point variables");
7194 arg2 = coerce_for_assign (VALUE_TYPE (arg1), arg2);
7195 return ada_value_assign (arg1, arg2);
7199 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
7200 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
7201 if (noside == EVAL_SKIP)
7203 if (binop_user_defined_p (op, arg1, arg2))
7204 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
7207 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
7208 || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
7209 && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
7210 error ("Operands of fixed-point addition must have the same type");
7211 return value_cast (VALUE_TYPE (arg1), value_add (arg1, arg2));
7215 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
7216 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
7217 if (noside == EVAL_SKIP)
7219 if (binop_user_defined_p (op, arg1, arg2))
7220 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
7223 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
7224 || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
7225 && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
7226 error ("Operands of fixed-point subtraction must have the same type");
7227 return value_cast (VALUE_TYPE (arg1), value_sub (arg1, arg2));
7232 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7233 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7234 if (noside == EVAL_SKIP)
7236 if (binop_user_defined_p (op, arg1, arg2))
7237 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
7239 if (noside == EVAL_AVOID_SIDE_EFFECTS
7240 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
7241 return value_zero (VALUE_TYPE (arg1), not_lval);
7244 if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
7245 arg1 = cast_from_fixed_to_double (arg1);
7246 if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
7247 arg2 = cast_from_fixed_to_double (arg2);
7248 return value_binop (arg1, arg2, op);
7252 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7253 if (noside == EVAL_SKIP)
7255 if (unop_user_defined_p (op, arg1))
7256 return value_x_unop (arg1, op, EVAL_NORMAL);
7257 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
7258 return value_cast (VALUE_TYPE (arg1), value_neg (arg1));
7260 return value_neg (arg1);
7262 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7263 /* case OP_UNRESOLVED_VALUE:
7264 /* Only encountered when an unresolved symbol occurs in a
7265 context other than a function call, in which case, it is
7268 if (noside == EVAL_SKIP)
7271 error ("Unexpected unresolved symbol, %s, during evaluation",
7272 ada_demangle (exp->elts[pc + 2].name));
7276 if (noside == EVAL_SKIP)
7281 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7285 (to_static_fixed_type
7286 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc+2].symbol))),
7291 arg1 = unwrap_value (evaluate_subexp_standard (expect_type, exp, pos,
7293 return ada_to_fixed_value (VALUE_TYPE (arg1), 0,
7294 VALUE_ADDRESS (arg1) + VALUE_OFFSET(arg1),
7300 tem2 = longest_to_int (exp->elts[pc + 1].longconst);
7301 tem3 = longest_to_int (exp->elts[pc + 2].longconst);
7302 nargs = tem3 - tem2 + 1;
7303 type = expect_type ? check_typedef (expect_type) : NULL_TYPE;
7305 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
7306 for (tem = 0; tem == 0 || tem < nargs; tem += 1)
7307 /* At least one element gets inserted for the type */
7309 /* Ensure that array expressions are coerced into pointer objects. */
7310 argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside);
7312 if (noside == EVAL_SKIP)
7314 return value_array (tem2, tem3, argvec);
7319 /* Allocate arg vector, including space for the function to be
7320 called in argvec[0] and a terminating NULL */
7321 nargs = longest_to_int (exp->elts[pc + 1].longconst);
7322 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 2));
7324 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7325 /* FIXME: name should be defined in expresion.h */
7326 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7327 error ("Unexpected unresolved symbol, %s, during evaluation",
7328 ada_demangle (exp->elts[pc + 5].name));
7332 error ("unexpected code path, FIXME");
7336 for (tem = 0; tem <= nargs; tem += 1)
7337 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7340 if (noside == EVAL_SKIP)
7344 if (TYPE_CODE (VALUE_TYPE (argvec[0])) == TYPE_CODE_REF)
7345 argvec[0] = value_addr (argvec[0]);
7347 if (ada_is_packed_array_type (VALUE_TYPE (argvec[0])))
7348 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
7350 type = check_typedef (VALUE_TYPE (argvec[0]));
7351 if (TYPE_CODE (type) == TYPE_CODE_PTR)
7353 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type))))
7355 case TYPE_CODE_FUNC:
7356 type = check_typedef (TYPE_TARGET_TYPE (type));
7358 case TYPE_CODE_ARRAY:
7360 case TYPE_CODE_STRUCT:
7361 if (noside != EVAL_AVOID_SIDE_EFFECTS)
7362 argvec[0] = ada_value_ind (argvec[0]);
7363 type = check_typedef (TYPE_TARGET_TYPE (type));
7366 error ("cannot subscript or call something of type `%s'",
7367 ada_type_name (VALUE_TYPE (argvec[0])));
7372 switch (TYPE_CODE (type))
7374 case TYPE_CODE_FUNC:
7375 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7376 return allocate_value (TYPE_TARGET_TYPE (type));
7377 return call_function_by_hand (argvec[0], nargs, argvec + 1);
7378 case TYPE_CODE_STRUCT:
7380 int arity = ada_array_arity (type);
7381 type = ada_array_element_type (type, nargs);
7383 error ("cannot subscript or call a record");
7385 error ("wrong number of subscripts; expecting %d", arity);
7386 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7387 return allocate_value (ada_aligned_type (type));
7388 return unwrap_value (ada_value_subscript (argvec[0], nargs, argvec+1));
7390 case TYPE_CODE_ARRAY:
7391 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7393 type = ada_array_element_type (type, nargs);
7395 error ("element type of array unknown");
7397 return allocate_value (ada_aligned_type (type));
7400 unwrap_value (ada_value_subscript
7401 (ada_coerce_to_simple_array (argvec[0]),
7403 case TYPE_CODE_PTR: /* Pointer to array */
7404 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
7405 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7407 type = ada_array_element_type (type, nargs);
7409 error ("element type of array unknown");
7411 return allocate_value (ada_aligned_type (type));
7414 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
7418 error ("Internal error in evaluate_subexp");
7423 struct value* array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7425 = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
7427 = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
7428 if (noside == EVAL_SKIP)
7431 /* If this is a reference to an array, then dereference it */
7432 if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_REF
7433 && TYPE_TARGET_TYPE (VALUE_TYPE (array)) != NULL
7434 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array))) ==
7436 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE
7439 array = ada_coerce_ref (array);
7442 if (noside == EVAL_AVOID_SIDE_EFFECTS &&
7443 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array))))
7445 /* Try to dereference the array, in case it is an access to array */
7446 struct type * arrType = ada_type_of_array (array, 0);
7447 if (arrType != NULL)
7448 array = value_at_lazy (arrType, 0, NULL);
7450 if (ada_is_array_descriptor (VALUE_TYPE (array)))
7451 array = ada_coerce_to_simple_array (array);
7453 /* If at this point we have a pointer to an array, it means that
7454 it is a pointer to a simple (non-ada) array. We just then
7456 if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_PTR
7457 && TYPE_TARGET_TYPE (VALUE_TYPE (array)) != NULL
7458 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array))) ==
7461 array = ada_value_ind (array);
7464 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7465 /* The following will get the bounds wrong, but only in contexts
7466 where the value is not being requested (FIXME?). */
7469 return value_slice (array, lowbound, upper - lowbound + 1);
7472 /* FIXME: UNOP_MBR should be defined in expression.h */
7475 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7476 type = exp->elts[pc + 1].type;
7478 if (noside == EVAL_SKIP)
7481 switch (TYPE_CODE (type))
7484 warning ("Membership test incompletely implemented; always returns true");
7485 return value_from_longest (builtin_type_int, (LONGEST) 1);
7487 case TYPE_CODE_RANGE:
7488 arg2 = value_from_longest (builtin_type_int,
7489 (LONGEST) TYPE_LOW_BOUND (type));
7490 arg3 = value_from_longest (builtin_type_int,
7491 (LONGEST) TYPE_HIGH_BOUND (type));
7493 value_from_longest (builtin_type_int,
7494 (value_less (arg1,arg3)
7495 || value_equal (arg1,arg3))
7496 && (value_less (arg2,arg1)
7497 || value_equal (arg2,arg1)));
7500 /* FIXME: BINOP_MBR should be defined in expression.h */
7503 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7504 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7506 if (noside == EVAL_SKIP)
7509 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7510 return value_zero (builtin_type_int, not_lval);
7512 tem = longest_to_int (exp->elts[pc + 1].longconst);
7514 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7515 error ("invalid dimension number to '%s", "range");
7517 arg3 = ada_array_bound (arg2, tem, 1);
7518 arg2 = ada_array_bound (arg2, tem, 0);
7521 value_from_longest (builtin_type_int,
7522 (value_less (arg1,arg3)
7523 || value_equal (arg1,arg3))
7524 && (value_less (arg2,arg1)
7525 || value_equal (arg2,arg1)));
7527 /* FIXME: TERNOP_MBR should be defined in expression.h */
7529 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7530 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7531 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7533 if (noside == EVAL_SKIP)
7537 value_from_longest (builtin_type_int,
7538 (value_less (arg1,arg3)
7539 || value_equal (arg1,arg3))
7540 && (value_less (arg2,arg1)
7541 || value_equal (arg2,arg1)));
7543 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7544 /* case OP_ATTRIBUTE:
7546 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7550 error ("unexpected attribute encountered");
7556 struct type* type_arg;
7557 if (exp->elts[*pos].opcode == OP_TYPE)
7559 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7561 type_arg = exp->elts[pc + 5].type;
7565 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7569 if (exp->elts[*pos].opcode != OP_LONG)
7570 error ("illegal operand to '%s", ada_attribute_name (atr));
7571 tem = longest_to_int (exp->elts[*pos+2].longconst);
7574 if (noside == EVAL_SKIP)
7577 if (type_arg == NULL)
7579 arg1 = ada_coerce_ref (arg1);
7581 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7582 arg1 = ada_coerce_to_simple_array (arg1);
7584 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7585 error ("invalid dimension number to '%s",
7586 ada_attribute_name (atr));
7588 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7590 type = ada_index_type (VALUE_TYPE (arg1), tem);
7592 error ("attempt to take bound of something that is not an array");
7593 return allocate_value (type);
7599 error ("unexpected attribute encountered");
7601 return ada_array_bound (arg1, tem, 0);
7603 return ada_array_bound (arg1, tem, 1);
7605 return ada_array_length (arg1, tem);
7608 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7609 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7611 struct type* range_type;
7612 char* name = ada_type_name (type_arg);
7615 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7616 range_type = type_arg;
7618 error ("unimplemented type attribute");
7622 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7626 error ("unexpected attribute encountered");
7628 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7629 TYPE_LOW_BOUND (range_type));
7631 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7632 TYPE_HIGH_BOUND (range_type));
7635 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7640 error ("unexpected attribute encountered");
7642 return value_from_longest
7643 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7645 return value_from_longest
7647 TYPE_FIELD_BITPOS (type_arg,
7648 TYPE_NFIELDS (type_arg) - 1));
7651 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7652 error ("unimplemented type attribute");
7657 if (ada_is_packed_array_type (type_arg))
7658 type_arg = decode_packed_array_type (type_arg);
7660 if (tem < 1 || tem > ada_array_arity (type_arg))
7661 error ("invalid dimension number to '%s",
7662 ada_attribute_name (atr));
7664 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7666 type = ada_index_type (type_arg, tem);
7668 error ("attempt to take bound of something that is not an array");
7669 return allocate_value (type);
7675 error ("unexpected attribute encountered");
7677 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7678 return value_from_longest (type, low);
7680 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7681 return value_from_longest (type, high);
7683 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7684 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7685 return value_from_longest (type, high-low+1);
7691 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7692 if (noside == EVAL_SKIP)
7695 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7697 value_zero (ada_tag_type (arg1), not_lval);
7699 return ada_value_tag (arg1);
7703 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7704 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7705 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7706 if (noside == EVAL_SKIP)
7708 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7709 return value_zero (VALUE_TYPE (arg1), not_lval);
7711 return value_binop (arg1, arg2,
7712 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7716 struct type* type_arg = exp->elts[pc + 5].type;
7717 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7720 if (noside == EVAL_SKIP)
7723 if (! ada_is_modular_type (type_arg))
7724 error ("'modulus must be applied to modular type");
7726 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7727 ada_modulus (type_arg));
7732 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7733 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7734 if (noside == EVAL_SKIP)
7736 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7737 return value_zero (builtin_type_ada_int, not_lval);
7739 return value_pos_atr (arg1);
7742 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7743 if (noside == EVAL_SKIP)
7745 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7746 return value_zero (builtin_type_ada_int, not_lval);
7748 return value_from_longest (builtin_type_ada_int,
7750 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7753 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7754 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7755 type = exp->elts[pc + 5].type;
7756 if (noside == EVAL_SKIP)
7758 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7759 return value_zero (type, not_lval);
7761 return value_val_atr (type, arg1);
7764 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7765 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7766 if (noside == EVAL_SKIP)
7768 if (binop_user_defined_p (op, arg1, arg2))
7769 return unwrap_value (value_x_binop (arg1, arg2, op, OP_NULL,
7772 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7773 return value_zero (VALUE_TYPE (arg1), not_lval);
7775 return value_binop (arg1, arg2, op);
7778 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7779 if (noside == EVAL_SKIP)
7781 if (unop_user_defined_p (op, arg1))
7782 return unwrap_value (value_x_unop (arg1, op, EVAL_NORMAL));
7787 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7788 if (noside == EVAL_SKIP)
7790 if (value_less (arg1, value_zero (VALUE_TYPE (arg1), not_lval)))
7791 return value_neg (arg1);
7796 if (expect_type && TYPE_CODE (expect_type) == TYPE_CODE_PTR)
7797 expect_type = TYPE_TARGET_TYPE (check_typedef (expect_type));
7798 arg1 = evaluate_subexp (expect_type, exp, pos, noside);
7799 if (noside == EVAL_SKIP)
7801 type = check_typedef (VALUE_TYPE (arg1));
7802 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7804 if (ada_is_array_descriptor (type))
7805 /* GDB allows dereferencing GNAT array descriptors. */
7807 struct type* arrType = ada_type_of_array (arg1, 0);
7808 if (arrType == NULL)
7809 error ("Attempt to dereference null array pointer.");
7810 return value_at_lazy (arrType, 0, NULL);
7812 else if (TYPE_CODE (type) == TYPE_CODE_PTR
7813 || TYPE_CODE (type) == TYPE_CODE_REF
7814 /* In C you can dereference an array to get the 1st elt. */
7815 || TYPE_CODE (type) == TYPE_CODE_ARRAY
7819 (to_static_fixed_type
7820 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type)))),
7822 else if (TYPE_CODE (type) == TYPE_CODE_INT)
7823 /* GDB allows dereferencing an int. */
7824 return value_zero (builtin_type_int, lval_memory);
7826 error ("Attempt to take contents of a non-pointer value.");
7828 arg1 = ada_coerce_ref (arg1);
7829 type = check_typedef (VALUE_TYPE (arg1));
7831 if (ada_is_array_descriptor (type))
7832 /* GDB allows dereferencing GNAT array descriptors. */
7833 return ada_coerce_to_simple_array (arg1);
7835 return ada_value_ind (arg1);
7837 case STRUCTOP_STRUCT:
7838 tem = longest_to_int (exp->elts[pc + 1].longconst);
7839 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
7840 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7841 if (noside == EVAL_SKIP)
7843 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7844 return value_zero (ada_aligned_type
7845 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1),
7846 &exp->elts[pc + 2].string,
7850 return unwrap_value (ada_value_struct_elt (arg1,
7851 &exp->elts[pc + 2].string,
7854 /* The value is not supposed to be used. This is here to make it
7855 easier to accommodate expressions that contain types. */
7857 if (noside == EVAL_SKIP)
7859 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7860 return allocate_value (builtin_type_void);
7862 error ("Attempt to use a type name as an expression");
7865 tem = longest_to_int (exp->elts[pc + 1].longconst);
7866 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
7867 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7868 if (noside == EVAL_SKIP)
7870 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7871 return value_zero (ada_aligned_type
7872 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1),
7873 &exp->elts[pc + 2].string,
7877 return unwrap_value (ada_value_struct_elt (arg1,
7878 &exp->elts[pc + 2].string,
7883 return value_from_longest (builtin_type_long, (LONGEST) 1);
7889 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7890 type name that encodes the 'small and 'delta information.
7891 Otherwise, return NULL. */
7894 fixed_type_info (type)
7897 const char* name = ada_type_name (type);
7898 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
7900 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE)
7903 const char *tail = strstr (name, "___XF_");
7909 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
7910 return fixed_type_info (TYPE_TARGET_TYPE (type));
7915 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7918 ada_is_fixed_point_type (type)
7921 return fixed_type_info (type) != NULL;
7924 /* Assuming that TYPE is the representation of an Ada fixed-point
7925 type, return its delta, or -1 if the type is malformed and the
7926 delta cannot be determined. */
7932 const char *encoding = fixed_type_info (type);
7935 if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
7938 return (DOUBLEST) num / (DOUBLEST) den;
7941 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7942 factor ('SMALL value) associated with the type. */
7945 scaling_factor (type)
7948 const char *encoding = fixed_type_info (type);
7949 unsigned long num0, den0, num1, den1;
7952 n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);
7957 return (DOUBLEST) num1 / (DOUBLEST) den1;
7959 return (DOUBLEST) num0 / (DOUBLEST) den0;
7963 /* Assuming that X is the representation of a value of fixed-point
7964 type TYPE, return its floating-point equivalent. */
7967 ada_fixed_to_float (type, x)
7971 return (DOUBLEST) x * scaling_factor (type);
7974 /* The representation of a fixed-point value of type TYPE
7975 corresponding to the value X. */
7978 ada_float_to_fixed (type, x)
7982 return (LONGEST) (x / scaling_factor (type) + 0.5);
7986 /* VAX floating formats */
7988 /* Non-zero iff TYPE represents one of the special VAX floating-point
7991 ada_is_vax_floating_type (type)
7995 (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
7998 && (TYPE_CODE (type) == TYPE_CODE_INT
7999 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8000 && STREQN (ada_type_name (type) + name_len - 6, "___XF", 5);
8003 /* The type of special VAX floating-point type this is, assuming
8004 ada_is_vax_floating_point */
8006 ada_vax_float_type_suffix (type)
8009 return ada_type_name (type)[strlen (ada_type_name (type))-1];
8012 /* A value representing the special debugging function that outputs
8013 VAX floating-point values of the type represented by TYPE. Assumes
8014 ada_is_vax_floating_type (TYPE). */
8016 ada_vax_float_print_function (type)
8020 switch (ada_vax_float_type_suffix (type)) {
8023 get_var_value ("DEBUG_STRING_F", 0);
8026 get_var_value ("DEBUG_STRING_D", 0);
8029 get_var_value ("DEBUG_STRING_G", 0);
8031 error ("invalid VAX floating-point type");
8038 /* Scan STR beginning at position K for a discriminant name, and
8039 return the value of that discriminant field of DVAL in *PX. If
8040 PNEW_K is not null, put the position of the character beyond the
8041 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
8042 not alter *PX and *PNEW_K if unsuccessful. */
8045 scan_discrim_bound (str, k, dval, px, pnew_k)
8052 static char *bound_buffer = NULL;
8053 static size_t bound_buffer_len = 0;
8056 struct value* bound_val;
8058 if (dval == NULL || str == NULL || str[k] == '\0')
8061 pend = strstr (str+k, "__");
8065 k += strlen (bound);
8069 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str+k) + 1);
8070 bound = bound_buffer;
8071 strncpy (bound_buffer, str+k, pend-(str+k));
8072 bound[pend-(str+k)] = '\0';
8077 ada_search_struct_field (bound, dval, 0, VALUE_TYPE (dval));
8078 if (bound_val == NULL)
8081 *px = value_as_long (bound_val);
8087 /* Value of variable named NAME in the current environment. If
8088 no such variable found, then if ERR_MSG is null, returns 0, and
8089 otherwise causes an error with message ERR_MSG. */
8090 static struct value*
8091 get_var_value (name, err_msg)
8095 struct symbol** syms;
8096 struct block** blocks;
8099 nsyms = ada_lookup_symbol_list (name, get_selected_block (NULL), VAR_NAMESPACE,
8104 if (err_msg == NULL)
8107 error ("%s", err_msg);
8110 return value_of_variable (syms[0], blocks[0]);
8113 /* Value of integer variable named NAME in the current environment. If
8114 no such variable found, then if ERR_MSG is null, returns 0, and sets
8115 *FLAG to 0. If successful, sets *FLAG to 1. */
8117 get_int_var_value (name, err_msg, flag)
8122 struct value* var_val = get_var_value (name, err_msg);
8134 return value_as_long (var_val);
8139 /* Return a range type whose base type is that of the range type named
8140 NAME in the current environment, and whose bounds are calculated
8141 from NAME according to the GNAT range encoding conventions.
8142 Extract discriminant values, if needed, from DVAL. If a new type
8143 must be created, allocate in OBJFILE's space. The bounds
8144 information, in general, is encoded in NAME, the base type given in
8145 the named range type. */
8148 to_fixed_range_type (name, dval, objfile)
8151 struct objfile *objfile;
8153 struct type *raw_type = ada_find_any_type (name);
8154 struct type *base_type;
8158 if (raw_type == NULL)
8159 base_type = builtin_type_int;
8160 else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
8161 base_type = TYPE_TARGET_TYPE (raw_type);
8163 base_type = raw_type;
8165 subtype_info = strstr (name, "___XD");
8166 if (subtype_info == NULL)
8170 static char *name_buf = NULL;
8171 static size_t name_len = 0;
8172 int prefix_len = subtype_info - name;
8178 GROW_VECT (name_buf, name_len, prefix_len + 5);
8179 strncpy (name_buf, name, prefix_len);
8180 name_buf[prefix_len] = '\0';
8183 bounds_str = strchr (subtype_info, '_');
8186 if (*subtype_info == 'L')
8188 if (! ada_scan_number (bounds_str, n, &L, &n)
8189 && ! scan_discrim_bound (bounds_str, n, dval, &L, &n))
8191 if (bounds_str[n] == '_')
8193 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
8199 strcpy (name_buf+prefix_len, "___L");
8200 L = get_int_var_value (name_buf, "Index bound unknown.", NULL);
8203 if (*subtype_info == 'U')
8205 if (! ada_scan_number (bounds_str, n, &U, &n)
8206 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
8211 strcpy (name_buf+prefix_len, "___U");
8212 U = get_int_var_value (name_buf, "Index bound unknown.", NULL);
8215 if (objfile == NULL)
8216 objfile = TYPE_OBJFILE (base_type);
8217 type = create_range_type (alloc_type (objfile), base_type, L, U);
8218 TYPE_NAME (type) = name;
8223 /* True iff NAME is the name of a range type. */
8225 ada_is_range_type_name (name)
8228 return (name != NULL && strstr (name, "___XD"));
8234 /* True iff TYPE is an Ada modular type. */
8236 ada_is_modular_type (type)
8239 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
8241 struct type* subranged_type; /* = base_type (type);*/
8243 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
8244 && TYPE_CODE (subranged_type) != TYPE_CODE_ENUM
8245 && TYPE_UNSIGNED (subranged_type));
8248 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
8253 return TYPE_HIGH_BOUND (type) + 1;
8260 /* Table mapping opcodes into strings for printing operators
8261 and precedences of the operators. */
8263 static const struct op_print ada_op_print_tab[] =
8265 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
8266 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
8267 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
8268 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
8269 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
8270 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
8271 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
8272 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
8273 {"<=", BINOP_LEQ, PREC_ORDER, 0},
8274 {">=", BINOP_GEQ, PREC_ORDER, 0},
8275 {">", BINOP_GTR, PREC_ORDER, 0},
8276 {"<", BINOP_LESS, PREC_ORDER, 0},
8277 {">>", BINOP_RSH, PREC_SHIFT, 0},
8278 {"<<", BINOP_LSH, PREC_SHIFT, 0},
8279 {"+", BINOP_ADD, PREC_ADD, 0},
8280 {"-", BINOP_SUB, PREC_ADD, 0},
8281 {"&", BINOP_CONCAT, PREC_ADD, 0},
8282 {"*", BINOP_MUL, PREC_MUL, 0},
8283 {"/", BINOP_DIV, PREC_MUL, 0},
8284 {"rem", BINOP_REM, PREC_MUL, 0},
8285 {"mod", BINOP_MOD, PREC_MUL, 0},
8286 {"**", BINOP_EXP, PREC_REPEAT, 0 },
8287 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
8288 {"-", UNOP_NEG, PREC_PREFIX, 0},
8289 {"+", UNOP_PLUS, PREC_PREFIX, 0},
8290 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
8291 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
8292 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
8293 {".all", UNOP_IND, PREC_SUFFIX, 1}, /* FIXME: postfix .ALL */
8294 {"'access", UNOP_ADDR, PREC_SUFFIX, 1}, /* FIXME: postfix 'ACCESS */
8298 /* Assorted Types and Interfaces */
8300 struct type* builtin_type_ada_int;
8301 struct type* builtin_type_ada_short;
8302 struct type* builtin_type_ada_long;
8303 struct type* builtin_type_ada_long_long;
8304 struct type* builtin_type_ada_char;
8305 struct type* builtin_type_ada_float;
8306 struct type* builtin_type_ada_double;
8307 struct type* builtin_type_ada_long_double;
8308 struct type* builtin_type_ada_natural;
8309 struct type* builtin_type_ada_positive;
8310 struct type* builtin_type_ada_system_address;
8312 struct type ** const (ada_builtin_types[]) =
8315 &builtin_type_ada_int,
8316 &builtin_type_ada_long,
8317 &builtin_type_ada_short,
8318 &builtin_type_ada_char,
8319 &builtin_type_ada_float,
8320 &builtin_type_ada_double,
8321 &builtin_type_ada_long_long,
8322 &builtin_type_ada_long_double,
8323 &builtin_type_ada_natural,
8324 &builtin_type_ada_positive,
8326 /* The following types are carried over from C for convenience. */
8329 &builtin_type_short,
8331 &builtin_type_float,
8332 &builtin_type_double,
8333 &builtin_type_long_long,
8335 &builtin_type_signed_char,
8336 &builtin_type_unsigned_char,
8337 &builtin_type_unsigned_short,
8338 &builtin_type_unsigned_int,
8339 &builtin_type_unsigned_long,
8340 &builtin_type_unsigned_long_long,
8341 &builtin_type_long_double,
8342 &builtin_type_complex,
8343 &builtin_type_double_complex,
8347 /* Not really used, but needed in the ada_language_defn. */
8348 static void emit_char (int c, struct ui_file* stream, int quoter)
8350 ada_emit_char (c, stream, quoter, 1);
8353 const struct language_defn ada_language_defn = {
8354 "ada", /* Language name */
8357 /* FIXME: language_ada should be defined in defs.h */
8361 case_sensitive_on, /* Yes, Ada is case-insensitive, but
8362 * that's not quite what this means. */
8365 ada_evaluate_subexp,
8366 ada_printchar, /* Print a character constant */
8367 ada_printstr, /* Function to print string constant */
8368 emit_char, /* Function to print single char (not used) */
8369 ada_create_fundamental_type, /* Create fundamental type in this language */
8370 ada_print_type, /* Print a type using appropriate syntax */
8371 ada_val_print, /* Print a value using appropriate syntax */
8372 ada_value_print, /* Print a top-level value */
8373 {"", "", "", ""}, /* Binary format info */
8375 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8376 {"%ld", "", "d", ""}, /* Decimal format info */
8377 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8379 /* Copied from c-lang.c. */
8380 {"0%lo", "0", "o", ""}, /* Octal format info */
8381 {"%ld", "", "d", ""}, /* Decimal format info */
8382 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8384 ada_op_print_tab, /* expression operators for printing */
8385 1, /* c-style arrays (FIXME?) */
8386 0, /* String lower bound (FIXME?) */
8387 &builtin_type_ada_char,
8392 _initialize_ada_language ()
8394 builtin_type_ada_int =
8395 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8397 "integer", (struct objfile *) NULL);
8398 builtin_type_ada_long =
8399 init_type (TYPE_CODE_INT, TARGET_LONG_BIT / TARGET_CHAR_BIT,
8401 "long_integer", (struct objfile *) NULL);
8402 builtin_type_ada_short =
8403 init_type (TYPE_CODE_INT, TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8405 "short_integer", (struct objfile *) NULL);
8406 builtin_type_ada_char =
8407 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8409 "character", (struct objfile *) NULL);
8410 builtin_type_ada_float =
8411 init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
8413 "float", (struct objfile *) NULL);
8414 builtin_type_ada_double =
8415 init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
8417 "long_float", (struct objfile *) NULL);
8418 builtin_type_ada_long_long =
8419 init_type (TYPE_CODE_INT, TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8421 "long_long_integer", (struct objfile *) NULL);
8422 builtin_type_ada_long_double =
8423 init_type (TYPE_CODE_FLT, TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
8425 "long_long_float", (struct objfile *) NULL);
8426 builtin_type_ada_natural =
8427 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8429 "natural", (struct objfile *) NULL);
8430 builtin_type_ada_positive =
8431 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8433 "positive", (struct objfile *) NULL);
8436 builtin_type_ada_system_address =
8437 lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
8438 (struct objfile *) NULL));
8439 TYPE_NAME (builtin_type_ada_system_address) = "system__address";
8441 add_language (&ada_language_defn);
8444 (add_set_cmd ("varsize-limit", class_support, var_uinteger,
8445 (char*) &varsize_limit,
8446 "Set maximum bytes in dynamic-sized object.",
8449 varsize_limit = 65536;
8451 add_com ("begin", class_breakpoint, begin_command,
8452 "Start the debugged program, stopping at the beginning of the\n\
8453 main program. You may specify command-line arguments to give it, as for\n\
8454 the \"run\" command (q.v.).");
8458 /* Create a fundamental Ada type using default reasonable for the current
8461 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8462 define fundamental types such as "int" or "double". Others (stabs or
8463 DWARF version 2, etc) do define fundamental types. For the formats which
8464 don't provide fundamental types, gdb can create such types using this
8467 FIXME: Some compilers distinguish explicitly signed integral types
8468 (signed short, signed int, signed long) from "regular" integral types
8469 (short, int, long) in the debugging information. There is some dis-
8470 agreement as to how useful this feature is. In particular, gcc does
8471 not support this. Also, only some debugging formats allow the
8472 distinction to be passed on to a debugger. For now, we always just
8473 use "short", "int", or "long" as the type name, for both the implicit
8474 and explicitly signed types. This also makes life easier for the
8475 gdb test suite since we don't have to account for the differences
8476 in output depending upon what the compiler and debugging format
8477 support. We will probably have to re-examine the issue when gdb
8478 starts taking it's fundamental type information directly from the
8479 debugging information supplied by the compiler. fnf@cygnus.com */
8481 static struct type *
8482 ada_create_fundamental_type (objfile, typeid)
8483 struct objfile *objfile;
8486 struct type *type = NULL;
8491 /* FIXME: For now, if we are asked to produce a type not in this
8492 language, create the equivalent of a C integer type with the
8493 name "<?type?>". When all the dust settles from the type
8494 reconstruction work, this should probably become an error. */
8495 type = init_type (TYPE_CODE_INT,
8496 TARGET_INT_BIT / TARGET_CHAR_BIT,
8497 0, "<?type?>", objfile);
8498 warning ("internal error: no Ada fundamental type %d", typeid);
8501 type = init_type (TYPE_CODE_VOID,
8502 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8503 0, "void", objfile);
8506 type = init_type (TYPE_CODE_INT,
8507 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8508 0, "character", objfile);
8510 case FT_SIGNED_CHAR:
8511 type = init_type (TYPE_CODE_INT,
8512 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8513 0, "signed char", objfile);
8515 case FT_UNSIGNED_CHAR:
8516 type = init_type (TYPE_CODE_INT,
8517 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8518 TYPE_FLAG_UNSIGNED, "unsigned char", objfile);
8521 type = init_type (TYPE_CODE_INT,
8522 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8523 0, "short_integer", objfile);
8525 case FT_SIGNED_SHORT:
8526 type = init_type (TYPE_CODE_INT,
8527 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8528 0, "short_integer", objfile);
8530 case FT_UNSIGNED_SHORT:
8531 type = init_type (TYPE_CODE_INT,
8532 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8533 TYPE_FLAG_UNSIGNED, "unsigned short", objfile);
8536 type = init_type (TYPE_CODE_INT,
8537 TARGET_INT_BIT / TARGET_CHAR_BIT,
8538 0, "integer", objfile);
8540 case FT_SIGNED_INTEGER:
8541 type = init_type (TYPE_CODE_INT,
8542 TARGET_INT_BIT / TARGET_CHAR_BIT,
8543 0, "integer", objfile); /* FIXME -fnf */
8545 case FT_UNSIGNED_INTEGER:
8546 type = init_type (TYPE_CODE_INT,
8547 TARGET_INT_BIT / TARGET_CHAR_BIT,
8548 TYPE_FLAG_UNSIGNED, "unsigned int", objfile);
8551 type = init_type (TYPE_CODE_INT,
8552 TARGET_LONG_BIT / TARGET_CHAR_BIT,
8553 0, "long_integer", objfile);
8555 case FT_SIGNED_LONG:
8556 type = init_type (TYPE_CODE_INT,
8557 TARGET_LONG_BIT / TARGET_CHAR_BIT,
8558 0, "long_integer", objfile);
8560 case FT_UNSIGNED_LONG:
8561 type = init_type (TYPE_CODE_INT,
8562 TARGET_LONG_BIT / TARGET_CHAR_BIT,
8563 TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
8566 type = init_type (TYPE_CODE_INT,
8567 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8568 0, "long_long_integer", objfile);
8570 case FT_SIGNED_LONG_LONG:
8571 type = init_type (TYPE_CODE_INT,
8572 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8573 0, "long_long_integer", objfile);
8575 case FT_UNSIGNED_LONG_LONG:
8576 type = init_type (TYPE_CODE_INT,
8577 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8578 TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
8581 type = init_type (TYPE_CODE_FLT,
8582 TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
8583 0, "float", objfile);
8585 case FT_DBL_PREC_FLOAT:
8586 type = init_type (TYPE_CODE_FLT,
8587 TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
8588 0, "long_float", objfile);
8590 case FT_EXT_PREC_FLOAT:
8591 type = init_type (TYPE_CODE_FLT,
8592 TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
8593 0, "long_long_float", objfile);
8599 void ada_dump_symtab (struct symtab* s)
8602 fprintf (stderr, "New symtab: [\n");
8603 fprintf (stderr, " Name: %s/%s;\n",
8604 s->dirname ? s->dirname : "?",
8605 s->filename ? s->filename : "?");
8606 fprintf (stderr, " Format: %s;\n", s->debugformat);
8607 if (s->linetable != NULL)
8609 fprintf (stderr, " Line table (section %d):\n", s->block_line_section);
8610 for (i = 0; i < s->linetable->nitems; i += 1)
8612 struct linetable_entry* e = s->linetable->item + i;
8613 fprintf (stderr, " %4ld: %8lx\n", (long) e->line, (long) e->pc);
8616 fprintf (stderr, "]\n");