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.
4285 Why is there provision in struct type for BOTH an array of argument
4286 types (TYPE_ARG_TYPES) and for an array of typed fields, whose
4287 comment suggests it may also represent argument types? I presume
4288 this is some attempt to save space. The problem is that argument
4289 names in Ada are significant. Therefore, for Ada we use the
4290 (apparently older) TYPE_FIELD_* stuff to store argument types. */
4294 fill_in_ada_prototype (func)
4295 struct symbol* func;
4305 || TYPE_CODE (SYMBOL_TYPE (func)) != TYPE_CODE_FUNC
4306 || TYPE_FIELDS (SYMBOL_TYPE (func)) != NULL)
4309 /* We make each function type unique, so that each may have its own */
4310 /* parameter types. This particular way of doing so wastes space: */
4311 /* it would be nicer to build the argument types while the original */
4312 /* function type is being built (FIXME). */
4313 rtype = check_typedef (TYPE_TARGET_TYPE (SYMBOL_TYPE (func)));
4314 ftype = alloc_type (TYPE_OBJFILE (SYMBOL_TYPE (func)));
4315 make_function_type (rtype, &ftype);
4316 SYMBOL_TYPE (func) = ftype;
4318 b = SYMBOL_BLOCK_VALUE (func);
4319 nsyms = BLOCK_NSYMS (b);
4323 TYPE_FIELDS (ftype) =
4324 (struct field*) xmalloc (sizeof (struct field) * max_fields);
4325 for (i = 0; i < nsyms; i += 1)
4327 struct symbol *sym = BLOCK_SYM (b, i);
4329 GROW_VECT (TYPE_FIELDS (ftype), max_fields, nargs+1);
4331 switch (SYMBOL_CLASS (sym))
4334 case LOC_REGPARM_ADDR:
4335 TYPE_FIELD_BITPOS (ftype, nargs) = nargs;
4336 TYPE_FIELD_BITSIZE (ftype, nargs) = 0;
4337 TYPE_FIELD_TYPE (ftype, nargs) =
4338 lookup_pointer_type (check_typedef (SYMBOL_TYPE (sym)));
4339 TYPE_FIELD_NAME (ftype, nargs) = SYMBOL_NAME (sym);
4347 case LOC_BASEREG_ARG:
4348 TYPE_FIELD_BITPOS (ftype, nargs) = nargs;
4349 TYPE_FIELD_BITSIZE (ftype, nargs) = 0;
4350 TYPE_FIELD_TYPE (ftype, nargs) = check_typedef (SYMBOL_TYPE (sym));
4351 TYPE_FIELD_NAME (ftype, nargs) = SYMBOL_NAME (sym);
4361 /* Re-allocate fields vector; if there are no fields, make the */
4362 /* fields pointer non-null anyway, to mark that this function type */
4363 /* has been filled in. */
4365 TYPE_NFIELDS (ftype) = nargs;
4368 static struct field dummy_field = {0, 0, 0, 0};
4369 free (TYPE_FIELDS (ftype));
4370 TYPE_FIELDS (ftype) = &dummy_field;
4374 struct field* fields =
4375 (struct field*) TYPE_ALLOC (ftype, nargs * sizeof (struct field));
4376 memcpy ((char*) fields,
4377 (char*) TYPE_FIELDS (ftype),
4378 nargs * sizeof (struct field));
4379 free (TYPE_FIELDS (ftype));
4380 TYPE_FIELDS (ftype) = fields;
4385 /* Breakpoint-related */
4387 char no_symtab_msg[] = "No symbol table is loaded. Use the \"file\" command.";
4389 /* Assuming that LINE is pointing at the beginning of an argument to
4390 'break', return a pointer to the delimiter for the initial segment
4391 of that name. This is the first ':', ' ', or end of LINE.
4394 ada_start_decode_line_1 (line)
4397 /* [NOTE: strpbrk would be more elegant, but I am reluctant to be
4398 the first to use such a library function in GDB code.] */
4400 for (p = line; *p != '\000' && *p != ' ' && *p != ':'; p += 1)
4405 /* *SPEC points to a function and line number spec (as in a break
4406 command), following any initial file name specification.
4408 Return all symbol table/line specfications (sals) consistent with the
4409 information in *SPEC and FILE_TABLE in the
4411 + FILE_TABLE is null, or the sal refers to a line in the file
4412 named by FILE_TABLE.
4413 + If *SPEC points to an argument with a trailing ':LINENUM',
4414 then the sal refers to that line (or one following it as closely as
4416 + If *SPEC does not start with '*', the sal is in a function with
4419 Returns with 0 elements if no matching non-minimal symbols found.
4421 If *SPEC begins with a function name of the form <NAME>, then NAME
4422 is taken as a literal name; otherwise the function name is subject
4423 to the usual mangling.
4425 *SPEC is updated to point after the function/line number specification.
4427 FUNFIRSTLINE is non-zero if we desire the first line of real code
4428 in each function (this is ignored in the presence of a LINENUM spec.).
4430 If CANONICAL is non-NULL, and if any of the sals require a
4431 'canonical line spec', then *CANONICAL is set to point to an array
4432 of strings, corresponding to and equal in length to the returned
4433 list of sals, such that (*CANONICAL)[i] is non-null and contains a
4434 canonical line spec for the ith returned sal, if needed. If no
4435 canonical line specs are required and CANONICAL is non-null,
4436 *CANONICAL is set to NULL.
4438 A 'canonical line spec' is simply a name (in the format of the
4439 breakpoint command) that uniquely identifies a breakpoint position,
4440 with no further contextual information or user selection. It is
4441 needed whenever the file name, function name, and line number
4442 information supplied is insufficient for this unique
4443 identification. Currently overloaded functions, the name '*',
4444 or static functions without a filename yield a canonical line spec.
4445 The array and the line spec strings are allocated on the heap; it
4446 is the caller's responsibility to free them. */
4448 struct symtabs_and_lines
4449 ada_finish_decode_line_1 (spec, file_table, funfirstline, canonical)
4451 struct symtab* file_table;
4455 struct symbol** symbols;
4456 struct block** blocks;
4457 struct block* block;
4458 int n_matches, i, line_num;
4459 struct symtabs_and_lines selected;
4460 struct cleanup* old_chain = make_cleanup (null_cleanup, NULL);
4465 char* unquoted_name;
4467 if (file_table == NULL)
4468 block = get_selected_block (NULL);
4470 block = BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table), STATIC_BLOCK);
4472 if (canonical != NULL)
4473 *canonical = (char**) NULL;
4480 while (**spec != '\000' &&
4481 ! strchr (ada_completer_word_break_characters, **spec))
4487 if (file_table != NULL && (*spec)[0] == ':' && isdigit ((*spec)[1]))
4489 line_num = strtol (*spec + 1, spec, 10);
4490 while (**spec == ' ' || **spec == '\t')
4497 error ("Wild-card function with no line number or file name.");
4499 return all_sals_for_line (file_table->filename, line_num, canonical);
4502 if (name[0] == '\'')
4510 unquoted_name = (char*) alloca (len-1);
4511 memcpy (unquoted_name, name+1, len-2);
4512 unquoted_name[len-2] = '\000';
4517 unquoted_name = (char*) alloca (len+1);
4518 memcpy (unquoted_name, name, len);
4519 unquoted_name[len] = '\000';
4520 lower_name = (char*) alloca (len + 1);
4521 for (i = 0; i < len; i += 1)
4522 lower_name[i] = tolower (name[i]);
4523 lower_name[len] = '\000';
4527 if (lower_name != NULL)
4528 n_matches = ada_lookup_symbol_list (ada_mangle (lower_name), block,
4529 VAR_NAMESPACE, &symbols, &blocks);
4531 n_matches = ada_lookup_symbol_list (unquoted_name, block,
4532 VAR_NAMESPACE, &symbols, &blocks);
4533 if (n_matches == 0 && line_num >= 0)
4534 error ("No line number information found for %s.", unquoted_name);
4535 else if (n_matches == 0)
4537 #ifdef HPPA_COMPILER_BUG
4538 /* FIXME: See comment in symtab.c::decode_line_1 */
4540 volatile struct symtab_and_line val;
4541 #define volatile /*nothing*/
4543 struct symtab_and_line val;
4545 struct minimal_symbol* msymbol;
4550 if (lower_name != NULL)
4551 msymbol = ada_lookup_minimal_symbol (ada_mangle (lower_name));
4552 if (msymbol == NULL)
4553 msymbol = ada_lookup_minimal_symbol (unquoted_name);
4554 if (msymbol != NULL)
4556 val.pc = SYMBOL_VALUE_ADDRESS (msymbol);
4557 val.section = SYMBOL_BFD_SECTION (msymbol);
4560 val.pc += FUNCTION_START_OFFSET;
4561 SKIP_PROLOGUE (val.pc);
4563 selected.sals = (struct symtab_and_line *)
4564 xmalloc (sizeof (struct symtab_and_line));
4565 selected.sals[0] = val;
4570 if (!have_full_symbols () &&
4571 !have_partial_symbols () && !have_minimal_symbols ())
4572 error (no_symtab_msg);
4574 error ("Function \"%s\" not defined.", unquoted_name);
4575 return selected; /* for lint */
4581 find_sal_from_funcs_and_line (file_table->filename, line_num,
4582 symbols, n_matches);
4586 selected.nelts = user_select_syms (symbols, blocks, n_matches, n_matches);
4589 selected.sals = (struct symtab_and_line*)
4590 xmalloc (sizeof (struct symtab_and_line) * selected.nelts);
4591 memset (selected.sals, 0, selected.nelts * sizeof (selected.sals[i]));
4592 make_cleanup (free, selected.sals);
4595 while (i < selected.nelts)
4597 if (SYMBOL_CLASS (symbols[i]) == LOC_BLOCK)
4598 selected.sals[i] = find_function_start_sal (symbols[i], funfirstline);
4599 else if (SYMBOL_LINE (symbols[i]) != 0)
4601 selected.sals[i].symtab = symtab_for_sym (symbols[i]);
4602 selected.sals[i].line = SYMBOL_LINE (symbols[i]);
4604 else if (line_num >= 0)
4606 /* Ignore this choice */
4607 symbols[i] = symbols[selected.nelts-1];
4608 blocks[i] = blocks[selected.nelts-1];
4609 selected.nelts -= 1;
4613 error ("Line number not known for symbol \"%s\"", unquoted_name);
4617 if (canonical != NULL && (line_num >= 0 || n_matches > 1))
4619 *canonical = (char**) xmalloc (sizeof(char*) * selected.nelts);
4620 for (i = 0; i < selected.nelts; i += 1)
4622 extended_canonical_line_spec (selected.sals[i],
4623 SYMBOL_SOURCE_NAME (symbols[i]));
4626 discard_cleanups (old_chain);
4630 /* The (single) sal corresponding to line LINE_NUM in a symbol table
4631 with file name FILENAME that occurs in one of the functions listed
4632 in SYMBOLS[0 .. NSYMS-1]. */
4633 static struct symtabs_and_lines
4634 find_sal_from_funcs_and_line (filename, line_num, symbols, nsyms)
4635 const char* filename;
4637 struct symbol** symbols;
4640 struct symtabs_and_lines sals;
4641 int best_index, best;
4642 struct linetable* best_linetable;
4643 struct objfile* objfile;
4645 struct symtab* best_symtab;
4647 read_all_symtabs (filename);
4649 best_index = 0; best_linetable = NULL; best_symtab = NULL;
4651 ALL_SYMTABS (objfile, s)
4653 struct linetable *l;
4658 if (!STREQ (filename, s->filename))
4661 ind = find_line_in_linetable (l, line_num, symbols, nsyms, &exact);
4671 if (best == 0 || l->item[ind].line < best)
4673 best = l->item[ind].line;
4682 error ("Line number not found in designated function.");
4687 sals.sals = (struct symtab_and_line*) xmalloc (sizeof (sals.sals[0]));
4689 INIT_SAL (&sals.sals[0]);
4691 sals.sals[0].line = best_linetable->item[best_index].line;
4692 sals.sals[0].pc = best_linetable->item[best_index].pc;
4693 sals.sals[0].symtab = best_symtab;
4698 /* Return the index in LINETABLE of the best match for LINE_NUM whose
4699 pc falls within one of the functions denoted by SYMBOLS[0..NSYMS-1].
4700 Set *EXACTP to the 1 if the match is exact, and 0 otherwise. */
4702 find_line_in_linetable (linetable, line_num, symbols, nsyms, exactp)
4703 struct linetable* linetable;
4705 struct symbol** symbols;
4709 int i, len, best_index, best;
4711 if (line_num <= 0 || linetable == NULL)
4714 len = linetable->nitems;
4715 for (i = 0, best_index = -1, best = 0; i < len; i += 1)
4718 struct linetable_entry* item = &(linetable->item[i]);
4720 for (k = 0; k < nsyms; k += 1)
4722 if (symbols[k] != NULL && SYMBOL_CLASS (symbols[k]) == LOC_BLOCK
4723 && item->pc >= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols[k]))
4724 && item->pc < BLOCK_END (SYMBOL_BLOCK_VALUE (symbols[k])))
4731 if (item->line == line_num)
4737 if (item->line > line_num && (best == 0 || item->line < best))
4748 /* Find the smallest k >= LINE_NUM such that k is a line number in
4749 LINETABLE, and k falls strictly within a named function that begins at
4750 or before LINE_NUM. Return -1 if there is no such k. */
4752 nearest_line_number_in_linetable (linetable, line_num)
4753 struct linetable* linetable;
4758 if (line_num <= 0 || linetable == NULL || linetable->nitems == 0)
4760 len = linetable->nitems;
4762 i = 0; best = INT_MAX;
4766 struct linetable_entry* item = &(linetable->item[i]);
4768 if (item->line >= line_num && item->line < best)
4771 CORE_ADDR start, end;
4774 find_pc_partial_function (item->pc, &func_name, &start, &end);
4776 if (func_name != NULL && item->pc < end)
4778 if (item->line == line_num)
4782 struct symbol* sym =
4783 standard_lookup (func_name, VAR_NAMESPACE);
4784 if (is_plausible_func_for_line (sym, line_num))
4790 while (i < len && linetable->item[i].pc < end);
4800 return (best == INT_MAX) ? -1 : best;
4804 /* Return the next higher index, k, into LINETABLE such that k > IND,
4805 entry k in LINETABLE has a line number equal to LINE_NUM, k
4806 corresponds to a PC that is in a function different from that
4807 corresponding to IND, and falls strictly within a named function
4808 that begins at a line at or preceding STARTING_LINE.
4809 Return -1 if there is no such k.
4810 IND == -1 corresponds to no function. */
4813 find_next_line_in_linetable (linetable, line_num, starting_line, ind)
4814 struct linetable* linetable;
4821 if (line_num <= 0 || linetable == NULL || ind >= linetable->nitems)
4823 len = linetable->nitems;
4827 CORE_ADDR start, end;
4829 if (find_pc_partial_function (linetable->item[ind].pc,
4830 (char**) NULL, &start, &end))
4832 while (ind < len && linetable->item[ind].pc < end)
4845 struct linetable_entry* item = &(linetable->item[i]);
4847 if (item->line >= line_num)
4850 CORE_ADDR start, end;
4853 find_pc_partial_function (item->pc, &func_name, &start, &end);
4855 if (func_name != NULL && item->pc < end)
4857 if (item->line == line_num)
4859 struct symbol* sym =
4860 standard_lookup (func_name, VAR_NAMESPACE);
4861 if (is_plausible_func_for_line (sym, starting_line))
4865 while ((i+1) < len && linetable->item[i+1].pc < end)
4877 /* True iff function symbol SYM starts somewhere at or before line #
4880 is_plausible_func_for_line (sym, line_num)
4884 struct symtab_and_line start_sal;
4889 start_sal = find_function_start_sal (sym, 0);
4891 return (start_sal.line != 0 && line_num >= start_sal.line);
4895 debug_print_lines (lt)
4896 struct linetable* lt;
4903 fprintf (stderr, "\t");
4904 for (i = 0; i < lt->nitems; i += 1)
4905 fprintf (stderr, "(%d->%p) ", lt->item[i].line, (void *) lt->item[i].pc);
4906 fprintf (stderr, "\n");
4910 debug_print_block (b)
4914 fprintf (stderr, "Block: %p; [0x%lx, 0x%lx]",
4915 b, BLOCK_START(b), BLOCK_END(b));
4916 if (BLOCK_FUNCTION(b) != NULL)
4917 fprintf (stderr, " Function: %s", SYMBOL_NAME (BLOCK_FUNCTION(b)));
4918 fprintf (stderr, "\n");
4919 fprintf (stderr, "\t Superblock: %p\n", BLOCK_SUPERBLOCK(b));
4920 fprintf (stderr, "\t Symbols:");
4921 for (i = 0; i < BLOCK_NSYMS (b); i += 1)
4923 if (i > 0 && i % 4 == 0)
4924 fprintf (stderr, "\n\t\t ");
4925 fprintf (stderr, " %s", SYMBOL_NAME (BLOCK_SYM (b, i)));
4927 fprintf (stderr, "\n");
4931 debug_print_blocks (bv)
4932 struct blockvector* bv;
4938 for (i = 0; i < BLOCKVECTOR_NBLOCKS (bv); i += 1) {
4939 fprintf (stderr, "%6d. ", i);
4940 debug_print_block (BLOCKVECTOR_BLOCK (bv, i));
4945 debug_print_symtab (s)
4948 fprintf (stderr, "Symtab %p\n File: %s; Dir: %s\n", s,
4949 s->filename, s->dirname);
4950 fprintf (stderr, " Blockvector: %p, Primary: %d\n",
4951 BLOCKVECTOR(s), s->primary);
4952 debug_print_blocks (BLOCKVECTOR(s));
4953 fprintf (stderr, " Line table: %p\n", LINETABLE (s));
4954 debug_print_lines (LINETABLE(s));
4957 /* Read in all symbol tables corresponding to partial symbol tables
4958 with file name FILENAME. */
4960 read_all_symtabs (filename)
4961 const char* filename;
4963 struct partial_symtab* ps;
4964 struct objfile* objfile;
4966 ALL_PSYMTABS (objfile, ps)
4970 if (STREQ (filename, ps->filename))
4971 PSYMTAB_TO_SYMTAB (ps);
4975 /* All sals corresponding to line LINE_NUM in a symbol table from file
4976 FILENAME, as filtered by the user. If CANONICAL is not null, set
4977 it to a corresponding array of canonical line specs. */
4978 static struct symtabs_and_lines
4979 all_sals_for_line (filename, line_num, canonical)
4980 const char* filename;
4984 struct symtabs_and_lines result;
4985 struct objfile* objfile;
4987 struct cleanup* old_chain = make_cleanup (null_cleanup, NULL);
4990 read_all_symtabs (filename);
4992 result.sals = (struct symtab_and_line*) xmalloc (4 * sizeof (result.sals[0]));
4995 make_cleanup (free_current_contents, &result.sals);
4997 ALL_SYMTABS (objfile, s)
4999 int ind, target_line_num;
5003 if (!STREQ (s->filename, filename))
5007 nearest_line_number_in_linetable (LINETABLE (s), line_num);
5008 if (target_line_num == -1)
5015 find_next_line_in_linetable (LINETABLE (s),
5016 target_line_num, line_num, ind);
5021 GROW_VECT (result.sals, len, result.nelts+1);
5022 INIT_SAL (&result.sals[result.nelts]);
5023 result.sals[result.nelts].line = LINETABLE(s)->item[ind].line;
5024 result.sals[result.nelts].pc = LINETABLE(s)->item[ind].pc;
5025 result.sals[result.nelts].symtab = s;
5030 if (canonical != NULL || result.nelts > 1)
5033 char** func_names = (char**) alloca (result.nelts * sizeof (char*));
5034 int first_choice = (result.nelts > 1) ? 2 : 1;
5036 int* choices = (int*) alloca (result.nelts * sizeof (int));
5038 for (k = 0; k < result.nelts; k += 1)
5040 find_pc_partial_function (result.sals[k].pc, &func_names[k],
5041 (CORE_ADDR*) NULL, (CORE_ADDR*) NULL);
5042 if (func_names[k] == NULL)
5043 error ("Could not find function for one or more breakpoints.");
5046 if (result.nelts > 1)
5048 printf_unfiltered("[0] cancel\n");
5049 if (result.nelts > 1)
5050 printf_unfiltered("[1] all\n");
5051 for (k = 0; k < result.nelts; k += 1)
5052 printf_unfiltered ("[%d] %s\n", k + first_choice,
5053 ada_demangle (func_names[k]));
5055 n = get_selections (choices, result.nelts, result.nelts,
5056 result.nelts > 1, "instance-choice");
5058 for (k = 0; k < n; k += 1)
5060 result.sals[k] = result.sals[choices[k]];
5061 func_names[k] = func_names[choices[k]];
5066 if (canonical != NULL)
5068 *canonical = (char**) xmalloc (result.nelts * sizeof (char**));
5069 make_cleanup (free, *canonical);
5070 for (k = 0; k < result.nelts; k += 1)
5073 extended_canonical_line_spec (result.sals[k], func_names[k]);
5074 if ((*canonical)[k] == NULL)
5075 error ("Could not locate one or more breakpoints.");
5076 make_cleanup (free, (*canonical)[k]);
5081 discard_cleanups (old_chain);
5086 /* A canonical line specification of the form FILE:NAME:LINENUM for
5087 symbol table and line data SAL. NULL if insufficient
5088 information. The caller is responsible for releasing any space
5092 extended_canonical_line_spec (sal, name)
5093 struct symtab_and_line sal;
5098 if (sal.symtab == NULL || sal.symtab->filename == NULL ||
5102 r = (char*) xmalloc (strlen (name) + strlen (sal.symtab->filename)
5103 + sizeof(sal.line)*3 + 3);
5104 sprintf (r, "%s:'%s':%d", sal.symtab->filename, name, sal.line);
5109 int begin_bnum = -1;
5111 int begin_annotate_level = 0;
5114 begin_cleanup (void* dummy)
5116 begin_annotate_level = 0;
5120 begin_command (args, from_tty)
5124 struct minimal_symbol *msym;
5125 CORE_ADDR main_program_name_addr;
5126 char main_program_name[1024];
5127 struct cleanup* old_chain = make_cleanup (begin_cleanup, NULL);
5128 begin_annotate_level = 2;
5130 /* Check that there is a program to debug */
5131 if (!have_full_symbols () && !have_partial_symbols ())
5132 error ("No symbol table is loaded. Use the \"file\" command.");
5134 /* Check that we are debugging an Ada program */
5135 /* if (ada_update_initial_language (language_unknown, NULL) != language_ada)
5136 error ("Cannot find the Ada initialization procedure. Is this an Ada main program?");
5138 /* FIXME: language_ada should be defined in defs.h */
5140 /* Get the address of the name of the main procedure */
5141 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
5145 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
5146 if (main_program_name_addr == 0)
5147 error ("Invalid address for Ada main program name.");
5149 /* Read the name of the main procedure */
5150 extract_string (main_program_name_addr, main_program_name);
5152 /* Put a temporary breakpoint in the Ada main program and run */
5153 do_command ("tbreak ", main_program_name, 0);
5154 do_command ("run ", args, 0);
5158 /* If we could not find the symbol containing the name of the
5159 main program, that means that the compiler that was used to build
5160 was not recent enough. In that case, we fallback to the previous
5161 mechanism, which is a little bit less reliable, but has proved to work
5162 in most cases. The only cases where it will fail is when the user
5163 has set some breakpoints which will be hit before the end of the
5164 begin command processing (eg in the initialization code).
5166 The begining of the main Ada subprogram is located by breaking
5167 on the adainit procedure. Since we know that the binder generates
5168 the call to this procedure exactly 2 calls before the call to the
5169 Ada main subprogram, it is then easy to put a breakpoint on this
5170 Ada main subprogram once we hit adainit.
5172 do_command ("tbreak adainit", 0);
5173 do_command ("run ", args, 0);
5174 do_command ("up", 0);
5175 do_command ("tbreak +2", 0);
5176 do_command ("continue", 0);
5177 do_command ("step", 0);
5180 do_cleanups (old_chain);
5184 is_ada_runtime_file (filename)
5187 return (STREQN (filename, "s-", 2) ||
5188 STREQN (filename, "a-", 2) ||
5189 STREQN (filename, "g-", 2) ||
5190 STREQN (filename, "i-", 2));
5193 /* find the first frame that contains debugging information and that is not
5194 part of the Ada run-time, starting from fi and moving upward. */
5197 find_printable_frame (fi, level)
5198 struct frame_info *fi;
5201 struct symtab_and_line sal;
5203 for (; fi != NULL; level += 1, fi = get_prev_frame (fi))
5205 /* If fi is not the innermost frame, that normally means that fi->pc
5206 points to *after* the call instruction, and we want to get the line
5207 containing the call, never the next line. But if the next frame is
5208 a signal_handler_caller or a dummy frame, then the next frame was
5209 not entered as the result of a call, and we want to get the line
5210 containing fi->pc. */
5212 find_pc_line (fi->pc,
5214 && !fi->next->signal_handler_caller
5215 && !frame_in_dummy (fi->next));
5216 if (sal.symtab && !is_ada_runtime_file (sal.symtab->filename))
5218 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
5219 /* libpthread.so contains some debugging information that prevents us
5220 from finding the right frame */
5222 if (sal.symtab->objfile &&
5223 STREQ (sal.symtab->objfile->name, "/usr/shlib/libpthread.so"))
5226 selected_frame = fi;
5235 ada_report_exception_break (b)
5236 struct breakpoint *b;
5239 /* FIXME: break_on_exception should be defined in breakpoint.h */
5240 /* if (b->break_on_exception == 1)
5242 /* Assume that cond has 16 elements, the 15th
5243 being the exception */ /*
5244 if (b->cond && b->cond->nelts == 16)
5246 ui_out_text (uiout, "on ");
5247 ui_out_field_string (uiout, "exception",
5248 SYMBOL_NAME (b->cond->elts[14].symbol));
5251 ui_out_text (uiout, "on all exceptions");
5253 else if (b->break_on_exception == 2)
5254 ui_out_text (uiout, "on unhandled exception");
5255 else if (b->break_on_exception == 3)
5256 ui_out_text (uiout, "on assert failure");
5258 if (b->break_on_exception == 1)
5260 /* Assume that cond has 16 elements, the 15th
5261 being the exception */ /*
5262 if (b->cond && b->cond->nelts == 16)
5264 fputs_filtered ("on ", gdb_stdout);
5265 fputs_filtered (SYMBOL_NAME
5266 (b->cond->elts[14].symbol), gdb_stdout);
5269 fputs_filtered ("on all exceptions", gdb_stdout);
5271 else if (b->break_on_exception == 2)
5272 fputs_filtered ("on unhandled exception", gdb_stdout);
5273 else if (b->break_on_exception == 3)
5274 fputs_filtered ("on assert failure", gdb_stdout);
5280 ada_is_exception_sym (struct symbol* sym)
5282 char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
5284 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
5285 && SYMBOL_CLASS (sym) != LOC_BLOCK
5286 && SYMBOL_CLASS (sym) != LOC_CONST
5287 && type_name != NULL
5288 && STREQ (type_name, "exception"));
5292 ada_maybe_exception_partial_symbol (struct partial_symbol* sym)
5294 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
5295 && SYMBOL_CLASS (sym) != LOC_BLOCK
5296 && SYMBOL_CLASS (sym) != LOC_CONST);
5299 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5300 into equivalent form. Return resulting argument string. Set
5301 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5302 break on unhandled, 3 for assert, 0 otherwise. */
5303 char* ada_breakpoint_rewrite (char* arg, int* break_on_exceptionp)
5307 *break_on_exceptionp = 0;
5308 /* FIXME: language_ada should be defined in defs.h */
5309 /* if (current_language->la_language == language_ada
5310 && STREQN (arg, "exception", 9) &&
5311 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5313 char *tok, *end_tok;
5316 *break_on_exceptionp = 1;
5319 while (*tok == ' ' || *tok == '\t')
5324 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5327 toklen = end_tok - tok;
5329 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5330 "long_integer(e) = long_integer(&)")
5332 make_cleanup (free, arg);
5334 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5335 else if (STREQN (tok, "unhandled", toklen))
5337 *break_on_exceptionp = 2;
5338 strcpy (arg, "__gnat_unhandled_exception");
5342 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5343 "long_integer(e) = long_integer(&%.*s)",
5347 else if (current_language->la_language == language_ada
5348 && STREQN (arg, "assert", 6) &&
5349 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5351 char *tok = arg + 6;
5353 *break_on_exceptionp = 3;
5356 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5357 + strlen (tok) + 1);
5358 make_cleanup (free, arg);
5359 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5368 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5369 to be invisible to users. */
5372 ada_is_ignored_field (type, field_num)
5376 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5380 const char* name = TYPE_FIELD_NAME (type, field_num);
5381 return (name == NULL
5382 || (name[0] == '_' && ! STREQN (name, "_parent", 7)));
5386 /* True iff structure type TYPE has a tag field. */
5389 ada_is_tagged_type (type)
5392 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5395 return (ada_lookup_struct_elt_type (type, "_tag", 1, NULL) != NULL);
5398 /* The type of the tag on VAL. */
5404 return ada_lookup_struct_elt_type (VALUE_TYPE (val), "_tag", 0, NULL);
5407 /* The value of the tag on VAL. */
5413 return ada_value_struct_elt (val, "_tag", "record");
5416 /* The parent type of TYPE, or NULL if none. */
5419 ada_parent_type (type)
5424 CHECK_TYPEDEF (type);
5426 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5429 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5430 if (ada_is_parent_field (type, i))
5431 return check_typedef (TYPE_FIELD_TYPE (type, i));
5436 /* True iff field number FIELD_NUM of structure type TYPE contains the
5437 parent-type (inherited) fields of a derived type. Assumes TYPE is
5438 a structure type with at least FIELD_NUM+1 fields. */
5441 ada_is_parent_field (type, field_num)
5445 const char* name = TYPE_FIELD_NAME (check_typedef (type), field_num);
5446 return (name != NULL &&
5447 (STREQN (name, "PARENT", 6) || STREQN (name, "_parent", 7)));
5450 /* True iff field number FIELD_NUM of structure type TYPE is a
5451 transparent wrapper field (which should be silently traversed when doing
5452 field selection and flattened when printing). Assumes TYPE is a
5453 structure type with at least FIELD_NUM+1 fields. Such fields are always
5457 ada_is_wrapper_field (type, field_num)
5461 const char* name = TYPE_FIELD_NAME (type, field_num);
5462 return (name != NULL
5463 && (STREQN (name, "PARENT", 6) || STREQ (name, "REP")
5464 || STREQN (name, "_parent", 7)
5465 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
5468 /* True iff field number FIELD_NUM of structure or union type TYPE
5469 is a variant wrapper. Assumes TYPE is a structure type with at least
5470 FIELD_NUM+1 fields. */
5473 ada_is_variant_part (type, field_num)
5477 struct type* field_type = TYPE_FIELD_TYPE (type, field_num);
5478 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
5479 || (is_dynamic_field (type, field_num)
5480 && TYPE_CODE (TYPE_TARGET_TYPE (field_type)) == TYPE_CODE_UNION));
5483 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5484 whose discriminants are contained in the record type OUTER_TYPE,
5485 returns the type of the controlling discriminant for the variant. */
5488 ada_variant_discrim_type (var_type, outer_type)
5489 struct type *var_type;
5490 struct type *outer_type;
5492 char* name = ada_variant_discrim_name (var_type);
5494 ada_lookup_struct_elt_type (outer_type, name, 1, NULL);
5496 return builtin_type_int;
5501 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5502 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5503 represents a 'when others' clause; otherwise 0. */
5506 ada_is_others_clause (type, field_num)
5510 const char* name = TYPE_FIELD_NAME (type, field_num);
5511 return (name != NULL && name[0] == 'O');
5514 /* Assuming that TYPE0 is the type of the variant part of a record,
5515 returns the name of the discriminant controlling the variant. The
5516 value is valid until the next call to ada_variant_discrim_name. */
5519 ada_variant_discrim_name (type0)
5522 static char* result = NULL;
5523 static size_t result_len = 0;
5526 const char* discrim_end;
5527 const char* discrim_start;
5529 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
5530 type = TYPE_TARGET_TYPE (type0);
5534 name = ada_type_name (type);
5536 if (name == NULL || name[0] == '\000')
5539 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
5542 if (STREQN (discrim_end, "___XVN", 6))
5545 if (discrim_end == name)
5548 for (discrim_start = discrim_end; discrim_start != name+3;
5551 if (discrim_start == name+1)
5553 if ((discrim_start > name+3 && STREQN (discrim_start-3, "___", 3))
5554 || discrim_start[-1] == '.')
5558 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
5559 strncpy (result, discrim_start, discrim_end - discrim_start);
5560 result[discrim_end-discrim_start] = '\0';
5564 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5565 position of the character just past the number scanned in *NEW_K,
5566 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5567 if there was a valid number at the given position, and 0 otherwise. A
5568 "subtype-encoded" number consists of the absolute value in decimal,
5569 followed by the letter 'm' to indicate a negative number. Assumes 0m
5573 ada_scan_number (str, k, R, new_k)
5581 if (! isdigit (str[k]))
5584 /* Do it the hard way so as not to make any assumption about
5585 the relationship of unsigned long (%lu scan format code) and
5588 while (isdigit (str[k]))
5590 RU = RU*10 + (str[k] - '0');
5597 *R = (- (LONGEST) (RU-1)) - 1;
5603 /* NOTE on the above: Technically, C does not say what the results of
5604 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5605 number representable as a LONGEST (although either would probably work
5606 in most implementations). When RU>0, the locution in the then branch
5607 above is always equivalent to the negative of RU. */
5614 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5615 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5616 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5619 ada_in_variant (val, type, field_num)
5624 const char* name = TYPE_FIELD_NAME (type, field_num);
5637 if (! ada_scan_number (name, p + 1, &W, &p))
5646 if (! ada_scan_number (name, p + 1, &L, &p)
5648 || ! ada_scan_number (name, p + 1, &U, &p))
5650 if (val >= L && val <= U)
5662 /* Given a value ARG1 (offset by OFFSET bytes)
5663 of a struct or union type ARG_TYPE,
5664 extract and return the value of one of its (non-static) fields.
5665 FIELDNO says which field. Differs from value_primitive_field only
5666 in that it can handle packed values of arbitrary type. */
5669 ada_value_primitive_field (arg1, offset, fieldno, arg_type)
5673 struct type *arg_type;
5678 CHECK_TYPEDEF (arg_type);
5679 type = TYPE_FIELD_TYPE (arg_type, fieldno);
5681 /* Handle packed fields */
5683 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
5685 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
5686 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
5688 return ada_value_primitive_packed_val (arg1, VALUE_CONTENTS (arg1),
5689 offset + bit_pos/8, bit_pos % 8,
5693 return value_primitive_field (arg1, offset, fieldno, arg_type);
5697 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5698 and search in it assuming it has (class) type TYPE.
5699 If found, return value, else return NULL.
5701 Searches recursively through wrapper fields (e.g., '_parent'). */
5704 ada_search_struct_field (name, arg, offset, type)
5711 CHECK_TYPEDEF (type);
5713 for (i = TYPE_NFIELDS (type)-1; i >= 0; i -= 1)
5715 char *t_field_name = TYPE_FIELD_NAME (type, i);
5717 if (t_field_name == NULL)
5720 else if (field_name_match (t_field_name, name))
5721 return ada_value_primitive_field (arg, offset, i, type);
5723 else if (ada_is_wrapper_field (type, i))
5726 ada_search_struct_field (name, arg,
5727 offset + TYPE_FIELD_BITPOS (type, i) / 8,
5728 TYPE_FIELD_TYPE (type, i));
5733 else if (ada_is_variant_part (type, i))
5736 struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, i));
5737 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
5739 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
5742 ada_search_struct_field (name, arg,
5744 + TYPE_FIELD_BITPOS (field_type, j)/8,
5745 TYPE_FIELD_TYPE (field_type, j));
5754 /* Given ARG, a value of type (pointer to a)* structure/union,
5755 extract the component named NAME from the ultimate target structure/union
5756 and return it as a value with its appropriate type.
5758 The routine searches for NAME among all members of the structure itself
5759 and (recursively) among all members of any wrapper members
5762 ERR is a name (for use in error messages) that identifies the class
5763 of entity that ARG is supposed to be. */
5766 ada_value_struct_elt (arg, name, err)
5774 arg = ada_coerce_ref (arg);
5775 t = check_typedef (VALUE_TYPE (arg));
5777 /* Follow pointers until we get to a non-pointer. */
5779 while (TYPE_CODE (t) == TYPE_CODE_PTR || TYPE_CODE (t) == TYPE_CODE_REF)
5781 arg = ada_value_ind (arg);
5782 t = check_typedef (VALUE_TYPE (arg));
5785 if ( TYPE_CODE (t) != TYPE_CODE_STRUCT
5786 && TYPE_CODE (t) != TYPE_CODE_UNION)
5787 error ("Attempt to extract a component of a value that is not a %s.", err);
5789 v = ada_search_struct_field (name, arg, 0, t);
5791 error ("There is no member named %s.", name);
5796 /* Given a type TYPE, look up the type of the component of type named NAME.
5797 If DISPP is non-null, add its byte displacement from the beginning of a
5798 structure (pointed to by a value) of type TYPE to *DISPP (does not
5799 work for packed fields).
5801 Matches any field whose name has NAME as a prefix, possibly
5804 TYPE can be either a struct or union, or a pointer or reference to
5805 a struct or union. If it is a pointer or reference, its target
5806 type is automatically used.
5808 Looks recursively into variant clauses and parent types.
5810 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5813 ada_lookup_struct_elt_type (type, name, noerr, dispp)
5826 CHECK_TYPEDEF (type);
5827 if (TYPE_CODE (type) != TYPE_CODE_PTR
5828 && TYPE_CODE (type) != TYPE_CODE_REF)
5830 type = TYPE_TARGET_TYPE (type);
5833 if (TYPE_CODE (type) != TYPE_CODE_STRUCT &&
5834 TYPE_CODE (type) != TYPE_CODE_UNION)
5836 target_terminal_ours ();
5837 gdb_flush (gdb_stdout);
5838 fprintf_unfiltered (gdb_stderr, "Type ");
5839 type_print (type, "", gdb_stderr, -1);
5840 error (" is not a structure or union type");
5843 type = to_static_fixed_type (type);
5845 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5847 char *t_field_name = TYPE_FIELD_NAME (type, i);
5851 if (t_field_name == NULL)
5854 else if (field_name_match (t_field_name, name))
5857 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
5858 return check_typedef (TYPE_FIELD_TYPE (type, i));
5861 else if (ada_is_wrapper_field (type, i))
5864 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
5869 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
5874 else if (ada_is_variant_part (type, i))
5877 struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, i));
5879 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
5882 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
5887 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
5898 target_terminal_ours ();
5899 gdb_flush (gdb_stdout);
5900 fprintf_unfiltered (gdb_stderr, "Type ");
5901 type_print (type, "", gdb_stderr, -1);
5902 fprintf_unfiltered (gdb_stderr, " has no component named ");
5903 error ("%s", name == NULL ? "<null>" : name);
5909 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5910 within a value of type OUTER_TYPE that is stored in GDB at
5911 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5912 numbering from 0) is applicable. Returns -1 if none are. */
5915 ada_which_variant_applies (var_type, outer_type, outer_valaddr)
5916 struct type *var_type;
5917 struct type *outer_type;
5918 char* outer_valaddr;
5923 struct type* discrim_type;
5924 char* discrim_name = ada_variant_discrim_name (var_type);
5925 LONGEST discrim_val;
5929 ada_lookup_struct_elt_type (outer_type, discrim_name, 1, &disp);
5930 if (discrim_type == NULL)
5932 discrim_val = unpack_long (discrim_type, outer_valaddr + disp);
5935 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
5937 if (ada_is_others_clause (var_type, i))
5939 else if (ada_in_variant (discrim_val, var_type, i))
5943 return others_clause;
5948 /* Dynamic-Sized Records */
5950 /* Strategy: The type ostensibly attached to a value with dynamic size
5951 (i.e., a size that is not statically recorded in the debugging
5952 data) does not accurately reflect the size or layout of the value.
5953 Our strategy is to convert these values to values with accurate,
5954 conventional types that are constructed on the fly. */
5956 /* There is a subtle and tricky problem here. In general, we cannot
5957 determine the size of dynamic records without its data. However,
5958 the 'struct value' data structure, which GDB uses to represent
5959 quantities in the inferior process (the target), requires the size
5960 of the type at the time of its allocation in order to reserve space
5961 for GDB's internal copy of the data. That's why the
5962 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5963 rather than struct value*s.
5965 However, GDB's internal history variables ($1, $2, etc.) are
5966 struct value*s containing internal copies of the data that are not, in
5967 general, the same as the data at their corresponding addresses in
5968 the target. Fortunately, the types we give to these values are all
5969 conventional, fixed-size types (as per the strategy described
5970 above), so that we don't usually have to perform the
5971 'to_fixed_xxx_type' conversions to look at their values.
5972 Unfortunately, there is one exception: if one of the internal
5973 history variables is an array whose elements are unconstrained
5974 records, then we will need to create distinct fixed types for each
5975 element selected. */
5977 /* The upshot of all of this is that many routines take a (type, host
5978 address, target address) triple as arguments to represent a value.
5979 The host address, if non-null, is supposed to contain an internal
5980 copy of the relevant data; otherwise, the program is to consult the
5981 target at the target address. */
5983 /* Assuming that VAL0 represents a pointer value, the result of
5984 dereferencing it. Differs from value_ind in its treatment of
5985 dynamic-sized types. */
5988 ada_value_ind (val0)
5991 struct value* val = unwrap_value (value_ind (val0));
5992 return ada_to_fixed_value (VALUE_TYPE (val), 0,
5993 VALUE_ADDRESS (val) + VALUE_OFFSET (val),
5997 /* The value resulting from dereferencing any "reference to"
5998 * qualifiers on VAL0. */
5999 static struct value*
6000 ada_coerce_ref (val0)
6003 if (TYPE_CODE (VALUE_TYPE (val0)) == TYPE_CODE_REF) {
6004 struct value* val = val0;
6006 val = unwrap_value (val);
6007 return ada_to_fixed_value (VALUE_TYPE (val), 0,
6008 VALUE_ADDRESS (val) + VALUE_OFFSET (val),
6014 /* Return OFF rounded upward if necessary to a multiple of
6015 ALIGNMENT (a power of 2). */
6018 align_value (off, alignment)
6020 unsigned int alignment;
6022 return (off + alignment - 1) & ~(alignment - 1);
6025 /* Return the additional bit offset required by field F of template
6029 field_offset (type, f)
6033 int n = TYPE_FIELD_BITPOS (type, f);
6034 /* Kludge (temporary?) to fix problem with dwarf output. */
6036 return (unsigned int) n & 0xffff;
6042 /* Return the bit alignment required for field #F of template type TYPE. */
6045 field_alignment (type, f)
6049 const char* name = TYPE_FIELD_NAME (type, f);
6050 int len = (name == NULL) ? 0 : strlen (name);
6053 if (len < 8 || ! isdigit (name[len-1]))
6054 return TARGET_CHAR_BIT;
6056 if (isdigit (name[len-2]))
6057 align_offset = len - 2;
6059 align_offset = len - 1;
6061 if (align_offset < 7 || ! STREQN ("___XV", name+align_offset-6, 5))
6062 return TARGET_CHAR_BIT;
6064 return atoi (name+align_offset) * TARGET_CHAR_BIT;
6067 /* Find a type named NAME. Ignores ambiguity. */
6069 ada_find_any_type (name)
6074 sym = standard_lookup (name, VAR_NAMESPACE);
6075 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
6076 return SYMBOL_TYPE (sym);
6078 sym = standard_lookup (name, STRUCT_NAMESPACE);
6080 return SYMBOL_TYPE (sym);
6085 /* Because of GNAT encoding conventions, several GDB symbols may match a
6086 given type name. If the type denoted by TYPE0 is to be preferred to
6087 that of TYPE1 for purposes of type printing, return non-zero;
6088 otherwise return 0. */
6090 ada_prefer_type (type0, type1)
6096 else if (type0 == NULL)
6098 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
6100 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
6102 else if (ada_is_packed_array_type (type0))
6104 else if (ada_is_array_descriptor (type0) && ! ada_is_array_descriptor (type1))
6106 else if (ada_renaming_type (type0) != NULL
6107 && ada_renaming_type (type1) == NULL)
6112 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6113 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6115 ada_type_name (type)
6120 else if (TYPE_NAME (type) != NULL)
6121 return TYPE_NAME (type);
6123 return TYPE_TAG_NAME (type);
6126 /* Find a parallel type to TYPE whose name is formed by appending
6127 SUFFIX to the name of TYPE. */
6130 ada_find_parallel_type (type, suffix)
6135 static size_t name_len = 0;
6136 struct symbol** syms;
6137 struct block** blocks;
6140 char* typename = ada_type_name (type);
6142 if (typename == NULL)
6145 len = strlen (typename);
6147 GROW_VECT (name, name_len, len+strlen (suffix)+1);
6149 strcpy (name, typename);
6150 strcpy (name + len, suffix);
6152 return ada_find_any_type (name);
6156 /* If TYPE is a variable-size record type, return the corresponding template
6157 type describing its fields. Otherwise, return NULL. */
6160 dynamic_template_type (type)
6163 CHECK_TYPEDEF (type);
6165 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
6166 || ada_type_name (type) == NULL)
6170 int len = strlen (ada_type_name (type));
6171 if (len > 6 && STREQ (ada_type_name (type) + len - 6, "___XVE"))
6174 return ada_find_parallel_type (type, "___XVE");
6178 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6179 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6182 is_dynamic_field (templ_type, field_num)
6183 struct type* templ_type;
6186 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
6188 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
6189 && strstr (name, "___XVL") != NULL;
6192 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
6193 contains a variant part. */
6196 contains_variant_part (type)
6201 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
6202 || TYPE_NFIELDS (type) <= 0)
6204 return ada_is_variant_part (type, TYPE_NFIELDS (type) - 1);
6207 /* A record type with no fields, . */
6209 empty_record (objfile)
6210 struct objfile* objfile;
6212 struct type* type = alloc_type (objfile);
6213 TYPE_CODE (type) = TYPE_CODE_STRUCT;
6214 TYPE_NFIELDS (type) = 0;
6215 TYPE_FIELDS (type) = NULL;
6216 TYPE_NAME (type) = "<empty>";
6217 TYPE_TAG_NAME (type) = NULL;
6218 TYPE_FLAGS (type) = 0;
6219 TYPE_LENGTH (type) = 0;
6223 /* An ordinary record type (with fixed-length fields) that describes
6224 the value of type TYPE at VALADDR or ADDRESS (see comments at
6225 the beginning of this section) VAL according to GNAT conventions.
6226 DVAL0 should describe the (portion of a) record that contains any
6227 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
6228 an outer-level type (i.e., as opposed to a branch of a variant.) A
6229 variant field (unless unchecked) is replaced by a particular branch
6231 /* NOTE: Limitations: For now, we assume that dynamic fields and
6232 * variants occupy whole numbers of bytes. However, they need not be
6236 template_to_fixed_record_type (type, valaddr, address, dval0)
6240 struct value* dval0;
6243 struct value* mark = value_mark();
6246 int nfields, bit_len;
6250 nfields = TYPE_NFIELDS (type);
6251 rtype = alloc_type (TYPE_OBJFILE (type));
6252 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6253 INIT_CPLUS_SPECIFIC (rtype);
6254 TYPE_NFIELDS (rtype) = nfields;
6255 TYPE_FIELDS (rtype) = (struct field*)
6256 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6257 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
6258 TYPE_NAME (rtype) = ada_type_name (type);
6259 TYPE_TAG_NAME (rtype) = NULL;
6260 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
6262 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE;*/
6264 off = 0; bit_len = 0;
6265 for (f = 0; f < nfields; f += 1)
6267 int fld_bit_len, bit_incr;
6269 align_value (off, field_alignment (type, f))+TYPE_FIELD_BITPOS (type,f);
6270 /* NOTE: used to use field_offset above, but that causes
6271 * problems with really negative bit positions. So, let's
6272 * rediscover why we needed field_offset and fix it properly. */
6273 TYPE_FIELD_BITPOS (rtype, f) = off;
6274 TYPE_FIELD_BITSIZE (rtype, f) = 0;
6276 if (ada_is_variant_part (type, f))
6278 struct type *branch_type;
6282 value_from_contents_and_address (rtype, valaddr, address);
6287 to_fixed_variant_branch_type
6288 (TYPE_FIELD_TYPE (type, f),
6289 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6290 cond_offset_target (address, off / TARGET_CHAR_BIT),
6292 if (branch_type == NULL)
6293 TYPE_NFIELDS (rtype) -= 1;
6296 TYPE_FIELD_TYPE (rtype, f) = branch_type;
6297 TYPE_FIELD_NAME (rtype, f) = "S";
6301 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6303 else if (is_dynamic_field (type, f))
6307 value_from_contents_and_address (rtype, valaddr, address);
6311 TYPE_FIELD_TYPE (rtype, f) =
6314 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
6315 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6316 cond_offset_target (address, off / TARGET_CHAR_BIT),
6318 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6319 bit_incr = fld_bit_len =
6320 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6324 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
6325 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6326 if (TYPE_FIELD_BITSIZE (type, f) > 0)
6327 bit_incr = fld_bit_len =
6328 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
6330 bit_incr = fld_bit_len =
6331 TYPE_LENGTH (TYPE_FIELD_TYPE (type, f)) * TARGET_CHAR_BIT;
6333 if (off + fld_bit_len > bit_len)
6334 bit_len = off + fld_bit_len;
6336 TYPE_LENGTH (rtype) = bit_len / TARGET_CHAR_BIT;
6338 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype), TYPE_LENGTH (type));
6340 value_free_to_mark (mark);
6341 if (TYPE_LENGTH (rtype) > varsize_limit)
6342 error ("record type with dynamic size is larger than varsize-limit");
6346 /* As for template_to_fixed_record_type, but uses no run-time values.
6347 As a result, this type can only be approximate, but that's OK,
6348 since it is used only for type determinations. Works on both
6350 Representation note: to save space, we memoize the result of this
6351 function in the TYPE_TARGET_TYPE of the template type. */
6354 template_to_static_fixed_type (templ_type)
6355 struct type* templ_type;
6361 if (TYPE_TARGET_TYPE (templ_type) != NULL)
6362 return TYPE_TARGET_TYPE (templ_type);
6364 nfields = TYPE_NFIELDS (templ_type);
6365 TYPE_TARGET_TYPE (templ_type) = type = alloc_type (TYPE_OBJFILE (templ_type));
6366 TYPE_CODE (type) = TYPE_CODE (templ_type);
6367 INIT_CPLUS_SPECIFIC (type);
6368 TYPE_NFIELDS (type) = nfields;
6369 TYPE_FIELDS (type) = (struct field*)
6370 TYPE_ALLOC (type, nfields * sizeof (struct field));
6371 memset (TYPE_FIELDS (type), 0, sizeof (struct field) * nfields);
6372 TYPE_NAME (type) = ada_type_name (templ_type);
6373 TYPE_TAG_NAME (type) = NULL;
6374 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6375 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6376 TYPE_LENGTH (type) = 0;
6378 for (f = 0; f < nfields; f += 1)
6380 TYPE_FIELD_BITPOS (type, f) = 0;
6381 TYPE_FIELD_BITSIZE (type, f) = 0;
6383 if (is_dynamic_field (templ_type, f))
6385 TYPE_FIELD_TYPE (type, f) =
6386 to_static_fixed_type (TYPE_TARGET_TYPE
6387 (TYPE_FIELD_TYPE (templ_type, f)));
6388 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (templ_type, f);
6392 TYPE_FIELD_TYPE (type, f) =
6393 check_typedef (TYPE_FIELD_TYPE (templ_type, f));
6394 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (templ_type, f);
6401 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6402 part -- in which the variant part is replaced with the appropriate
6405 to_record_with_fixed_variant_part (type, valaddr, address, dval)
6411 struct value* mark = value_mark();
6413 struct type *branch_type;
6414 int nfields = TYPE_NFIELDS (type);
6419 rtype = alloc_type (TYPE_OBJFILE (type));
6420 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6421 INIT_CPLUS_SPECIFIC (type);
6422 TYPE_NFIELDS (rtype) = TYPE_NFIELDS (type);
6423 TYPE_FIELDS (rtype) =
6424 (struct field*) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6425 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
6426 sizeof (struct field) * nfields);
6427 TYPE_NAME (rtype) = ada_type_name (type);
6428 TYPE_TAG_NAME (rtype) = NULL;
6429 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6430 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6431 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
6434 to_fixed_variant_branch_type
6435 (TYPE_FIELD_TYPE (type, nfields - 1),
6436 cond_offset_host (valaddr,
6437 TYPE_FIELD_BITPOS (type, nfields-1) / TARGET_CHAR_BIT),
6438 cond_offset_target (address,
6439 TYPE_FIELD_BITPOS (type, nfields-1) / TARGET_CHAR_BIT),
6441 if (branch_type == NULL)
6443 TYPE_NFIELDS (rtype) -= 1;
6444 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, nfields - 1));
6448 TYPE_FIELD_TYPE (rtype, nfields-1) = branch_type;
6449 TYPE_FIELD_NAME (rtype, nfields-1) = "S";
6450 TYPE_FIELD_BITSIZE (rtype, nfields-1) = 0;
6451 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
6452 - TYPE_LENGTH (TYPE_FIELD_TYPE (type, nfields - 1));
6458 /* An ordinary record type (with fixed-length fields) that describes
6459 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6460 beginning of this section]. Any necessary discriminants' values
6461 should be in DVAL, a record value; it should be NULL if the object
6462 at ADDR itself contains any necessary discriminant values. A
6463 variant field (unless unchecked) is replaced by a particular branch
6467 to_fixed_record_type (type0, valaddr, address, dval)
6473 struct type* templ_type;
6475 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6476 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6479 templ_type = dynamic_template_type (type0);
6481 if (templ_type != NULL)
6482 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
6483 else if (contains_variant_part (type0))
6484 return to_record_with_fixed_variant_part (type0, valaddr, address, dval);
6487 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6488 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6494 /* An ordinary record type (with fixed-length fields) that describes
6495 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6496 union type. Any necessary discriminants' values should be in DVAL,
6497 a record value. That is, this routine selects the appropriate
6498 branch of the union at ADDR according to the discriminant value
6499 indicated in the union's type name. */
6502 to_fixed_variant_branch_type (var_type0, valaddr, address, dval)
6503 struct type* var_type0;
6509 struct type* templ_type;
6510 struct type* var_type;
6512 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
6513 var_type = TYPE_TARGET_TYPE (var_type0);
6515 var_type = var_type0;
6517 templ_type = ada_find_parallel_type (var_type, "___XVU");
6519 if (templ_type != NULL)
6520 var_type = templ_type;
6523 ada_which_variant_applies (var_type,
6524 VALUE_TYPE (dval), VALUE_CONTENTS (dval));
6527 return empty_record (TYPE_OBJFILE (var_type));
6528 else if (is_dynamic_field (var_type, which))
6530 to_fixed_record_type
6531 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
6532 valaddr, address, dval);
6533 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type, which)))
6535 to_fixed_record_type
6536 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
6538 return TYPE_FIELD_TYPE (var_type, which);
6541 /* Assuming that TYPE0 is an array type describing the type of a value
6542 at ADDR, and that DVAL describes a record containing any
6543 discriminants used in TYPE0, returns a type for the value that
6544 contains no dynamic components (that is, no components whose sizes
6545 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6546 true, gives an error message if the resulting type's size is over
6551 to_fixed_array_type (type0, dval, ignore_too_big)
6556 struct type* index_type_desc;
6557 struct type* result;
6559 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6560 /* if (ada_is_packed_array_type (type0) /* revisit? */ /*
6561 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6564 index_type_desc = ada_find_parallel_type (type0, "___XA");
6565 if (index_type_desc == NULL)
6567 struct type *elt_type0 = check_typedef (TYPE_TARGET_TYPE (type0));
6568 /* NOTE: elt_type---the fixed version of elt_type0---should never
6569 * depend on the contents of the array in properly constructed
6570 * debugging data. */
6571 struct type *elt_type =
6572 ada_to_fixed_type (elt_type0, 0, 0, dval);
6574 if (elt_type0 == elt_type)
6577 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
6578 elt_type, TYPE_INDEX_TYPE (type0));
6583 struct type *elt_type0;
6586 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
6587 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
6589 /* NOTE: result---the fixed version of elt_type0---should never
6590 * depend on the contents of the array in properly constructed
6591 * debugging data. */
6593 ada_to_fixed_type (check_typedef (elt_type0), 0, 0, dval);
6594 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
6596 struct type *range_type =
6597 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i),
6598 dval, TYPE_OBJFILE (type0));
6599 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
6600 result, range_type);
6602 if (! ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
6603 error ("array type with dynamic size is larger than varsize-limit");
6606 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6607 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6612 /* A standard type (containing no dynamically sized components)
6613 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6614 DVAL describes a record containing any discriminants used in TYPE0,
6615 and may be NULL if there are none. */
6618 ada_to_fixed_type (type, valaddr, address, dval)
6624 CHECK_TYPEDEF (type);
6625 switch (TYPE_CODE (type)) {
6628 case TYPE_CODE_STRUCT:
6629 return to_fixed_record_type (type, valaddr, address, NULL);
6630 case TYPE_CODE_ARRAY:
6631 return to_fixed_array_type (type, dval, 0);
6632 case TYPE_CODE_UNION:
6636 return to_fixed_variant_branch_type (type, valaddr, address, dval);
6640 /* A standard (static-sized) type corresponding as well as possible to
6641 TYPE0, but based on no runtime data. */
6644 to_static_fixed_type (type0)
6652 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6653 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6656 CHECK_TYPEDEF (type0);
6658 switch (TYPE_CODE (type0))
6662 case TYPE_CODE_STRUCT:
6663 type = dynamic_template_type (type0);
6665 return template_to_static_fixed_type (type);
6667 case TYPE_CODE_UNION:
6668 type = ada_find_parallel_type (type0, "___XVU");
6670 return template_to_static_fixed_type (type);
6675 /* A static approximation of TYPE with all type wrappers removed. */
6677 static_unwrap_type (type)
6680 if (ada_is_aligner_type (type))
6682 struct type* type1 = TYPE_FIELD_TYPE (check_typedef (type), 0);
6683 if (ada_type_name (type1) == NULL)
6684 TYPE_NAME (type1) = ada_type_name (type);
6686 return static_unwrap_type (type1);
6690 struct type* raw_real_type = ada_get_base_type (type);
6691 if (raw_real_type == type)
6694 return to_static_fixed_type (raw_real_type);
6698 /* In some cases, incomplete and private types require
6699 cross-references that are not resolved as records (for example,
6701 type FooP is access Foo;
6703 type Foo is array ...;
6704 ). In these cases, since there is no mechanism for producing
6705 cross-references to such types, we instead substitute for FooP a
6706 stub enumeration type that is nowhere resolved, and whose tag is
6707 the name of the actual type. Call these types "non-record stubs". */
6709 /* A type equivalent to TYPE that is not a non-record stub, if one
6710 exists, otherwise TYPE. */
6712 ada_completed_type (type)
6715 CHECK_TYPEDEF (type);
6716 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
6717 || (TYPE_FLAGS (type) & TYPE_FLAG_STUB) == 0
6718 || TYPE_TAG_NAME (type) == NULL)
6722 char* name = TYPE_TAG_NAME (type);
6723 struct type* type1 = ada_find_any_type (name);
6724 return (type1 == NULL) ? type : type1;
6728 /* A value representing the data at VALADDR/ADDRESS as described by
6729 type TYPE0, but with a standard (static-sized) type that correctly
6730 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6731 type, then return VAL0 [this feature is simply to avoid redundant
6732 creation of struct values]. */
6735 ada_to_fixed_value (type0, valaddr, address, val0)
6741 struct type* type = ada_to_fixed_type (type0, valaddr, address, NULL);
6742 if (type == type0 && val0 != NULL)
6744 else return value_from_contents_and_address (type, valaddr, address);
6747 /* A value representing VAL, but with a standard (static-sized) type
6748 chosen to approximate the real type of VAL as well as possible, but
6749 without consulting any runtime values. For Ada dynamic-sized
6750 types, therefore, the type of the result is likely to be inaccurate. */
6753 ada_to_static_fixed_value (val)
6757 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val)));
6758 if (type == VALUE_TYPE (val))
6761 return coerce_unspec_val_to_type (val, 0, type);
6770 /* Table mapping attribute numbers to names */
6771 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6773 static const char* attribute_names[] = {
6791 ada_attribute_name (n)
6794 if (n > 0 && n < (int) ATR_END)
6795 return attribute_names[n];
6797 return attribute_names[0];
6800 /* Evaluate the 'POS attribute applied to ARG. */
6802 static struct value*
6806 struct type *type = VALUE_TYPE (arg);
6808 if (! discrete_type_p (type))
6809 error ("'POS only defined on discrete types");
6811 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
6814 LONGEST v = value_as_long (arg);
6816 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6818 if (v == TYPE_FIELD_BITPOS (type, i))
6819 return value_from_longest (builtin_type_ada_int, i);
6821 error ("enumeration value is invalid: can't find 'POS");
6824 return value_from_longest (builtin_type_ada_int, value_as_long (arg));
6827 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6829 static struct value*
6830 value_val_atr (type, arg)
6834 if (! discrete_type_p (type))
6835 error ("'VAL only defined on discrete types");
6836 if (! integer_type_p (VALUE_TYPE (arg)))
6837 error ("'VAL requires integral argument");
6839 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
6841 long pos = value_as_long (arg);
6842 if (pos < 0 || pos >= TYPE_NFIELDS (type))
6843 error ("argument to 'VAL out of range");
6845 value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
6848 return value_from_longest (type, value_as_long (arg));
6854 /* True if TYPE appears to be an Ada character type.
6855 * [At the moment, this is true only for Character and Wide_Character;
6856 * It is a heuristic test that could stand improvement]. */
6859 ada_is_character_type (type)
6862 const char* name = ada_type_name (type);
6865 && (TYPE_CODE (type) == TYPE_CODE_CHAR
6866 || TYPE_CODE (type) == TYPE_CODE_INT
6867 || TYPE_CODE (type) == TYPE_CODE_RANGE)
6868 && (STREQ (name, "character") || STREQ (name, "wide_character")
6869 || STREQ (name, "unsigned char"));
6872 /* True if TYPE appears to be an Ada string type. */
6875 ada_is_string_type (type)
6878 CHECK_TYPEDEF (type);
6880 && TYPE_CODE (type) != TYPE_CODE_PTR
6881 && (ada_is_simple_array (type) || ada_is_array_descriptor (type))
6882 && ada_array_arity (type) == 1)
6884 struct type *elttype = ada_array_element_type (type, 1);
6886 return ada_is_character_type (elttype);
6893 /* True if TYPE is a struct type introduced by the compiler to force the
6894 alignment of a value. Such types have a single field with a
6895 distinctive name. */
6898 ada_is_aligner_type (type)
6901 CHECK_TYPEDEF (type);
6902 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
6903 && TYPE_NFIELDS (type) == 1
6904 && STREQ (TYPE_FIELD_NAME (type, 0), "F"));
6907 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6908 the parallel type. */
6911 ada_get_base_type (raw_type)
6912 struct type* raw_type;
6914 struct type* real_type_namer;
6915 struct type* raw_real_type;
6916 struct type* real_type;
6918 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
6921 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
6922 if (real_type_namer == NULL
6923 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
6924 || TYPE_NFIELDS (real_type_namer) != 1)
6927 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
6928 if (raw_real_type == NULL)
6931 return raw_real_type;
6934 /* The type of value designated by TYPE, with all aligners removed. */
6937 ada_aligned_type (type)
6940 if (ada_is_aligner_type (type))
6941 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
6943 return ada_get_base_type (type);
6947 /* The address of the aligned value in an object at address VALADDR
6948 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6951 ada_aligned_value_addr (type, valaddr)
6955 if (ada_is_aligner_type (type))
6956 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
6958 TYPE_FIELD_BITPOS (type, 0)/TARGET_CHAR_BIT);
6963 /* The printed representation of an enumeration literal with encoded
6964 name NAME. The value is good to the next call of ada_enum_name. */
6966 ada_enum_name (name)
6973 if ((tmp = strstr (name, "__")) != NULL)
6975 else if ((tmp = strchr (name, '.')) != NULL)
6983 static char result[16];
6985 if (name[1] == 'U' || name[1] == 'W')
6987 if (sscanf (name+2, "%x", &v) != 1)
6993 if (isascii (v) && isprint (v))
6994 sprintf (result, "'%c'", v);
6995 else if (name[1] == 'U')
6996 sprintf (result, "[\"%02x\"]", v);
6998 sprintf (result, "[\"%04x\"]", v);
7006 static struct value*
7007 evaluate_subexp (expect_type, exp, pos, noside)
7008 struct type *expect_type;
7009 struct expression *exp;
7013 return (*exp->language_defn->evaluate_exp) (expect_type, exp, pos, noside);
7016 /* Evaluate the subexpression of EXP starting at *POS as for
7017 evaluate_type, updating *POS to point just past the evaluated
7020 static struct value*
7021 evaluate_subexp_type (exp, pos)
7022 struct expression* exp;
7025 return (*exp->language_defn->evaluate_exp)
7026 (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
7029 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7032 static struct value*
7036 struct type* type = check_typedef (VALUE_TYPE (val));
7037 if (ada_is_aligner_type (type))
7039 struct value* v = value_struct_elt (&val, NULL, "F",
7040 NULL, "internal structure");
7041 struct type* val_type = check_typedef (VALUE_TYPE (v));
7042 if (ada_type_name (val_type) == NULL)
7043 TYPE_NAME (val_type) = ada_type_name (type);
7045 return unwrap_value (v);
7049 struct type* raw_real_type =
7050 ada_completed_type (ada_get_base_type (type));
7052 if (type == raw_real_type)
7056 coerce_unspec_val_to_type
7057 (val, 0, ada_to_fixed_type (raw_real_type, 0,
7058 VALUE_ADDRESS (val) + VALUE_OFFSET (val),
7063 static struct value*
7064 cast_to_fixed (type, arg)
7070 if (type == VALUE_TYPE (arg))
7072 else if (ada_is_fixed_point_type (VALUE_TYPE (arg)))
7073 val = ada_float_to_fixed (type,
7074 ada_fixed_to_float (VALUE_TYPE (arg),
7075 value_as_long (arg)));
7079 value_as_double (value_cast (builtin_type_double, value_copy (arg)));
7080 val = ada_float_to_fixed (type, argd);
7083 return value_from_longest (type, val);
7086 static struct value*
7087 cast_from_fixed_to_double (arg)
7090 DOUBLEST val = ada_fixed_to_float (VALUE_TYPE (arg),
7091 value_as_long (arg));
7092 return value_from_double (builtin_type_double, val);
7095 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7096 * return the converted value. */
7097 static struct value*
7098 coerce_for_assign (type, val)
7102 struct type* type2 = VALUE_TYPE (val);
7106 CHECK_TYPEDEF (type2);
7107 CHECK_TYPEDEF (type);
7109 if (TYPE_CODE (type2) == TYPE_CODE_PTR && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7111 val = ada_value_ind (val);
7112 type2 = VALUE_TYPE (val);
7115 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
7116 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
7118 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
7119 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
7120 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
7121 error ("Incompatible types in assignment");
7122 VALUE_TYPE (val) = type;
7128 ada_evaluate_subexp (expect_type, exp, pos, noside)
7129 struct type *expect_type;
7130 struct expression *exp;
7135 enum ada_attribute atr;
7136 int tem, tem2, tem3;
7138 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
7141 struct value* *argvec;
7143 pc = *pos; *pos += 1;
7144 op = exp->elts[pc].opcode;
7150 return unwrap_value (evaluate_subexp_standard (expect_type, exp, pos, noside));
7154 type = exp->elts[pc + 1].type;
7155 arg1 = evaluate_subexp (type, exp, pos, noside);
7156 if (noside == EVAL_SKIP)
7158 if (type != check_typedef (VALUE_TYPE (arg1)))
7160 if (ada_is_fixed_point_type (type))
7161 arg1 = cast_to_fixed (type, arg1);
7162 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
7163 arg1 = value_cast (type, cast_from_fixed_to_double (arg1));
7164 else if (VALUE_LVAL (arg1) == lval_memory)
7166 /* This is in case of the really obscure (and undocumented,
7167 but apparently expected) case of (Foo) Bar.all, where Bar
7168 is an integer constant and Foo is a dynamic-sized type.
7169 If we don't do this, ARG1 will simply be relabeled with
7171 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7172 return value_zero (to_static_fixed_type (type), not_lval);
7175 (type, 0, VALUE_ADDRESS (arg1) + VALUE_OFFSET (arg1), 0);
7178 arg1 = value_cast (type, arg1);
7182 /* FIXME: UNOP_QUAL should be defined in expression.h */
7185 type = exp->elts[pc + 1].type;
7186 return ada_evaluate_subexp (type, exp, pos, noside);
7189 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7190 arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
7191 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
7193 if (binop_user_defined_p (op, arg1, arg2))
7194 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
7197 if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
7198 arg2 = cast_to_fixed (VALUE_TYPE (arg1), arg2);
7199 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
7200 error ("Fixed-point values must be assigned to fixed-point variables");
7202 arg2 = coerce_for_assign (VALUE_TYPE (arg1), arg2);
7203 return ada_value_assign (arg1, arg2);
7207 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
7208 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
7209 if (noside == EVAL_SKIP)
7211 if (binop_user_defined_p (op, arg1, arg2))
7212 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
7215 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
7216 || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
7217 && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
7218 error ("Operands of fixed-point addition must have the same type");
7219 return value_cast (VALUE_TYPE (arg1), value_add (arg1, arg2));
7223 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
7224 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
7225 if (noside == EVAL_SKIP)
7227 if (binop_user_defined_p (op, arg1, arg2))
7228 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
7231 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
7232 || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
7233 && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
7234 error ("Operands of fixed-point subtraction must have the same type");
7235 return value_cast (VALUE_TYPE (arg1), value_sub (arg1, arg2));
7240 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7241 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7242 if (noside == EVAL_SKIP)
7244 if (binop_user_defined_p (op, arg1, arg2))
7245 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
7247 if (noside == EVAL_AVOID_SIDE_EFFECTS
7248 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
7249 return value_zero (VALUE_TYPE (arg1), not_lval);
7252 if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
7253 arg1 = cast_from_fixed_to_double (arg1);
7254 if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
7255 arg2 = cast_from_fixed_to_double (arg2);
7256 return value_binop (arg1, arg2, op);
7260 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7261 if (noside == EVAL_SKIP)
7263 if (unop_user_defined_p (op, arg1))
7264 return value_x_unop (arg1, op, EVAL_NORMAL);
7265 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
7266 return value_cast (VALUE_TYPE (arg1), value_neg (arg1));
7268 return value_neg (arg1);
7270 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7271 /* case OP_UNRESOLVED_VALUE:
7272 /* Only encountered when an unresolved symbol occurs in a
7273 context other than a function call, in which case, it is
7276 if (noside == EVAL_SKIP)
7279 error ("Unexpected unresolved symbol, %s, during evaluation",
7280 ada_demangle (exp->elts[pc + 2].name));
7284 if (noside == EVAL_SKIP)
7289 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7293 (to_static_fixed_type
7294 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc+2].symbol))),
7299 arg1 = unwrap_value (evaluate_subexp_standard (expect_type, exp, pos,
7301 return ada_to_fixed_value (VALUE_TYPE (arg1), 0,
7302 VALUE_ADDRESS (arg1) + VALUE_OFFSET(arg1),
7308 tem2 = longest_to_int (exp->elts[pc + 1].longconst);
7309 tem3 = longest_to_int (exp->elts[pc + 2].longconst);
7310 nargs = tem3 - tem2 + 1;
7311 type = expect_type ? check_typedef (expect_type) : NULL_TYPE;
7313 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
7314 for (tem = 0; tem == 0 || tem < nargs; tem += 1)
7315 /* At least one element gets inserted for the type */
7317 /* Ensure that array expressions are coerced into pointer objects. */
7318 argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside);
7320 if (noside == EVAL_SKIP)
7322 return value_array (tem2, tem3, argvec);
7327 /* Allocate arg vector, including space for the function to be
7328 called in argvec[0] and a terminating NULL */
7329 nargs = longest_to_int (exp->elts[pc + 1].longconst);
7330 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 2));
7332 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7333 /* FIXME: name should be defined in expresion.h */
7334 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7335 error ("Unexpected unresolved symbol, %s, during evaluation",
7336 ada_demangle (exp->elts[pc + 5].name));
7340 error ("unexpected code path, FIXME");
7344 for (tem = 0; tem <= nargs; tem += 1)
7345 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7348 if (noside == EVAL_SKIP)
7352 if (TYPE_CODE (VALUE_TYPE (argvec[0])) == TYPE_CODE_REF)
7353 argvec[0] = value_addr (argvec[0]);
7355 if (ada_is_packed_array_type (VALUE_TYPE (argvec[0])))
7356 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
7358 type = check_typedef (VALUE_TYPE (argvec[0]));
7359 if (TYPE_CODE (type) == TYPE_CODE_PTR)
7361 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type))))
7363 case TYPE_CODE_FUNC:
7364 type = check_typedef (TYPE_TARGET_TYPE (type));
7366 case TYPE_CODE_ARRAY:
7368 case TYPE_CODE_STRUCT:
7369 if (noside != EVAL_AVOID_SIDE_EFFECTS)
7370 argvec[0] = ada_value_ind (argvec[0]);
7371 type = check_typedef (TYPE_TARGET_TYPE (type));
7374 error ("cannot subscript or call something of type `%s'",
7375 ada_type_name (VALUE_TYPE (argvec[0])));
7380 switch (TYPE_CODE (type))
7382 case TYPE_CODE_FUNC:
7383 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7384 return allocate_value (TYPE_TARGET_TYPE (type));
7385 return call_function_by_hand (argvec[0], nargs, argvec + 1);
7386 case TYPE_CODE_STRUCT:
7388 int arity = ada_array_arity (type);
7389 type = ada_array_element_type (type, nargs);
7391 error ("cannot subscript or call a record");
7393 error ("wrong number of subscripts; expecting %d", arity);
7394 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7395 return allocate_value (ada_aligned_type (type));
7396 return unwrap_value (ada_value_subscript (argvec[0], nargs, argvec+1));
7398 case TYPE_CODE_ARRAY:
7399 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7401 type = ada_array_element_type (type, nargs);
7403 error ("element type of array unknown");
7405 return allocate_value (ada_aligned_type (type));
7408 unwrap_value (ada_value_subscript
7409 (ada_coerce_to_simple_array (argvec[0]),
7411 case TYPE_CODE_PTR: /* Pointer to array */
7412 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
7413 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7415 type = ada_array_element_type (type, nargs);
7417 error ("element type of array unknown");
7419 return allocate_value (ada_aligned_type (type));
7422 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
7426 error ("Internal error in evaluate_subexp");
7431 struct value* array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7433 = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
7435 = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
7436 if (noside == EVAL_SKIP)
7439 /* If this is a reference to an array, then dereference it */
7440 if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_REF
7441 && TYPE_TARGET_TYPE (VALUE_TYPE (array)) != NULL
7442 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array))) ==
7444 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE
7447 array = ada_coerce_ref (array);
7450 if (noside == EVAL_AVOID_SIDE_EFFECTS &&
7451 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array))))
7453 /* Try to dereference the array, in case it is an access to array */
7454 struct type * arrType = ada_type_of_array (array, 0);
7455 if (arrType != NULL)
7456 array = value_at_lazy (arrType, 0, NULL);
7458 if (ada_is_array_descriptor (VALUE_TYPE (array)))
7459 array = ada_coerce_to_simple_array (array);
7461 /* If at this point we have a pointer to an array, it means that
7462 it is a pointer to a simple (non-ada) array. We just then
7464 if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_PTR
7465 && TYPE_TARGET_TYPE (VALUE_TYPE (array)) != NULL
7466 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array))) ==
7469 array = ada_value_ind (array);
7472 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7473 /* The following will get the bounds wrong, but only in contexts
7474 where the value is not being requested (FIXME?). */
7477 return value_slice (array, lowbound, upper - lowbound + 1);
7480 /* FIXME: UNOP_MBR should be defined in expression.h */
7483 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7484 type = exp->elts[pc + 1].type;
7486 if (noside == EVAL_SKIP)
7489 switch (TYPE_CODE (type))
7492 warning ("Membership test incompletely implemented; always returns true");
7493 return value_from_longest (builtin_type_int, (LONGEST) 1);
7495 case TYPE_CODE_RANGE:
7496 arg2 = value_from_longest (builtin_type_int,
7497 (LONGEST) TYPE_LOW_BOUND (type));
7498 arg3 = value_from_longest (builtin_type_int,
7499 (LONGEST) TYPE_HIGH_BOUND (type));
7501 value_from_longest (builtin_type_int,
7502 (value_less (arg1,arg3)
7503 || value_equal (arg1,arg3))
7504 && (value_less (arg2,arg1)
7505 || value_equal (arg2,arg1)));
7508 /* FIXME: BINOP_MBR should be defined in expression.h */
7511 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7512 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7514 if (noside == EVAL_SKIP)
7517 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7518 return value_zero (builtin_type_int, not_lval);
7520 tem = longest_to_int (exp->elts[pc + 1].longconst);
7522 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7523 error ("invalid dimension number to '%s", "range");
7525 arg3 = ada_array_bound (arg2, tem, 1);
7526 arg2 = ada_array_bound (arg2, tem, 0);
7529 value_from_longest (builtin_type_int,
7530 (value_less (arg1,arg3)
7531 || value_equal (arg1,arg3))
7532 && (value_less (arg2,arg1)
7533 || value_equal (arg2,arg1)));
7535 /* FIXME: TERNOP_MBR should be defined in expression.h */
7537 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7538 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7539 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7541 if (noside == EVAL_SKIP)
7545 value_from_longest (builtin_type_int,
7546 (value_less (arg1,arg3)
7547 || value_equal (arg1,arg3))
7548 && (value_less (arg2,arg1)
7549 || value_equal (arg2,arg1)));
7551 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7552 /* case OP_ATTRIBUTE:
7554 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7558 error ("unexpected attribute encountered");
7564 struct type* type_arg;
7565 if (exp->elts[*pos].opcode == OP_TYPE)
7567 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7569 type_arg = exp->elts[pc + 5].type;
7573 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7577 if (exp->elts[*pos].opcode != OP_LONG)
7578 error ("illegal operand to '%s", ada_attribute_name (atr));
7579 tem = longest_to_int (exp->elts[*pos+2].longconst);
7582 if (noside == EVAL_SKIP)
7585 if (type_arg == NULL)
7587 arg1 = ada_coerce_ref (arg1);
7589 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7590 arg1 = ada_coerce_to_simple_array (arg1);
7592 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7593 error ("invalid dimension number to '%s",
7594 ada_attribute_name (atr));
7596 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7598 type = ada_index_type (VALUE_TYPE (arg1), tem);
7600 error ("attempt to take bound of something that is not an array");
7601 return allocate_value (type);
7607 error ("unexpected attribute encountered");
7609 return ada_array_bound (arg1, tem, 0);
7611 return ada_array_bound (arg1, tem, 1);
7613 return ada_array_length (arg1, tem);
7616 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7617 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7619 struct type* range_type;
7620 char* name = ada_type_name (type_arg);
7623 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7624 range_type = type_arg;
7626 error ("unimplemented type attribute");
7630 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7634 error ("unexpected attribute encountered");
7636 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7637 TYPE_LOW_BOUND (range_type));
7639 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7640 TYPE_HIGH_BOUND (range_type));
7643 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7648 error ("unexpected attribute encountered");
7650 return value_from_longest
7651 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7653 return value_from_longest
7655 TYPE_FIELD_BITPOS (type_arg,
7656 TYPE_NFIELDS (type_arg) - 1));
7659 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7660 error ("unimplemented type attribute");
7665 if (ada_is_packed_array_type (type_arg))
7666 type_arg = decode_packed_array_type (type_arg);
7668 if (tem < 1 || tem > ada_array_arity (type_arg))
7669 error ("invalid dimension number to '%s",
7670 ada_attribute_name (atr));
7672 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7674 type = ada_index_type (type_arg, tem);
7676 error ("attempt to take bound of something that is not an array");
7677 return allocate_value (type);
7683 error ("unexpected attribute encountered");
7685 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7686 return value_from_longest (type, low);
7688 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7689 return value_from_longest (type, high);
7691 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7692 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7693 return value_from_longest (type, high-low+1);
7699 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7700 if (noside == EVAL_SKIP)
7703 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7705 value_zero (ada_tag_type (arg1), not_lval);
7707 return ada_value_tag (arg1);
7711 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7712 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7713 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7714 if (noside == EVAL_SKIP)
7716 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7717 return value_zero (VALUE_TYPE (arg1), not_lval);
7719 return value_binop (arg1, arg2,
7720 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7724 struct type* type_arg = exp->elts[pc + 5].type;
7725 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7728 if (noside == EVAL_SKIP)
7731 if (! ada_is_modular_type (type_arg))
7732 error ("'modulus must be applied to modular type");
7734 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7735 ada_modulus (type_arg));
7740 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7741 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7742 if (noside == EVAL_SKIP)
7744 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7745 return value_zero (builtin_type_ada_int, not_lval);
7747 return value_pos_atr (arg1);
7750 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7751 if (noside == EVAL_SKIP)
7753 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7754 return value_zero (builtin_type_ada_int, not_lval);
7756 return value_from_longest (builtin_type_ada_int,
7758 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7761 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7762 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7763 type = exp->elts[pc + 5].type;
7764 if (noside == EVAL_SKIP)
7766 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7767 return value_zero (type, not_lval);
7769 return value_val_atr (type, arg1);
7772 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7773 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7774 if (noside == EVAL_SKIP)
7776 if (binop_user_defined_p (op, arg1, arg2))
7777 return unwrap_value (value_x_binop (arg1, arg2, op, OP_NULL,
7780 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7781 return value_zero (VALUE_TYPE (arg1), not_lval);
7783 return value_binop (arg1, arg2, op);
7786 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7787 if (noside == EVAL_SKIP)
7789 if (unop_user_defined_p (op, arg1))
7790 return unwrap_value (value_x_unop (arg1, op, EVAL_NORMAL));
7795 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7796 if (noside == EVAL_SKIP)
7798 if (value_less (arg1, value_zero (VALUE_TYPE (arg1), not_lval)))
7799 return value_neg (arg1);
7804 if (expect_type && TYPE_CODE (expect_type) == TYPE_CODE_PTR)
7805 expect_type = TYPE_TARGET_TYPE (check_typedef (expect_type));
7806 arg1 = evaluate_subexp (expect_type, exp, pos, noside);
7807 if (noside == EVAL_SKIP)
7809 type = check_typedef (VALUE_TYPE (arg1));
7810 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7812 if (ada_is_array_descriptor (type))
7813 /* GDB allows dereferencing GNAT array descriptors. */
7815 struct type* arrType = ada_type_of_array (arg1, 0);
7816 if (arrType == NULL)
7817 error ("Attempt to dereference null array pointer.");
7818 return value_at_lazy (arrType, 0, NULL);
7820 else if (TYPE_CODE (type) == TYPE_CODE_PTR
7821 || TYPE_CODE (type) == TYPE_CODE_REF
7822 /* In C you can dereference an array to get the 1st elt. */
7823 || TYPE_CODE (type) == TYPE_CODE_ARRAY
7827 (to_static_fixed_type
7828 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type)))),
7830 else if (TYPE_CODE (type) == TYPE_CODE_INT)
7831 /* GDB allows dereferencing an int. */
7832 return value_zero (builtin_type_int, lval_memory);
7834 error ("Attempt to take contents of a non-pointer value.");
7836 arg1 = ada_coerce_ref (arg1);
7837 type = check_typedef (VALUE_TYPE (arg1));
7839 if (ada_is_array_descriptor (type))
7840 /* GDB allows dereferencing GNAT array descriptors. */
7841 return ada_coerce_to_simple_array (arg1);
7843 return ada_value_ind (arg1);
7845 case STRUCTOP_STRUCT:
7846 tem = longest_to_int (exp->elts[pc + 1].longconst);
7847 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
7848 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7849 if (noside == EVAL_SKIP)
7851 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7852 return value_zero (ada_aligned_type
7853 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1),
7854 &exp->elts[pc + 2].string,
7858 return unwrap_value (ada_value_struct_elt (arg1,
7859 &exp->elts[pc + 2].string,
7862 /* The value is not supposed to be used. This is here to make it
7863 easier to accommodate expressions that contain types. */
7865 if (noside == EVAL_SKIP)
7867 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7868 return allocate_value (builtin_type_void);
7870 error ("Attempt to use a type name as an expression");
7873 tem = longest_to_int (exp->elts[pc + 1].longconst);
7874 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
7875 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7876 if (noside == EVAL_SKIP)
7878 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7879 return value_zero (ada_aligned_type
7880 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1),
7881 &exp->elts[pc + 2].string,
7885 return unwrap_value (ada_value_struct_elt (arg1,
7886 &exp->elts[pc + 2].string,
7891 return value_from_longest (builtin_type_long, (LONGEST) 1);
7897 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7898 type name that encodes the 'small and 'delta information.
7899 Otherwise, return NULL. */
7902 fixed_type_info (type)
7905 const char* name = ada_type_name (type);
7906 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
7908 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE)
7911 const char *tail = strstr (name, "___XF_");
7917 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
7918 return fixed_type_info (TYPE_TARGET_TYPE (type));
7923 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7926 ada_is_fixed_point_type (type)
7929 return fixed_type_info (type) != NULL;
7932 /* Assuming that TYPE is the representation of an Ada fixed-point
7933 type, return its delta, or -1 if the type is malformed and the
7934 delta cannot be determined. */
7940 const char *encoding = fixed_type_info (type);
7943 if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
7946 return (DOUBLEST) num / (DOUBLEST) den;
7949 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7950 factor ('SMALL value) associated with the type. */
7953 scaling_factor (type)
7956 const char *encoding = fixed_type_info (type);
7957 unsigned long num0, den0, num1, den1;
7960 n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);
7965 return (DOUBLEST) num1 / (DOUBLEST) den1;
7967 return (DOUBLEST) num0 / (DOUBLEST) den0;
7971 /* Assuming that X is the representation of a value of fixed-point
7972 type TYPE, return its floating-point equivalent. */
7975 ada_fixed_to_float (type, x)
7979 return (DOUBLEST) x * scaling_factor (type);
7982 /* The representation of a fixed-point value of type TYPE
7983 corresponding to the value X. */
7986 ada_float_to_fixed (type, x)
7990 return (LONGEST) (x / scaling_factor (type) + 0.5);
7994 /* VAX floating formats */
7996 /* Non-zero iff TYPE represents one of the special VAX floating-point
7999 ada_is_vax_floating_type (type)
8003 (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
8006 && (TYPE_CODE (type) == TYPE_CODE_INT
8007 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8008 && STREQN (ada_type_name (type) + name_len - 6, "___XF", 5);
8011 /* The type of special VAX floating-point type this is, assuming
8012 ada_is_vax_floating_point */
8014 ada_vax_float_type_suffix (type)
8017 return ada_type_name (type)[strlen (ada_type_name (type))-1];
8020 /* A value representing the special debugging function that outputs
8021 VAX floating-point values of the type represented by TYPE. Assumes
8022 ada_is_vax_floating_type (TYPE). */
8024 ada_vax_float_print_function (type)
8028 switch (ada_vax_float_type_suffix (type)) {
8031 get_var_value ("DEBUG_STRING_F", 0);
8034 get_var_value ("DEBUG_STRING_D", 0);
8037 get_var_value ("DEBUG_STRING_G", 0);
8039 error ("invalid VAX floating-point type");
8046 /* Scan STR beginning at position K for a discriminant name, and
8047 return the value of that discriminant field of DVAL in *PX. If
8048 PNEW_K is not null, put the position of the character beyond the
8049 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
8050 not alter *PX and *PNEW_K if unsuccessful. */
8053 scan_discrim_bound (str, k, dval, px, pnew_k)
8060 static char *bound_buffer = NULL;
8061 static size_t bound_buffer_len = 0;
8064 struct value* bound_val;
8066 if (dval == NULL || str == NULL || str[k] == '\0')
8069 pend = strstr (str+k, "__");
8073 k += strlen (bound);
8077 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str+k) + 1);
8078 bound = bound_buffer;
8079 strncpy (bound_buffer, str+k, pend-(str+k));
8080 bound[pend-(str+k)] = '\0';
8085 ada_search_struct_field (bound, dval, 0, VALUE_TYPE (dval));
8086 if (bound_val == NULL)
8089 *px = value_as_long (bound_val);
8095 /* Value of variable named NAME in the current environment. If
8096 no such variable found, then if ERR_MSG is null, returns 0, and
8097 otherwise causes an error with message ERR_MSG. */
8098 static struct value*
8099 get_var_value (name, err_msg)
8103 struct symbol** syms;
8104 struct block** blocks;
8107 nsyms = ada_lookup_symbol_list (name, get_selected_block (NULL), VAR_NAMESPACE,
8112 if (err_msg == NULL)
8115 error ("%s", err_msg);
8118 return value_of_variable (syms[0], blocks[0]);
8121 /* Value of integer variable named NAME in the current environment. If
8122 no such variable found, then if ERR_MSG is null, returns 0, and sets
8123 *FLAG to 0. If successful, sets *FLAG to 1. */
8125 get_int_var_value (name, err_msg, flag)
8130 struct value* var_val = get_var_value (name, err_msg);
8142 return value_as_long (var_val);
8147 /* Return a range type whose base type is that of the range type named
8148 NAME in the current environment, and whose bounds are calculated
8149 from NAME according to the GNAT range encoding conventions.
8150 Extract discriminant values, if needed, from DVAL. If a new type
8151 must be created, allocate in OBJFILE's space. The bounds
8152 information, in general, is encoded in NAME, the base type given in
8153 the named range type. */
8156 to_fixed_range_type (name, dval, objfile)
8159 struct objfile *objfile;
8161 struct type *raw_type = ada_find_any_type (name);
8162 struct type *base_type;
8166 if (raw_type == NULL)
8167 base_type = builtin_type_int;
8168 else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
8169 base_type = TYPE_TARGET_TYPE (raw_type);
8171 base_type = raw_type;
8173 subtype_info = strstr (name, "___XD");
8174 if (subtype_info == NULL)
8178 static char *name_buf = NULL;
8179 static size_t name_len = 0;
8180 int prefix_len = subtype_info - name;
8186 GROW_VECT (name_buf, name_len, prefix_len + 5);
8187 strncpy (name_buf, name, prefix_len);
8188 name_buf[prefix_len] = '\0';
8191 bounds_str = strchr (subtype_info, '_');
8194 if (*subtype_info == 'L')
8196 if (! ada_scan_number (bounds_str, n, &L, &n)
8197 && ! scan_discrim_bound (bounds_str, n, dval, &L, &n))
8199 if (bounds_str[n] == '_')
8201 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
8207 strcpy (name_buf+prefix_len, "___L");
8208 L = get_int_var_value (name_buf, "Index bound unknown.", NULL);
8211 if (*subtype_info == 'U')
8213 if (! ada_scan_number (bounds_str, n, &U, &n)
8214 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
8219 strcpy (name_buf+prefix_len, "___U");
8220 U = get_int_var_value (name_buf, "Index bound unknown.", NULL);
8223 if (objfile == NULL)
8224 objfile = TYPE_OBJFILE (base_type);
8225 type = create_range_type (alloc_type (objfile), base_type, L, U);
8226 TYPE_NAME (type) = name;
8231 /* True iff NAME is the name of a range type. */
8233 ada_is_range_type_name (name)
8236 return (name != NULL && strstr (name, "___XD"));
8242 /* True iff TYPE is an Ada modular type. */
8244 ada_is_modular_type (type)
8247 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
8249 struct type* subranged_type; /* = base_type (type);*/
8251 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
8252 && TYPE_CODE (subranged_type) != TYPE_CODE_ENUM
8253 && TYPE_UNSIGNED (subranged_type));
8256 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
8261 return TYPE_HIGH_BOUND (type) + 1;
8268 /* Table mapping opcodes into strings for printing operators
8269 and precedences of the operators. */
8271 static const struct op_print ada_op_print_tab[] =
8273 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
8274 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
8275 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
8276 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
8277 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
8278 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
8279 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
8280 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
8281 {"<=", BINOP_LEQ, PREC_ORDER, 0},
8282 {">=", BINOP_GEQ, PREC_ORDER, 0},
8283 {">", BINOP_GTR, PREC_ORDER, 0},
8284 {"<", BINOP_LESS, PREC_ORDER, 0},
8285 {">>", BINOP_RSH, PREC_SHIFT, 0},
8286 {"<<", BINOP_LSH, PREC_SHIFT, 0},
8287 {"+", BINOP_ADD, PREC_ADD, 0},
8288 {"-", BINOP_SUB, PREC_ADD, 0},
8289 {"&", BINOP_CONCAT, PREC_ADD, 0},
8290 {"*", BINOP_MUL, PREC_MUL, 0},
8291 {"/", BINOP_DIV, PREC_MUL, 0},
8292 {"rem", BINOP_REM, PREC_MUL, 0},
8293 {"mod", BINOP_MOD, PREC_MUL, 0},
8294 {"**", BINOP_EXP, PREC_REPEAT, 0 },
8295 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
8296 {"-", UNOP_NEG, PREC_PREFIX, 0},
8297 {"+", UNOP_PLUS, PREC_PREFIX, 0},
8298 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
8299 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
8300 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
8301 {".all", UNOP_IND, PREC_SUFFIX, 1}, /* FIXME: postfix .ALL */
8302 {"'access", UNOP_ADDR, PREC_SUFFIX, 1}, /* FIXME: postfix 'ACCESS */
8306 /* Assorted Types and Interfaces */
8308 struct type* builtin_type_ada_int;
8309 struct type* builtin_type_ada_short;
8310 struct type* builtin_type_ada_long;
8311 struct type* builtin_type_ada_long_long;
8312 struct type* builtin_type_ada_char;
8313 struct type* builtin_type_ada_float;
8314 struct type* builtin_type_ada_double;
8315 struct type* builtin_type_ada_long_double;
8316 struct type* builtin_type_ada_natural;
8317 struct type* builtin_type_ada_positive;
8318 struct type* builtin_type_ada_system_address;
8320 struct type ** const (ada_builtin_types[]) =
8323 &builtin_type_ada_int,
8324 &builtin_type_ada_long,
8325 &builtin_type_ada_short,
8326 &builtin_type_ada_char,
8327 &builtin_type_ada_float,
8328 &builtin_type_ada_double,
8329 &builtin_type_ada_long_long,
8330 &builtin_type_ada_long_double,
8331 &builtin_type_ada_natural,
8332 &builtin_type_ada_positive,
8334 /* The following types are carried over from C for convenience. */
8337 &builtin_type_short,
8339 &builtin_type_float,
8340 &builtin_type_double,
8341 &builtin_type_long_long,
8343 &builtin_type_signed_char,
8344 &builtin_type_unsigned_char,
8345 &builtin_type_unsigned_short,
8346 &builtin_type_unsigned_int,
8347 &builtin_type_unsigned_long,
8348 &builtin_type_unsigned_long_long,
8349 &builtin_type_long_double,
8350 &builtin_type_complex,
8351 &builtin_type_double_complex,
8355 /* Not really used, but needed in the ada_language_defn. */
8356 static void emit_char (int c, struct ui_file* stream, int quoter)
8358 ada_emit_char (c, stream, quoter, 1);
8361 const struct language_defn ada_language_defn = {
8362 "ada", /* Language name */
8365 /* FIXME: language_ada should be defined in defs.h */
8369 case_sensitive_on, /* Yes, Ada is case-insensitive, but
8370 * that's not quite what this means. */
8373 ada_evaluate_subexp,
8374 ada_printchar, /* Print a character constant */
8375 ada_printstr, /* Function to print string constant */
8376 emit_char, /* Function to print single char (not used) */
8377 ada_create_fundamental_type, /* Create fundamental type in this language */
8378 ada_print_type, /* Print a type using appropriate syntax */
8379 ada_val_print, /* Print a value using appropriate syntax */
8380 ada_value_print, /* Print a top-level value */
8381 {"", "", "", ""}, /* Binary format info */
8383 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8384 {"%ld", "", "d", ""}, /* Decimal format info */
8385 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8387 /* Copied from c-lang.c. */
8388 {"0%lo", "0", "o", ""}, /* Octal format info */
8389 {"%ld", "", "d", ""}, /* Decimal format info */
8390 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8392 ada_op_print_tab, /* expression operators for printing */
8393 1, /* c-style arrays (FIXME?) */
8394 0, /* String lower bound (FIXME?) */
8395 &builtin_type_ada_char,
8400 _initialize_ada_language ()
8402 builtin_type_ada_int =
8403 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8405 "integer", (struct objfile *) NULL);
8406 builtin_type_ada_long =
8407 init_type (TYPE_CODE_INT, TARGET_LONG_BIT / TARGET_CHAR_BIT,
8409 "long_integer", (struct objfile *) NULL);
8410 builtin_type_ada_short =
8411 init_type (TYPE_CODE_INT, TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8413 "short_integer", (struct objfile *) NULL);
8414 builtin_type_ada_char =
8415 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8417 "character", (struct objfile *) NULL);
8418 builtin_type_ada_float =
8419 init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
8421 "float", (struct objfile *) NULL);
8422 builtin_type_ada_double =
8423 init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
8425 "long_float", (struct objfile *) NULL);
8426 builtin_type_ada_long_long =
8427 init_type (TYPE_CODE_INT, TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8429 "long_long_integer", (struct objfile *) NULL);
8430 builtin_type_ada_long_double =
8431 init_type (TYPE_CODE_FLT, TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
8433 "long_long_float", (struct objfile *) NULL);
8434 builtin_type_ada_natural =
8435 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8437 "natural", (struct objfile *) NULL);
8438 builtin_type_ada_positive =
8439 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8441 "positive", (struct objfile *) NULL);
8444 builtin_type_ada_system_address =
8445 lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
8446 (struct objfile *) NULL));
8447 TYPE_NAME (builtin_type_ada_system_address) = "system__address";
8449 add_language (&ada_language_defn);
8452 (add_set_cmd ("varsize-limit", class_support, var_uinteger,
8453 (char*) &varsize_limit,
8454 "Set maximum bytes in dynamic-sized object.",
8457 varsize_limit = 65536;
8459 add_com ("begin", class_breakpoint, begin_command,
8460 "Start the debugged program, stopping at the beginning of the\n\
8461 main program. You may specify command-line arguments to give it, as for\n\
8462 the \"run\" command (q.v.).");
8466 /* Create a fundamental Ada type using default reasonable for the current
8469 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8470 define fundamental types such as "int" or "double". Others (stabs or
8471 DWARF version 2, etc) do define fundamental types. For the formats which
8472 don't provide fundamental types, gdb can create such types using this
8475 FIXME: Some compilers distinguish explicitly signed integral types
8476 (signed short, signed int, signed long) from "regular" integral types
8477 (short, int, long) in the debugging information. There is some dis-
8478 agreement as to how useful this feature is. In particular, gcc does
8479 not support this. Also, only some debugging formats allow the
8480 distinction to be passed on to a debugger. For now, we always just
8481 use "short", "int", or "long" as the type name, for both the implicit
8482 and explicitly signed types. This also makes life easier for the
8483 gdb test suite since we don't have to account for the differences
8484 in output depending upon what the compiler and debugging format
8485 support. We will probably have to re-examine the issue when gdb
8486 starts taking it's fundamental type information directly from the
8487 debugging information supplied by the compiler. fnf@cygnus.com */
8489 static struct type *
8490 ada_create_fundamental_type (objfile, typeid)
8491 struct objfile *objfile;
8494 struct type *type = NULL;
8499 /* FIXME: For now, if we are asked to produce a type not in this
8500 language, create the equivalent of a C integer type with the
8501 name "<?type?>". When all the dust settles from the type
8502 reconstruction work, this should probably become an error. */
8503 type = init_type (TYPE_CODE_INT,
8504 TARGET_INT_BIT / TARGET_CHAR_BIT,
8505 0, "<?type?>", objfile);
8506 warning ("internal error: no Ada fundamental type %d", typeid);
8509 type = init_type (TYPE_CODE_VOID,
8510 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8511 0, "void", objfile);
8514 type = init_type (TYPE_CODE_INT,
8515 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8516 0, "character", objfile);
8518 case FT_SIGNED_CHAR:
8519 type = init_type (TYPE_CODE_INT,
8520 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8521 0, "signed char", objfile);
8523 case FT_UNSIGNED_CHAR:
8524 type = init_type (TYPE_CODE_INT,
8525 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8526 TYPE_FLAG_UNSIGNED, "unsigned char", objfile);
8529 type = init_type (TYPE_CODE_INT,
8530 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8531 0, "short_integer", objfile);
8533 case FT_SIGNED_SHORT:
8534 type = init_type (TYPE_CODE_INT,
8535 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8536 0, "short_integer", objfile);
8538 case FT_UNSIGNED_SHORT:
8539 type = init_type (TYPE_CODE_INT,
8540 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8541 TYPE_FLAG_UNSIGNED, "unsigned short", objfile);
8544 type = init_type (TYPE_CODE_INT,
8545 TARGET_INT_BIT / TARGET_CHAR_BIT,
8546 0, "integer", objfile);
8548 case FT_SIGNED_INTEGER:
8549 type = init_type (TYPE_CODE_INT,
8550 TARGET_INT_BIT / TARGET_CHAR_BIT,
8551 0, "integer", objfile); /* FIXME -fnf */
8553 case FT_UNSIGNED_INTEGER:
8554 type = init_type (TYPE_CODE_INT,
8555 TARGET_INT_BIT / TARGET_CHAR_BIT,
8556 TYPE_FLAG_UNSIGNED, "unsigned int", objfile);
8559 type = init_type (TYPE_CODE_INT,
8560 TARGET_LONG_BIT / TARGET_CHAR_BIT,
8561 0, "long_integer", objfile);
8563 case FT_SIGNED_LONG:
8564 type = init_type (TYPE_CODE_INT,
8565 TARGET_LONG_BIT / TARGET_CHAR_BIT,
8566 0, "long_integer", objfile);
8568 case FT_UNSIGNED_LONG:
8569 type = init_type (TYPE_CODE_INT,
8570 TARGET_LONG_BIT / TARGET_CHAR_BIT,
8571 TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
8574 type = init_type (TYPE_CODE_INT,
8575 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8576 0, "long_long_integer", objfile);
8578 case FT_SIGNED_LONG_LONG:
8579 type = init_type (TYPE_CODE_INT,
8580 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8581 0, "long_long_integer", objfile);
8583 case FT_UNSIGNED_LONG_LONG:
8584 type = init_type (TYPE_CODE_INT,
8585 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8586 TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
8589 type = init_type (TYPE_CODE_FLT,
8590 TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
8591 0, "float", objfile);
8593 case FT_DBL_PREC_FLOAT:
8594 type = init_type (TYPE_CODE_FLT,
8595 TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
8596 0, "long_float", objfile);
8598 case FT_EXT_PREC_FLOAT:
8599 type = init_type (TYPE_CODE_FLT,
8600 TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
8601 0, "long_long_float", objfile);
8607 void ada_dump_symtab (struct symtab* s)
8610 fprintf (stderr, "New symtab: [\n");
8611 fprintf (stderr, " Name: %s/%s;\n",
8612 s->dirname ? s->dirname : "?",
8613 s->filename ? s->filename : "?");
8614 fprintf (stderr, " Format: %s;\n", s->debugformat);
8615 if (s->linetable != NULL)
8617 fprintf (stderr, " Line table (section %d):\n", s->block_line_section);
8618 for (i = 0; i < s->linetable->nitems; i += 1)
8620 struct linetable_entry* e = s->linetable->item + i;
8621 fprintf (stderr, " %4ld: %8lx\n", (long) e->line, (long) e->pc);
8624 fprintf (stderr, "]\n");