1 /* Ada language support routines for GDB, the GNU debugger. Copyright
2 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003
3 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
22 #include "gdb_string.h"
30 #include "expression.h"
31 #include "parser-defs.h"
37 #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 *,
88 static struct value *make_array_descriptor (struct type *, struct value *,
91 static void ada_add_block_symbols (struct block *, const char *,
92 namespace_enum, struct objfile *, int);
94 static void fill_in_ada_prototype (struct symbol *);
96 static int is_nonfunction (struct symbol **, int);
98 static void add_defn_to_vec (struct symbol *, struct block *);
100 static struct partial_symbol *ada_lookup_partial_symbol (struct partial_symtab
101 *, const char *, int,
102 namespace_enum, int);
104 static struct symtab *symtab_for_sym (struct symbol *);
106 static struct value *ada_resolve_subexp (struct expression **, int *, int,
109 static void replace_operator_with_call (struct expression **, int, int, int,
110 struct symbol *, struct block *);
112 static int possible_user_operator_p (enum exp_opcode, struct value **);
114 static const char *ada_op_name (enum exp_opcode);
116 static int numeric_type_p (struct type *);
118 static int integer_type_p (struct type *);
120 static int scalar_type_p (struct type *);
122 static int discrete_type_p (struct type *);
124 static char *extended_canonical_line_spec (struct symtab_and_line,
127 static struct value *evaluate_subexp (struct type *, struct expression *,
130 static struct value *evaluate_subexp_type (struct expression *, int *);
132 static struct type *ada_create_fundamental_type (struct objfile *, int);
134 static int is_dynamic_field (struct type *, int);
136 static struct type *to_fixed_variant_branch_type (struct type *, char *,
137 CORE_ADDR, struct value *);
139 static struct type *to_fixed_range_type (char *, struct value *,
142 static struct type *to_static_fixed_type (struct type *);
144 static struct value *unwrap_value (struct value *);
146 static struct type *packed_array_type (struct type *, long *);
148 static struct type *decode_packed_array_type (struct type *);
150 static struct value *decode_packed_array (struct value *);
152 static struct value *value_subscript_packed (struct value *, int,
155 static struct value *coerce_unspec_val_to_type (struct value *, long,
158 static struct value *get_var_value (char *, char *);
160 static int lesseq_defined_than (struct symbol *, struct symbol *);
162 static int equiv_types (struct type *, struct type *);
164 static int is_name_suffix (const char *);
166 static int wild_match (const char *, int, const char *);
168 static struct symtabs_and_lines find_sal_from_funcs_and_line (const char *,
173 static int find_line_in_linetable (struct linetable *, int, struct symbol **,
176 static int find_next_line_in_linetable (struct linetable *, int, int, int);
178 static struct symtabs_and_lines all_sals_for_line (const char *, int,
181 static void read_all_symtabs (const char *);
183 static int is_plausible_func_for_line (struct symbol *, int);
185 static struct value *ada_coerce_ref (struct value *);
187 static struct value *value_pos_atr (struct value *);
189 static struct value *value_val_atr (struct type *, struct value *);
191 static struct symbol *standard_lookup (const char *, namespace_enum);
193 extern void markTimeStart (int index);
194 extern void markTimeStop (int index);
198 /* Maximum-sized dynamic type. */
199 static unsigned int varsize_limit;
201 static const char *ada_completer_word_break_characters =
202 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
204 /* The name of the symbol to use to get the name of the main subprogram */
205 #define ADA_MAIN_PROGRAM_SYMBOL_NAME "__gnat_ada_main_program_name"
211 * read the string located at ADDR from the inferior and store the
215 extract_string (CORE_ADDR addr, char *buf)
219 /* Loop, reading one byte at a time, until we reach the '\000'
220 end-of-string marker */
223 target_read_memory (addr + char_index * sizeof (char),
224 buf + char_index * sizeof (char), sizeof (char));
227 while (buf[char_index - 1] != '\000');
230 /* Assuming *OLD_VECT points to an array of *SIZE objects of size
231 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
232 updating *OLD_VECT and *SIZE as necessary. */
235 grow_vect (void **old_vect, size_t * size, size_t min_size, int element_size)
237 if (*size < min_size)
240 if (*size < min_size)
242 *old_vect = xrealloc (*old_vect, *size * element_size);
246 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
247 suffix of FIELD_NAME beginning "___" */
250 field_name_match (const char *field_name, const char *target)
252 int len = strlen (target);
254 STREQN (field_name, target, len)
255 && (field_name[len] == '\0'
256 || (STREQN (field_name + len, "___", 3)
257 && !STREQ (field_name + strlen (field_name) - 6, "___XVN")));
261 /* The length of the prefix of NAME prior to any "___" suffix. */
264 ada_name_prefix_len (const char *name)
270 const char *p = strstr (name, "___");
272 return strlen (name);
278 /* SUFFIX is a suffix of STR. False if STR is null. */
280 is_suffix (const char *str, const char *suffix)
286 len2 = strlen (suffix);
287 return (len1 >= len2 && STREQ (str + len1 - len2, suffix));
290 /* Create a value of type TYPE whose contents come from VALADDR, if it
291 * is non-null, and whose memory address (in the inferior) is
294 value_from_contents_and_address (struct type *type, char *valaddr,
297 struct value *v = allocate_value (type);
301 memcpy (VALUE_CONTENTS_RAW (v), valaddr, TYPE_LENGTH (type));
302 VALUE_ADDRESS (v) = address;
304 VALUE_LVAL (v) = lval_memory;
308 /* The contents of value VAL, beginning at offset OFFSET, treated as a
309 value of type TYPE. The result is an lval in memory if VAL is. */
311 static struct value *
312 coerce_unspec_val_to_type (struct value *val, long offset, struct type *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,
321 struct value *result = allocate_value (type);
322 VALUE_LVAL (result) = not_lval;
323 if (VALUE_ADDRESS (val) == 0)
324 memcpy (VALUE_CONTENTS_RAW (result), VALUE_CONTENTS (val) + offset,
325 TYPE_LENGTH (type) > TYPE_LENGTH (VALUE_TYPE (val))
326 ? TYPE_LENGTH (VALUE_TYPE (val)) : TYPE_LENGTH (type));
329 VALUE_ADDRESS (result) =
330 VALUE_ADDRESS (val) + VALUE_OFFSET (val) + offset;
331 VALUE_LAZY (result) = 1;
338 cond_offset_host (char *valaddr, long offset)
343 return valaddr + offset;
347 cond_offset_target (CORE_ADDR address, long offset)
352 return address + offset;
355 /* Perform execute_command on the result of concatenating all
356 arguments up to NULL. */
358 do_command (const char *arg, ...)
369 for (; s != NULL; s = va_arg (ap, const char *))
373 cmd1 = alloca (len + 1);
379 execute_command (cmd, 0);
383 /* Language Selection */
385 /* If the main program is in Ada, return language_ada, otherwise return LANG
386 (the main program is in Ada iif the adainit symbol is found).
388 MAIN_PST is not used. */
391 ada_update_initial_language (enum language lang,
392 struct partial_symtab *main_pst)
394 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
395 (struct objfile *) NULL) != NULL)
396 /* return language_ada; */
397 /* FIXME: language_ada should be defined in defs.h */
398 return language_unknown;
406 /* Table of Ada operators and their GNAT-mangled names. Last entry is pair
409 const struct ada_opname_map ada_opname_table[] = {
410 {"Oadd", "\"+\"", BINOP_ADD},
411 {"Osubtract", "\"-\"", BINOP_SUB},
412 {"Omultiply", "\"*\"", BINOP_MUL},
413 {"Odivide", "\"/\"", BINOP_DIV},
414 {"Omod", "\"mod\"", BINOP_MOD},
415 {"Orem", "\"rem\"", BINOP_REM},
416 {"Oexpon", "\"**\"", BINOP_EXP},
417 {"Olt", "\"<\"", BINOP_LESS},
418 {"Ole", "\"<=\"", BINOP_LEQ},
419 {"Ogt", "\">\"", BINOP_GTR},
420 {"Oge", "\">=\"", BINOP_GEQ},
421 {"Oeq", "\"=\"", BINOP_EQUAL},
422 {"One", "\"/=\"", BINOP_NOTEQUAL},
423 {"Oand", "\"and\"", BINOP_BITWISE_AND},
424 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
425 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
426 {"Oconcat", "\"&\"", BINOP_CONCAT},
427 {"Oabs", "\"abs\"", UNOP_ABS},
428 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
429 {"Oadd", "\"+\"", UNOP_PLUS},
430 {"Osubtract", "\"-\"", UNOP_NEG},
434 /* True if STR should be suppressed in info listings. */
436 is_suppressed_name (const char *str)
438 if (STREQN (str, "_ada_", 5))
440 if (str[0] == '_' || str[0] == '\000')
445 const char *suffix = strstr (str, "___");
446 if (suffix != NULL && suffix[3] != 'X')
449 suffix = str + strlen (str);
450 for (p = suffix - 1; p != str; p -= 1)
454 if (p[0] == 'X' && p[-1] != '_')
458 for (i = 0; ada_opname_table[i].mangled != NULL; i += 1)
459 if (STREQN (ada_opname_table[i].mangled, p,
460 strlen (ada_opname_table[i].mangled)))
469 /* The "mangled" form of DEMANGLED, according to GNAT conventions.
470 * The result is valid until the next call to ada_mangle. */
472 ada_mangle (const char *demangled)
474 static char *mangling_buffer = NULL;
475 static size_t mangling_buffer_size = 0;
479 if (demangled == NULL)
482 GROW_VECT (mangling_buffer, mangling_buffer_size,
483 2 * strlen (demangled) + 10);
486 for (p = demangled; *p != '\0'; p += 1)
490 mangling_buffer[k] = mangling_buffer[k + 1] = '_';
495 const struct ada_opname_map *mapping;
497 for (mapping = ada_opname_table;
498 mapping->mangled != NULL &&
499 !STREQN (mapping->demangled, p, strlen (mapping->demangled));
502 if (mapping->mangled == NULL)
503 error ("invalid Ada operator name: %s", p);
504 strcpy (mangling_buffer + k, mapping->mangled);
505 k += strlen (mapping->mangled);
510 mangling_buffer[k] = *p;
515 mangling_buffer[k] = '\0';
516 return mangling_buffer;
519 /* Return NAME folded to lower case, or, if surrounded by single
520 * quotes, unfolded, but with the quotes stripped away. Result good
523 ada_fold_name (const char *name)
525 static char *fold_buffer = NULL;
526 static size_t fold_buffer_size = 0;
528 int len = strlen (name);
529 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
533 strncpy (fold_buffer, name + 1, len - 2);
534 fold_buffer[len - 2] = '\000';
539 for (i = 0; i <= len; i += 1)
540 fold_buffer[i] = tolower (name[i]);
547 1. Discard final __{DIGIT}+ or ${DIGIT}+
548 2. Convert other instances of embedded "__" to `.'.
549 3. Discard leading _ada_.
550 4. Convert operator names to the appropriate quoted symbols.
551 5. Remove everything after first ___ if it is followed by
553 6. Replace TK__ with __, and a trailing B or TKB with nothing.
554 7. Put symbols that should be suppressed in <...> brackets.
555 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
556 The resulting string is valid until the next call of ada_demangle.
560 ada_demangle (const char *mangled)
567 static char *demangling_buffer = NULL;
568 static size_t demangling_buffer_size = 0;
570 if (STREQN (mangled, "_ada_", 5))
573 if (mangled[0] == '_' || mangled[0] == '<')
576 p = strstr (mangled, "___");
578 len0 = strlen (mangled);
586 if (len0 > 3 && STREQ (mangled + len0 - 3, "TKB"))
588 if (len0 > 1 && STREQ (mangled + len0 - 1, "B"))
591 /* Make demangled big enough for possible expansion by operator name. */
592 GROW_VECT (demangling_buffer, demangling_buffer_size, 2 * len0 + 1);
593 demangled = demangling_buffer;
595 if (isdigit (mangled[len0 - 1]))
597 for (i = len0 - 2; i >= 0 && isdigit (mangled[i]); i -= 1)
599 if (i > 1 && mangled[i] == '_' && mangled[i - 1] == '_')
601 else if (mangled[i] == '$')
605 for (i = 0, j = 0; i < len0 && !isalpha (mangled[i]); i += 1, j += 1)
606 demangled[j] = mangled[i];
611 if (at_start_name && mangled[i] == 'O')
614 for (k = 0; ada_opname_table[k].mangled != NULL; k += 1)
616 int op_len = strlen (ada_opname_table[k].mangled);
618 (ada_opname_table[k].mangled + 1, mangled + i + 1,
619 op_len - 1) && !isalnum (mangled[i + op_len]))
621 strcpy (demangled + j, ada_opname_table[k].demangled);
624 j += strlen (ada_opname_table[k].demangled);
628 if (ada_opname_table[k].mangled != NULL)
633 if (i < len0 - 4 && STREQN (mangled + i, "TK__", 4))
635 if (mangled[i] == 'X' && i != 0 && isalnum (mangled[i - 1]))
639 while (i < len0 && (mangled[i] == 'b' || mangled[i] == 'n'));
643 else if (i < len0 - 2 && mangled[i] == '_' && mangled[i + 1] == '_')
652 demangled[j] = mangled[i];
657 demangled[j] = '\000';
659 for (i = 0; demangled[i] != '\0'; i += 1)
660 if (isupper (demangled[i]) || demangled[i] == ' ')
666 GROW_VECT (demangling_buffer, demangling_buffer_size, strlen (mangled) + 3);
667 demangled = demangling_buffer;
668 if (mangled[0] == '<')
669 strcpy (demangled, mangled);
671 sprintf (demangled, "<%s>", mangled);
676 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
677 * suffixes that encode debugging information or leading _ada_ on
678 * SYM_NAME (see is_name_suffix commentary for the debugging
679 * information that is ignored). If WILD, then NAME need only match a
680 * suffix of SYM_NAME minus the same suffixes. Also returns 0 if
681 * either argument is NULL. */
684 ada_match_name (const char *sym_name, const char *name, int wild)
686 if (sym_name == NULL || name == NULL)
689 return wild_match (name, strlen (name), sym_name);
692 int len_name = strlen (name);
693 return (STREQN (sym_name, name, len_name)
694 && is_name_suffix (sym_name + len_name))
695 || (STREQN (sym_name, "_ada_", 5)
696 && STREQN (sym_name + 5, name, len_name)
697 && is_name_suffix (sym_name + len_name + 5));
701 /* True (non-zero) iff in Ada mode, the symbol SYM should be
702 suppressed in info listings. */
705 ada_suppress_symbol_printing (struct symbol *sym)
707 if (SYMBOL_NAMESPACE (sym) == STRUCT_NAMESPACE)
710 return is_suppressed_name (SYMBOL_NAME (sym));
716 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of
717 array descriptors. */
719 static char *bound_name[] = {
720 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
721 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
724 /* Maximum number of array dimensions we are prepared to handle. */
726 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char*)))
728 /* Like modify_field, but allows bitpos > wordlength. */
731 modify_general_field (char *addr, LONGEST fieldval, int bitpos, int bitsize)
733 modify_field (addr + sizeof (LONGEST) * bitpos / (8 * sizeof (LONGEST)),
734 fieldval, bitpos % (8 * sizeof (LONGEST)), bitsize);
738 /* The desc_* routines return primitive portions of array descriptors
741 /* The descriptor or array type, if any, indicated by TYPE; removes
742 level of indirection, if needed. */
744 desc_base_type (struct type *type)
748 CHECK_TYPEDEF (type);
749 if (type != NULL && TYPE_CODE (type) == TYPE_CODE_PTR)
750 return check_typedef (TYPE_TARGET_TYPE (type));
755 /* True iff TYPE indicates a "thin" array pointer type. */
757 is_thin_pntr (struct type *type)
760 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
761 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
764 /* The descriptor type for thin pointer type TYPE. */
766 thin_descriptor_type (struct type *type)
768 struct type *base_type = desc_base_type (type);
769 if (base_type == NULL)
771 if (is_suffix (ada_type_name (base_type), "___XVE"))
775 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
776 if (alt_type == NULL)
783 /* A pointer to the array data for thin-pointer value VAL. */
784 static struct value *
785 thin_data_pntr (struct value *val)
787 struct type *type = VALUE_TYPE (val);
788 if (TYPE_CODE (type) == TYPE_CODE_PTR)
789 return value_cast (desc_data_type (thin_descriptor_type (type)),
792 return value_from_longest (desc_data_type (thin_descriptor_type (type)),
793 VALUE_ADDRESS (val) + VALUE_OFFSET (val));
796 /* True iff TYPE indicates a "thick" array pointer type. */
798 is_thick_pntr (struct type *type)
800 type = desc_base_type (type);
801 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
802 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
805 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
806 pointer to one, the type of its bounds data; otherwise, NULL. */
808 desc_bounds_type (struct type *type)
812 type = desc_base_type (type);
816 else if (is_thin_pntr (type))
818 type = thin_descriptor_type (type);
821 r = lookup_struct_elt_type (type, "BOUNDS", 1);
823 return check_typedef (r);
825 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
827 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
829 return check_typedef (TYPE_TARGET_TYPE (check_typedef (r)));
834 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
835 one, a pointer to its bounds data. Otherwise NULL. */
836 static struct value *
837 desc_bounds (struct value *arr)
839 struct type *type = check_typedef (VALUE_TYPE (arr));
840 if (is_thin_pntr (type))
842 struct type *bounds_type =
843 desc_bounds_type (thin_descriptor_type (type));
846 if (desc_bounds_type == NULL)
847 error ("Bad GNAT array descriptor");
849 /* NOTE: The following calculation is not really kosher, but
850 since desc_type is an XVE-encoded type (and shouldn't be),
851 the correct calculation is a real pain. FIXME (and fix GCC). */
852 if (TYPE_CODE (type) == TYPE_CODE_PTR)
853 addr = value_as_long (arr);
855 addr = VALUE_ADDRESS (arr) + VALUE_OFFSET (arr);
858 value_from_longest (lookup_pointer_type (bounds_type),
859 addr - TYPE_LENGTH (bounds_type));
862 else if (is_thick_pntr (type))
863 return value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
864 "Bad GNAT array descriptor");
869 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
870 position of the field containing the address of the bounds data. */
872 fat_pntr_bounds_bitpos (struct type *type)
874 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
877 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
878 size of the field containing the address of the bounds data. */
880 fat_pntr_bounds_bitsize (struct type *type)
882 type = desc_base_type (type);
884 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
885 return TYPE_FIELD_BITSIZE (type, 1);
887 return 8 * TYPE_LENGTH (check_typedef (TYPE_FIELD_TYPE (type, 1)));
890 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
891 pointer to one, the type of its array data (a
892 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
893 ada_type_of_array to get an array type with bounds data. */
895 desc_data_type (struct type *type)
897 type = desc_base_type (type);
899 /* NOTE: The following is bogus; see comment in desc_bounds. */
900 if (is_thin_pntr (type))
901 return lookup_pointer_type
902 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)));
903 else if (is_thick_pntr (type))
904 return lookup_struct_elt_type (type, "P_ARRAY", 1);
909 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
911 static struct value *
912 desc_data (struct value *arr)
914 struct type *type = VALUE_TYPE (arr);
915 if (is_thin_pntr (type))
916 return thin_data_pntr (arr);
917 else if (is_thick_pntr (type))
918 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
919 "Bad GNAT array descriptor");
925 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
926 position of the field containing the address of the data. */
928 fat_pntr_data_bitpos (struct type *type)
930 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
933 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
934 size of the field containing the address of the data. */
936 fat_pntr_data_bitsize (struct type *type)
938 type = desc_base_type (type);
940 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
941 return TYPE_FIELD_BITSIZE (type, 0);
943 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
946 /* If BOUNDS is an array-bounds structure (or pointer to one), return
947 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
948 bound, if WHICH is 1. The first bound is I=1. */
949 static struct value *
950 desc_one_bound (struct value *bounds, int i, int which)
952 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
953 "Bad GNAT array descriptor bounds");
956 /* If BOUNDS is an array-bounds structure type, return the bit position
957 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
958 bound, if WHICH is 1. The first bound is I=1. */
960 desc_bound_bitpos (struct type *type, int i, int which)
962 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
965 /* If BOUNDS is an array-bounds structure type, return the bit field size
966 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
967 bound, if WHICH is 1. The first bound is I=1. */
969 desc_bound_bitsize (struct type *type, int i, int which)
971 type = desc_base_type (type);
973 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
974 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
976 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
979 /* If TYPE is the type of an array-bounds structure, the type of its
980 Ith bound (numbering from 1). Otherwise, NULL. */
982 desc_index_type (struct type *type, int i)
984 type = desc_base_type (type);
986 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
987 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
992 /* The number of index positions in the array-bounds type TYPE. 0
995 desc_arity (struct type *type)
997 type = desc_base_type (type);
1000 return TYPE_NFIELDS (type) / 2;
1005 /* Non-zero iff type is a simple array type (or pointer to one). */
1007 ada_is_simple_array (struct type *type)
1011 CHECK_TYPEDEF (type);
1012 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1013 || (TYPE_CODE (type) == TYPE_CODE_PTR
1014 && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY));
1017 /* Non-zero iff type belongs to a GNAT array descriptor. */
1019 ada_is_array_descriptor (struct type *type)
1021 struct type *data_type = desc_data_type (type);
1025 CHECK_TYPEDEF (type);
1028 && ((TYPE_CODE (data_type) == TYPE_CODE_PTR
1029 && TYPE_TARGET_TYPE (data_type) != NULL
1030 && TYPE_CODE (TYPE_TARGET_TYPE (data_type)) == TYPE_CODE_ARRAY)
1032 TYPE_CODE (data_type) == TYPE_CODE_ARRAY)
1033 && desc_arity (desc_bounds_type (type)) > 0;
1036 /* Non-zero iff type is a partially mal-formed GNAT array
1037 descriptor. (FIXME: This is to compensate for some problems with
1038 debugging output from GNAT. Re-examine periodically to see if it
1041 ada_is_bogus_array_descriptor (struct type *type)
1045 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1046 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1047 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1048 && !ada_is_array_descriptor (type);
1052 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1053 (fat pointer) returns the type of the array data described---specifically,
1054 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1055 in from the descriptor; otherwise, they are left unspecified. If
1056 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1057 returns NULL. The result is simply the type of ARR if ARR is not
1060 ada_type_of_array (struct value *arr, int bounds)
1062 if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1063 return decode_packed_array_type (VALUE_TYPE (arr));
1065 if (!ada_is_array_descriptor (VALUE_TYPE (arr)))
1066 return VALUE_TYPE (arr);
1070 check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr))));
1073 struct type *elt_type;
1075 struct value *descriptor;
1076 struct objfile *objf = TYPE_OBJFILE (VALUE_TYPE (arr));
1078 elt_type = ada_array_element_type (VALUE_TYPE (arr), -1);
1079 arity = ada_array_arity (VALUE_TYPE (arr));
1081 if (elt_type == NULL || arity == 0)
1082 return check_typedef (VALUE_TYPE (arr));
1084 descriptor = desc_bounds (arr);
1085 if (value_as_long (descriptor) == 0)
1089 struct type *range_type = alloc_type (objf);
1090 struct type *array_type = alloc_type (objf);
1091 struct value *low = desc_one_bound (descriptor, arity, 0);
1092 struct value *high = desc_one_bound (descriptor, arity, 1);
1095 create_range_type (range_type, VALUE_TYPE (low),
1096 (int) value_as_long (low),
1097 (int) value_as_long (high));
1098 elt_type = create_array_type (array_type, elt_type, range_type);
1101 return lookup_pointer_type (elt_type);
1105 /* If ARR does not represent an array, returns ARR unchanged.
1106 Otherwise, returns either a standard GDB array with bounds set
1107 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1108 GDB array. Returns NULL if ARR is a null fat pointer. */
1110 ada_coerce_to_simple_array_ptr (struct value *arr)
1112 if (ada_is_array_descriptor (VALUE_TYPE (arr)))
1114 struct type *arrType = ada_type_of_array (arr, 1);
1115 if (arrType == NULL)
1117 return value_cast (arrType, value_copy (desc_data (arr)));
1119 else if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1120 return decode_packed_array (arr);
1125 /* If ARR does not represent an array, returns ARR unchanged.
1126 Otherwise, returns a standard GDB array describing ARR (which may
1127 be ARR itself if it already is in the proper form). */
1129 ada_coerce_to_simple_array (struct value *arr)
1131 if (ada_is_array_descriptor (VALUE_TYPE (arr)))
1133 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
1135 error ("Bounds unavailable for null array pointer.");
1136 return value_ind (arrVal);
1138 else if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1139 return decode_packed_array (arr);
1144 /* If TYPE represents a GNAT array type, return it translated to an
1145 ordinary GDB array type (possibly with BITSIZE fields indicating
1146 packing). For other types, is the identity. */
1148 ada_coerce_to_simple_array_type (struct type *type)
1150 struct value *mark = value_mark ();
1151 struct value *dummy = value_from_longest (builtin_type_long, 0);
1152 struct type *result;
1153 VALUE_TYPE (dummy) = type;
1154 result = ada_type_of_array (dummy, 0);
1155 value_free_to_mark (dummy);
1159 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1161 ada_is_packed_array_type (struct type *type)
1165 CHECK_TYPEDEF (type);
1167 ada_type_name (type) != NULL
1168 && strstr (ada_type_name (type), "___XP") != NULL;
1171 /* Given that TYPE is a standard GDB array type with all bounds filled
1172 in, and that the element size of its ultimate scalar constituents
1173 (that is, either its elements, or, if it is an array of arrays, its
1174 elements' elements, etc.) is *ELT_BITS, return an identical type,
1175 but with the bit sizes of its elements (and those of any
1176 constituent arrays) recorded in the BITSIZE components of its
1177 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1179 static struct type *
1180 packed_array_type (struct type *type, long *elt_bits)
1182 struct type *new_elt_type;
1183 struct type *new_type;
1184 LONGEST low_bound, high_bound;
1186 CHECK_TYPEDEF (type);
1187 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1190 new_type = alloc_type (TYPE_OBJFILE (type));
1191 new_elt_type = packed_array_type (check_typedef (TYPE_TARGET_TYPE (type)),
1193 create_array_type (new_type, new_elt_type, TYPE_FIELD_TYPE (type, 0));
1194 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
1195 TYPE_NAME (new_type) = ada_type_name (type);
1197 if (get_discrete_bounds (TYPE_FIELD_TYPE (type, 0),
1198 &low_bound, &high_bound) < 0)
1199 low_bound = high_bound = 0;
1200 if (high_bound < low_bound)
1201 *elt_bits = TYPE_LENGTH (new_type) = 0;
1204 *elt_bits *= (high_bound - low_bound + 1);
1205 TYPE_LENGTH (new_type) =
1206 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
1209 /* TYPE_FLAGS (new_type) |= TYPE_FLAG_FIXED_INSTANCE; */
1210 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
1214 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE).
1216 static struct type *
1217 decode_packed_array_type (struct type *type)
1219 struct symbol **syms;
1220 struct block **blocks;
1221 const char *raw_name = ada_type_name (check_typedef (type));
1222 char *name = (char *) alloca (strlen (raw_name) + 1);
1223 char *tail = strstr (raw_name, "___XP");
1224 struct type *shadow_type;
1228 memcpy (name, raw_name, tail - raw_name);
1229 name[tail - raw_name] = '\000';
1231 /* NOTE: Use ada_lookup_symbol_list because of bug in some versions
1232 * of gcc (Solaris, e.g.). FIXME when compiler is fixed. */
1233 n = ada_lookup_symbol_list (name, get_selected_block (NULL),
1234 VAR_NAMESPACE, &syms, &blocks);
1235 for (i = 0; i < n; i += 1)
1236 if (syms[i] != NULL && SYMBOL_CLASS (syms[i]) == LOC_TYPEDEF
1237 && STREQ (name, ada_type_name (SYMBOL_TYPE (syms[i]))))
1241 warning ("could not find bounds information on packed array");
1244 shadow_type = SYMBOL_TYPE (syms[i]);
1246 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
1248 warning ("could not understand bounds information on packed array");
1252 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1254 warning ("could not understand bit size information on packed array");
1258 return packed_array_type (shadow_type, &bits);
1261 /* Given that ARR is a struct value* indicating a GNAT packed array,
1262 returns a simple array that denotes that array. Its type is a
1263 standard GDB array type except that the BITSIZEs of the array
1264 target types are set to the number of bits in each element, and the
1265 type length is set appropriately. */
1267 static struct value *
1268 decode_packed_array (struct value *arr)
1270 struct type *type = decode_packed_array_type (VALUE_TYPE (arr));
1274 error ("can't unpack array");
1278 return coerce_unspec_val_to_type (arr, 0, type);
1282 /* The value of the element of packed array ARR at the ARITY indices
1283 given in IND. ARR must be a simple array. */
1285 static struct value *
1286 value_subscript_packed (struct value *arr, int arity, struct value **ind)
1289 int bits, elt_off, bit_off;
1290 long elt_total_bit_offset;
1291 struct type *elt_type;
1295 elt_total_bit_offset = 0;
1296 elt_type = check_typedef (VALUE_TYPE (arr));
1297 for (i = 0; i < arity; i += 1)
1299 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
1300 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
1302 ("attempt to do packed indexing of something other than a packed array");
1305 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
1306 LONGEST lowerbound, upperbound;
1309 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
1311 warning ("don't know bounds of array");
1312 lowerbound = upperbound = 0;
1315 idx = value_as_long (value_pos_atr (ind[i]));
1316 if (idx < lowerbound || idx > upperbound)
1317 warning ("packed array index %ld out of bounds", (long) idx);
1318 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
1319 elt_total_bit_offset += (idx - lowerbound) * bits;
1320 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
1323 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
1324 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
1326 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
1328 if (VALUE_LVAL (arr) == lval_internalvar)
1329 VALUE_LVAL (v) = lval_internalvar_component;
1331 VALUE_LVAL (v) = VALUE_LVAL (arr);
1335 /* Non-zero iff TYPE includes negative integer values. */
1338 has_negatives (struct type *type)
1340 switch (TYPE_CODE (type))
1345 return !TYPE_UNSIGNED (type);
1346 case TYPE_CODE_RANGE:
1347 return TYPE_LOW_BOUND (type) < 0;
1352 /* Create a new value of type TYPE from the contents of OBJ starting
1353 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1354 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1355 assigning through the result will set the field fetched from. OBJ
1356 may also be NULL, in which case, VALADDR+OFFSET must address the
1357 start of storage containing the packed value. The value returned
1358 in this case is never an lval.
1359 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1362 ada_value_primitive_packed_val (struct value *obj, char *valaddr, long offset,
1363 int bit_offset, int bit_size,
1367 int src, /* Index into the source area. */
1368 targ, /* Index into the target area. */
1369 i, srcBitsLeft, /* Number of source bits left to move. */
1370 nsrc, ntarg, /* Number of source and target bytes. */
1371 unusedLS, /* Number of bits in next significant
1372 * byte of source that are unused. */
1373 accumSize; /* Number of meaningful bits in accum */
1374 unsigned char *bytes; /* First byte containing data to unpack. */
1375 unsigned char *unpacked;
1376 unsigned long accum; /* Staging area for bits being transferred */
1378 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
1379 /* Transmit bytes from least to most significant; delta is the
1380 * direction the indices move. */
1381 int delta = BITS_BIG_ENDIAN ? -1 : 1;
1383 CHECK_TYPEDEF (type);
1387 v = allocate_value (type);
1388 bytes = (unsigned char *) (valaddr + offset);
1390 else if (VALUE_LAZY (obj))
1393 VALUE_ADDRESS (obj) + VALUE_OFFSET (obj) + offset, NULL);
1394 bytes = (unsigned char *) alloca (len);
1395 read_memory (VALUE_ADDRESS (v), bytes, len);
1399 v = allocate_value (type);
1400 bytes = (unsigned char *) VALUE_CONTENTS (obj) + offset;
1405 VALUE_LVAL (v) = VALUE_LVAL (obj);
1406 if (VALUE_LVAL (obj) == lval_internalvar)
1407 VALUE_LVAL (v) = lval_internalvar_component;
1408 VALUE_ADDRESS (v) = VALUE_ADDRESS (obj) + VALUE_OFFSET (obj) + offset;
1409 VALUE_BITPOS (v) = bit_offset + VALUE_BITPOS (obj);
1410 VALUE_BITSIZE (v) = bit_size;
1411 if (VALUE_BITPOS (v) >= HOST_CHAR_BIT)
1413 VALUE_ADDRESS (v) += 1;
1414 VALUE_BITPOS (v) -= HOST_CHAR_BIT;
1418 VALUE_BITSIZE (v) = bit_size;
1419 unpacked = (unsigned char *) VALUE_CONTENTS (v);
1421 srcBitsLeft = bit_size;
1423 ntarg = TYPE_LENGTH (type);
1427 memset (unpacked, 0, TYPE_LENGTH (type));
1430 else if (BITS_BIG_ENDIAN)
1433 if (has_negatives (type) &&
1434 ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
1438 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
1441 switch (TYPE_CODE (type))
1443 case TYPE_CODE_ARRAY:
1444 case TYPE_CODE_UNION:
1445 case TYPE_CODE_STRUCT:
1446 /* Non-scalar values must be aligned at a byte boundary. */
1448 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
1449 /* And are placed at the beginning (most-significant) bytes
1455 targ = TYPE_LENGTH (type) - 1;
1461 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
1464 unusedLS = bit_offset;
1467 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
1474 /* Mask for removing bits of the next source byte that are not
1475 * part of the value. */
1476 unsigned int unusedMSMask =
1477 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
1479 /* Sign-extend bits for this byte. */
1480 unsigned int signMask = sign & ~unusedMSMask;
1482 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
1483 accumSize += HOST_CHAR_BIT - unusedLS;
1484 if (accumSize >= HOST_CHAR_BIT)
1486 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
1487 accumSize -= HOST_CHAR_BIT;
1488 accum >>= HOST_CHAR_BIT;
1492 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
1499 accum |= sign << accumSize;
1500 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
1501 accumSize -= HOST_CHAR_BIT;
1502 accum >>= HOST_CHAR_BIT;
1510 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1511 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1514 move_bits (char *target, int targ_offset, char *source, int src_offset, int n)
1516 unsigned int accum, mask;
1517 int accum_bits, chunk_size;
1519 target += targ_offset / HOST_CHAR_BIT;
1520 targ_offset %= HOST_CHAR_BIT;
1521 source += src_offset / HOST_CHAR_BIT;
1522 src_offset %= HOST_CHAR_BIT;
1523 if (BITS_BIG_ENDIAN)
1525 accum = (unsigned char) *source;
1527 accum_bits = HOST_CHAR_BIT - src_offset;
1532 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
1533 accum_bits += HOST_CHAR_BIT;
1535 chunk_size = HOST_CHAR_BIT - targ_offset;
1538 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
1539 mask = ((1 << chunk_size) - 1) << unused_right;
1542 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
1544 accum_bits -= chunk_size;
1551 accum = (unsigned char) *source >> src_offset;
1553 accum_bits = HOST_CHAR_BIT - src_offset;
1557 accum = accum + ((unsigned char) *source << accum_bits);
1558 accum_bits += HOST_CHAR_BIT;
1560 chunk_size = HOST_CHAR_BIT - targ_offset;
1563 mask = ((1 << chunk_size) - 1) << targ_offset;
1564 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
1566 accum_bits -= chunk_size;
1567 accum >>= chunk_size;
1575 /* Store the contents of FROMVAL into the location of TOVAL.
1576 Return a new value with the location of TOVAL and contents of
1577 FROMVAL. Handles assignment into packed fields that have
1578 floating-point or non-scalar types. */
1580 static struct value *
1581 ada_value_assign (struct value *toval, struct value *fromval)
1583 struct type *type = VALUE_TYPE (toval);
1584 int bits = VALUE_BITSIZE (toval);
1586 if (!toval->modifiable)
1587 error ("Left operand of assignment is not a modifiable lvalue.");
1591 if (VALUE_LVAL (toval) == lval_memory
1593 && (TYPE_CODE (type) == TYPE_CODE_FLT
1594 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
1597 (VALUE_BITPOS (toval) + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
1598 char *buffer = (char *) alloca (len);
1601 if (TYPE_CODE (type) == TYPE_CODE_FLT)
1602 fromval = value_cast (type, fromval);
1604 read_memory (VALUE_ADDRESS (toval) + VALUE_OFFSET (toval), buffer, len);
1605 if (BITS_BIG_ENDIAN)
1606 move_bits (buffer, VALUE_BITPOS (toval),
1607 VALUE_CONTENTS (fromval),
1608 TYPE_LENGTH (VALUE_TYPE (fromval)) * TARGET_CHAR_BIT -
1611 move_bits (buffer, VALUE_BITPOS (toval), VALUE_CONTENTS (fromval),
1613 write_memory (VALUE_ADDRESS (toval) + VALUE_OFFSET (toval), buffer,
1616 val = value_copy (toval);
1617 memcpy (VALUE_CONTENTS_RAW (val), VALUE_CONTENTS (fromval),
1618 TYPE_LENGTH (type));
1619 VALUE_TYPE (val) = type;
1624 return value_assign (toval, fromval);
1628 /* The value of the element of array ARR at the ARITY indices given in IND.
1629 ARR may be either a simple array, GNAT array descriptor, or pointer
1633 ada_value_subscript (struct value *arr, int arity, struct value **ind)
1637 struct type *elt_type;
1639 elt = ada_coerce_to_simple_array (arr);
1641 elt_type = check_typedef (VALUE_TYPE (elt));
1642 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
1643 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
1644 return value_subscript_packed (elt, arity, ind);
1646 for (k = 0; k < arity; k += 1)
1648 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
1649 error ("too many subscripts (%d expected)", k);
1650 elt = value_subscript (elt, value_pos_atr (ind[k]));
1655 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
1656 value of the element of *ARR at the ARITY indices given in
1657 IND. Does not read the entire array into memory. */
1660 ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
1665 for (k = 0; k < arity; k += 1)
1670 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1671 error ("too many subscripts (%d expected)", k);
1672 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
1674 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
1678 idx = value_sub (ind[k], value_from_longest (builtin_type_int, lwb));
1679 arr = value_add (arr, idx);
1680 type = TYPE_TARGET_TYPE (type);
1683 return value_ind (arr);
1686 /* If type is a record type in the form of a standard GNAT array
1687 descriptor, returns the number of dimensions for type. If arr is a
1688 simple array, returns the number of "array of"s that prefix its
1689 type designation. Otherwise, returns 0. */
1692 ada_array_arity (struct type *type)
1699 type = desc_base_type (type);
1702 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1703 return desc_arity (desc_bounds_type (type));
1705 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
1708 type = check_typedef (TYPE_TARGET_TYPE (type));
1714 /* If TYPE is a record type in the form of a standard GNAT array
1715 descriptor or a simple array type, returns the element type for
1716 TYPE after indexing by NINDICES indices, or by all indices if
1717 NINDICES is -1. Otherwise, returns NULL. */
1720 ada_array_element_type (struct type *type, int nindices)
1722 type = desc_base_type (type);
1724 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1727 struct type *p_array_type;
1729 p_array_type = desc_data_type (type);
1731 k = ada_array_arity (type);
1735 /* Initially p_array_type = elt_type(*)[]...(k times)...[] */
1736 if (nindices >= 0 && k > nindices)
1738 p_array_type = TYPE_TARGET_TYPE (p_array_type);
1739 while (k > 0 && p_array_type != NULL)
1741 p_array_type = check_typedef (TYPE_TARGET_TYPE (p_array_type));
1744 return p_array_type;
1746 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
1748 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
1750 type = TYPE_TARGET_TYPE (type);
1759 /* The type of nth index in arrays of given type (n numbering from 1). Does
1760 not examine memory. */
1763 ada_index_type (struct type *type, int n)
1765 type = desc_base_type (type);
1767 if (n > ada_array_arity (type))
1770 if (ada_is_simple_array (type))
1774 for (i = 1; i < n; i += 1)
1775 type = TYPE_TARGET_TYPE (type);
1777 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 0));
1780 return desc_index_type (desc_bounds_type (type), n);
1783 /* Given that arr is an array type, returns the lower bound of the
1784 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
1785 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1786 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
1787 bounds type. It works for other arrays with bounds supplied by
1788 run-time quantities other than discriminants. */
1791 ada_array_bound_from_type (struct type * arr_type, int n, int which,
1792 struct type ** typep)
1795 struct type *index_type_desc;
1797 if (ada_is_packed_array_type (arr_type))
1798 arr_type = decode_packed_array_type (arr_type);
1800 if (arr_type == NULL || !ada_is_simple_array (arr_type))
1803 *typep = builtin_type_int;
1804 return (LONGEST) - which;
1807 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
1808 type = TYPE_TARGET_TYPE (arr_type);
1812 index_type_desc = ada_find_parallel_type (type, "___XA");
1813 if (index_type_desc == NULL)
1815 struct type *range_type;
1816 struct type *index_type;
1820 type = TYPE_TARGET_TYPE (type);
1824 range_type = TYPE_INDEX_TYPE (type);
1825 index_type = TYPE_TARGET_TYPE (range_type);
1826 if (TYPE_CODE (index_type) == TYPE_CODE_UNDEF)
1827 index_type = builtin_type_long;
1829 *typep = index_type;
1831 (LONGEST) (which == 0
1832 ? TYPE_LOW_BOUND (range_type)
1833 : TYPE_HIGH_BOUND (range_type));
1837 struct type *index_type =
1838 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n - 1),
1839 NULL, TYPE_OBJFILE (arr_type));
1841 *typep = TYPE_TARGET_TYPE (index_type);
1843 (LONGEST) (which == 0
1844 ? TYPE_LOW_BOUND (index_type)
1845 : TYPE_HIGH_BOUND (index_type));
1849 /* Given that arr is an array value, returns the lower bound of the
1850 nth index (numbering from 1) if which is 0, and the upper bound if
1851 which is 1. This routine will also work for arrays with bounds
1852 supplied by run-time quantities other than discriminants. */
1855 ada_array_bound (struct value *arr, int n, int which)
1857 struct type *arr_type = VALUE_TYPE (arr);
1859 if (ada_is_packed_array_type (arr_type))
1860 return ada_array_bound (decode_packed_array (arr), n, which);
1861 else if (ada_is_simple_array (arr_type))
1864 LONGEST v = ada_array_bound_from_type (arr_type, n, which, &type);
1865 return value_from_longest (type, v);
1868 return desc_one_bound (desc_bounds (arr), n, which);
1871 /* Given that arr is an array value, returns the length of the
1872 nth index. This routine will also work for arrays with bounds
1873 supplied by run-time quantities other than discriminants. Does not
1874 work for arrays indexed by enumeration types with representation
1875 clauses at the moment. */
1878 ada_array_length (struct value *arr, int n)
1880 struct type *arr_type = check_typedef (VALUE_TYPE (arr));
1881 struct type *index_type_desc;
1883 if (ada_is_packed_array_type (arr_type))
1884 return ada_array_length (decode_packed_array (arr), n);
1886 if (ada_is_simple_array (arr_type))
1890 ada_array_bound_from_type (arr_type, n, 1, &type) -
1891 ada_array_bound_from_type (arr_type, n, 0, NULL) + 1;
1892 return value_from_longest (type, v);
1896 value_from_longest (builtin_type_ada_int,
1897 value_as_long (desc_one_bound (desc_bounds (arr),
1899 - value_as_long (desc_one_bound (desc_bounds (arr),
1904 /* Name resolution */
1906 /* The "demangled" name for the user-definable Ada operator corresponding
1910 ada_op_name (enum exp_opcode op)
1914 for (i = 0; ada_opname_table[i].mangled != NULL; i += 1)
1916 if (ada_opname_table[i].op == op)
1917 return ada_opname_table[i].demangled;
1919 error ("Could not find operator name for opcode");
1923 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
1924 references (OP_UNRESOLVED_VALUES) and converts operators that are
1925 user-defined into appropriate function calls. If CONTEXT_TYPE is
1926 non-null, it provides a preferred result type [at the moment, only
1927 type void has any effect---causing procedures to be preferred over
1928 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
1929 return type is preferred. The variable unresolved_names contains a list
1930 of character strings referenced by expout that should be freed.
1931 May change (expand) *EXP. */
1934 ada_resolve (struct expression **expp, struct type *context_type)
1938 ada_resolve_subexp (expp, &pc, 1, context_type);
1941 /* Resolve the operator of the subexpression beginning at
1942 position *POS of *EXPP. "Resolving" consists of replacing
1943 OP_UNRESOLVED_VALUE with an appropriate OP_VAR_VALUE, replacing
1944 built-in operators with function calls to user-defined operators,
1945 where appropriate, and (when DEPROCEDURE_P is non-zero), converting
1946 function-valued variables into parameterless calls. May expand
1947 EXP. The CONTEXT_TYPE functions as in ada_resolve, above. */
1949 static struct value *
1950 ada_resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
1951 struct type *context_type)
1955 struct expression *exp; /* Convenience: == *expp */
1956 enum exp_opcode op = (*expp)->elts[pc].opcode;
1957 struct value **argvec; /* Vector of operand types (alloca'ed). */
1958 int nargs; /* Number of operands */
1964 /* Pass one: resolve operands, saving their types and updating *pos. */
1968 /* case OP_UNRESOLVED_VALUE: */
1969 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1974 nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
1975 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1976 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
1980 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
1981 for (i = 0; i < nargs-1; i += 1)
1982 argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
1988 ada_resolve_subexp (expp, pos, 0, NULL);
1989 for (i = 1; i < nargs; i += 1)
1990 ada_resolve_subexp (expp, pos, 1, NULL);
1996 /* FIXME: UNOP_QUAL should be defined in expression.h */
2000 ada_resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2004 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
2005 /* case OP_ATTRIBUTE:
2006 nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
2008 for (i = 0; i < nargs; i += 1)
2009 ada_resolve_subexp (expp, pos, 1, NULL);
2016 ada_resolve_subexp (expp, pos, 0, NULL);
2025 arg1 = ada_resolve_subexp (expp, pos, 0, NULL);
2027 ada_resolve_subexp (expp, pos, 1, NULL);
2029 ada_resolve_subexp (expp, pos, 1, VALUE_TYPE (arg1));
2037 error ("Unexpected operator during name resolution");
2052 case BINOP_LOGICAL_AND:
2053 case BINOP_LOGICAL_OR:
2054 case BINOP_BITWISE_AND:
2055 case BINOP_BITWISE_IOR:
2056 case BINOP_BITWISE_XOR:
2059 case BINOP_NOTEQUAL:
2066 case BINOP_SUBSCRIPT:
2074 case UNOP_LOGICAL_NOT:
2091 case OP_INTERNALVAR:
2100 case STRUCTOP_STRUCT:
2103 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2108 nargs = longest_to_int (exp->elts[pc + 2].longconst) + 1;
2109 nargs -= longest_to_int (exp->elts[pc + 1].longconst);
2110 /* A null array contains one dummy element to give the type. */
2116 /* FIXME: TERNOP_MBR should be defined in expression.h */
2122 /* FIXME: BINOP_MBR should be defined in expression.h */
2130 (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
2131 for (i = 0; i < nargs; i += 1)
2132 argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
2138 /* Pass two: perform any resolution on principal operator. */
2144 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2145 /* case OP_UNRESOLVED_VALUE:
2147 struct symbol** candidate_syms;
2148 struct block** candidate_blocks;
2151 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 2].name,
2152 exp->elts[pc + 1].block,
2157 if (n_candidates > 1)
2159 /* Types tend to get re-introduced locally, so if there
2160 are any local symbols that are not types, first filter
2163 for (j = 0; j < n_candidates; j += 1)
2164 switch (SYMBOL_CLASS (candidate_syms[j]))
2170 case LOC_REGPARM_ADDR:
2174 case LOC_BASEREG_ARG:
2180 if (j < n_candidates)
2183 while (j < n_candidates)
2185 if (SYMBOL_CLASS (candidate_syms[j]) == LOC_TYPEDEF)
2187 candidate_syms[j] = candidate_syms[n_candidates-1];
2188 candidate_blocks[j] = candidate_blocks[n_candidates-1];
2197 if (n_candidates == 0)
2198 error ("No definition found for %s",
2199 ada_demangle (exp->elts[pc + 2].name));
2200 else if (n_candidates == 1)
2202 else if (deprocedure_p
2203 && ! is_nonfunction (candidate_syms, n_candidates))
2205 i = ada_resolve_function (candidate_syms, candidate_blocks,
2206 n_candidates, NULL, 0,
2207 exp->elts[pc + 2].name, context_type);
2209 error ("Could not find a match for %s",
2210 ada_demangle (exp->elts[pc + 2].name));
2214 printf_filtered ("Multiple matches for %s\n",
2215 ada_demangle (exp->elts[pc+2].name));
2216 user_select_syms (candidate_syms, candidate_blocks,
2221 exp->elts[pc].opcode = exp->elts[pc + 3].opcode = OP_VAR_VALUE;
2222 exp->elts[pc + 1].block = candidate_blocks[i];
2223 exp->elts[pc + 2].symbol = candidate_syms[i];
2224 if (innermost_block == NULL ||
2225 contained_in (candidate_blocks[i], innermost_block))
2226 innermost_block = candidate_blocks[i];
2231 if (deprocedure_p &&
2232 TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol)) ==
2235 replace_operator_with_call (expp, pc, 0, 0,
2236 exp->elts[pc + 2].symbol,
2237 exp->elts[pc + 1].block);
2244 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2245 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
2247 struct symbol** candidate_syms;
2248 struct block** candidate_blocks;
2251 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 5].name,
2252 exp->elts[pc + 4].block,
2256 if (n_candidates == 1)
2260 i = ada_resolve_function (candidate_syms, candidate_blocks,
2261 n_candidates, argvec, nargs-1,
2262 exp->elts[pc + 5].name, context_type);
2264 error ("Could not find a match for %s",
2265 ada_demangle (exp->elts[pc + 5].name));
2268 exp->elts[pc + 3].opcode = exp->elts[pc + 6].opcode = OP_VAR_VALUE;
2269 exp->elts[pc + 4].block = candidate_blocks[i];
2270 exp->elts[pc + 5].symbol = candidate_syms[i];
2271 if (innermost_block == NULL ||
2272 contained_in (candidate_blocks[i], innermost_block))
2273 innermost_block = candidate_blocks[i];
2285 case BINOP_BITWISE_AND:
2286 case BINOP_BITWISE_IOR:
2287 case BINOP_BITWISE_XOR:
2289 case BINOP_NOTEQUAL:
2297 case UNOP_LOGICAL_NOT:
2299 if (possible_user_operator_p (op, argvec))
2301 struct symbol **candidate_syms;
2302 struct block **candidate_blocks;
2306 ada_lookup_symbol_list (ada_mangle (ada_op_name (op)),
2307 (struct block *) NULL, VAR_NAMESPACE,
2308 &candidate_syms, &candidate_blocks);
2310 ada_resolve_function (candidate_syms, candidate_blocks,
2311 n_candidates, argvec, nargs,
2312 ada_op_name (op), NULL);
2316 replace_operator_with_call (expp, pc, nargs, 1,
2317 candidate_syms[i], candidate_blocks[i]);
2324 return evaluate_subexp_type (exp, pos);
2327 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2328 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2330 /* The term "match" here is rather loose. The match is heuristic and
2331 liberal. FIXME: TOO liberal, in fact. */
2334 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
2336 CHECK_TYPEDEF (ftype);
2337 CHECK_TYPEDEF (atype);
2339 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
2340 ftype = TYPE_TARGET_TYPE (ftype);
2341 if (TYPE_CODE (atype) == TYPE_CODE_REF)
2342 atype = TYPE_TARGET_TYPE (atype);
2344 if (TYPE_CODE (ftype) == TYPE_CODE_VOID
2345 || TYPE_CODE (atype) == TYPE_CODE_VOID)
2348 switch (TYPE_CODE (ftype))
2353 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
2354 return ada_type_match (TYPE_TARGET_TYPE (ftype),
2355 TYPE_TARGET_TYPE (atype), 0);
2357 return (may_deref &&
2358 ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
2360 case TYPE_CODE_ENUM:
2361 case TYPE_CODE_RANGE:
2362 switch (TYPE_CODE (atype))
2365 case TYPE_CODE_ENUM:
2366 case TYPE_CODE_RANGE:
2372 case TYPE_CODE_ARRAY:
2373 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
2374 || ada_is_array_descriptor (atype));
2376 case TYPE_CODE_STRUCT:
2377 if (ada_is_array_descriptor (ftype))
2378 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
2379 || ada_is_array_descriptor (atype));
2381 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
2382 && !ada_is_array_descriptor (atype));
2384 case TYPE_CODE_UNION:
2386 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
2390 /* Return non-zero if the formals of FUNC "sufficiently match" the
2391 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2392 may also be an enumeral, in which case it is treated as a 0-
2393 argument function. */
2396 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
2399 struct type *func_type = SYMBOL_TYPE (func);
2401 if (SYMBOL_CLASS (func) == LOC_CONST &&
2402 TYPE_CODE (func_type) == TYPE_CODE_ENUM)
2403 return (n_actuals == 0);
2404 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
2407 if (TYPE_NFIELDS (func_type) != n_actuals)
2410 for (i = 0; i < n_actuals; i += 1)
2412 struct type *ftype = check_typedef (TYPE_FIELD_TYPE (func_type, i));
2413 struct type *atype = check_typedef (VALUE_TYPE (actuals[i]));
2415 if (!ada_type_match (TYPE_FIELD_TYPE (func_type, i),
2416 VALUE_TYPE (actuals[i]), 1))
2422 /* False iff function type FUNC_TYPE definitely does not produce a value
2423 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2424 FUNC_TYPE is not a valid function type with a non-null return type
2425 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2428 return_match (struct type *func_type, struct type *context_type)
2430 struct type *return_type;
2432 if (func_type == NULL)
2435 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2436 /* if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
2437 return_type = base_type (TYPE_TARGET_TYPE (func_type));
2439 return_type = base_type (func_type); */
2440 if (return_type == NULL)
2443 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2444 /* context_type = base_type (context_type); */
2446 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
2447 return context_type == NULL || return_type == context_type;
2448 else if (context_type == NULL)
2449 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
2451 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
2455 /* Return the index in SYMS[0..NSYMS-1] of symbol for the
2456 function (if any) that matches the types of the NARGS arguments in
2457 ARGS. If CONTEXT_TYPE is non-null, and there is at least one match
2458 that returns type CONTEXT_TYPE, then eliminate other matches. If
2459 CONTEXT_TYPE is null, prefer a non-void-returning function.
2460 Asks the user if there is more than one match remaining. Returns -1
2461 if there is no such symbol or none is selected. NAME is used
2462 solely for messages. May re-arrange and modify SYMS in
2463 the process; the index returned is for the modified vector. BLOCKS
2464 is modified in parallel to SYMS. */
2467 ada_resolve_function (struct symbol *syms[], struct block *blocks[],
2468 int nsyms, struct value **args, int nargs,
2469 const char *name, struct type *context_type)
2472 int m; /* Number of hits */
2473 struct type *fallback;
2474 struct type *return_type;
2476 return_type = context_type;
2477 if (context_type == NULL)
2478 fallback = builtin_type_void;
2485 for (k = 0; k < nsyms; k += 1)
2487 struct type *type = check_typedef (SYMBOL_TYPE (syms[k]));
2489 if (ada_args_match (syms[k], args, nargs)
2490 && return_match (SYMBOL_TYPE (syms[k]), return_type))
2494 blocks[m] = blocks[k];
2498 if (m > 0 || return_type == fallback)
2501 return_type = fallback;
2508 printf_filtered ("Multiple matches for %s\n", name);
2509 user_select_syms (syms, blocks, m, 1);
2515 /* Returns true (non-zero) iff demangled name N0 should appear before N1 */
2516 /* in a listing of choices during disambiguation (see sort_choices, below). */
2517 /* The idea is that overloadings of a subprogram name from the */
2518 /* same package should sort in their source order. We settle for ordering */
2519 /* such symbols by their trailing number (__N or $N). */
2521 mangled_ordered_before (char *N0, char *N1)
2525 else if (N0 == NULL)
2530 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
2532 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
2534 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
2535 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
2539 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
2542 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
2544 if (n0 == n1 && STREQN (N0, N1, n0))
2545 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
2547 return (strcmp (N0, N1) < 0);
2551 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by their */
2552 /* mangled names, rearranging BLOCKS[0..NSYMS-1] according to the same */
2555 sort_choices (struct symbol *syms[], struct block *blocks[], int nsyms)
2558 for (i = 1; i < nsyms; i += 1)
2560 struct symbol *sym = syms[i];
2561 struct block *block = blocks[i];
2564 for (j = i - 1; j >= 0; j -= 1)
2566 if (mangled_ordered_before (SYMBOL_NAME (syms[j]),
2569 syms[j + 1] = syms[j];
2570 blocks[j + 1] = blocks[j];
2573 blocks[j + 1] = block;
2577 /* Given a list of NSYMS symbols in SYMS and corresponding blocks in */
2578 /* BLOCKS, select up to MAX_RESULTS>0 by asking the user (if */
2579 /* necessary), returning the number selected, and setting the first */
2580 /* elements of SYMS and BLOCKS to the selected symbols and */
2581 /* corresponding blocks. Error if no symbols selected. BLOCKS may */
2582 /* be NULL, in which case it is ignored. */
2584 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
2585 to be re-integrated one of these days. */
2588 user_select_syms (struct symbol *syms[], struct block *blocks[], int nsyms,
2592 int *chosen = (int *) alloca (sizeof (int) * nsyms);
2594 int first_choice = (max_results == 1) ? 1 : 2;
2596 if (max_results < 1)
2597 error ("Request to select 0 symbols!");
2601 printf_unfiltered ("[0] cancel\n");
2602 if (max_results > 1)
2603 printf_unfiltered ("[1] all\n");
2605 sort_choices (syms, blocks, nsyms);
2607 for (i = 0; i < nsyms; i += 1)
2609 if (syms[i] == NULL)
2612 if (SYMBOL_CLASS (syms[i]) == LOC_BLOCK)
2614 struct symtab_and_line sal = find_function_start_sal (syms[i], 1);
2615 printf_unfiltered ("[%d] %s at %s:%d\n",
2617 SYMBOL_PRINT_NAME (syms[i]),
2619 ? "<no source file available>"
2620 : sal.symtab->filename, sal.line);
2626 (SYMBOL_CLASS (syms[i]) == LOC_CONST
2627 && SYMBOL_TYPE (syms[i]) != NULL
2628 && TYPE_CODE (SYMBOL_TYPE (syms[i])) == TYPE_CODE_ENUM);
2629 struct symtab *symtab = symtab_for_sym (syms[i]);
2631 if (SYMBOL_LINE (syms[i]) != 0 && symtab != NULL)
2632 printf_unfiltered ("[%d] %s at %s:%d\n",
2634 SYMBOL_PRINT_NAME (syms[i]),
2635 symtab->filename, SYMBOL_LINE (syms[i]));
2636 else if (is_enumeral && TYPE_NAME (SYMBOL_TYPE (syms[i])) != NULL)
2638 printf_unfiltered ("[%d] ", i + first_choice);
2639 ada_print_type (SYMBOL_TYPE (syms[i]), NULL, gdb_stdout, -1, 0);
2640 printf_unfiltered ("'(%s) (enumeral)\n",
2641 SYMBOL_PRINT_NAME (syms[i]));
2643 else if (symtab != NULL)
2644 printf_unfiltered (is_enumeral
2645 ? "[%d] %s in %s (enumeral)\n"
2646 : "[%d] %s at %s:?\n",
2648 SYMBOL_PRINT_NAME (syms[i]),
2651 printf_unfiltered (is_enumeral
2652 ? "[%d] %s (enumeral)\n"
2655 SYMBOL_PRINT_NAME (syms[i]));
2659 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
2662 for (i = 0; i < n_chosen; i += 1)
2664 syms[i] = syms[chosen[i]];
2666 blocks[i] = blocks[chosen[i]];
2672 /* Read and validate a set of numeric choices from the user in the
2673 range 0 .. N_CHOICES-1. Place the results in increasing
2674 order in CHOICES[0 .. N-1], and return N.
2676 The user types choices as a sequence of numbers on one line
2677 separated by blanks, encoding them as follows:
2679 + A choice of 0 means to cancel the selection, throwing an error.
2680 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
2681 + The user chooses k by typing k+IS_ALL_CHOICE+1.
2683 The user is not allowed to choose more than MAX_RESULTS values.
2685 ANNOTATION_SUFFIX, if present, is used to annotate the input
2686 prompts (for use with the -f switch). */
2689 get_selections (int *choices, int n_choices, int max_results,
2690 int is_all_choice, char *annotation_suffix)
2696 int first_choice = is_all_choice ? 2 : 1;
2698 prompt = getenv ("PS2");
2702 printf_unfiltered ("%s ", prompt);
2703 gdb_flush (gdb_stdout);
2705 args = command_line_input ((char *) NULL, 0, annotation_suffix);
2708 error_no_arg ("one or more choice numbers");
2712 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
2713 order, as given in args. Choices are validated. */
2719 while (isspace (*args))
2721 if (*args == '\0' && n_chosen == 0)
2722 error_no_arg ("one or more choice numbers");
2723 else if (*args == '\0')
2726 choice = strtol (args, &args2, 10);
2727 if (args == args2 || choice < 0
2728 || choice > n_choices + first_choice - 1)
2729 error ("Argument must be choice number");
2733 error ("cancelled");
2735 if (choice < first_choice)
2737 n_chosen = n_choices;
2738 for (j = 0; j < n_choices; j += 1)
2742 choice -= first_choice;
2744 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
2748 if (j < 0 || choice != choices[j])
2751 for (k = n_chosen - 1; k > j; k -= 1)
2752 choices[k + 1] = choices[k];
2753 choices[j + 1] = choice;
2758 if (n_chosen > max_results)
2759 error ("Select no more than %d of the above", max_results);
2764 /* Replace the operator of length OPLEN at position PC in *EXPP with a call */
2765 /* on the function identified by SYM and BLOCK, and taking NARGS */
2766 /* arguments. Update *EXPP as needed to hold more space. */
2769 replace_operator_with_call (struct expression **expp, int pc, int nargs,
2770 int oplen, struct symbol *sym,
2771 struct block *block)
2773 /* A new expression, with 6 more elements (3 for funcall, 4 for function
2774 symbol, -oplen for operator being replaced). */
2775 struct expression *newexp = (struct expression *)
2776 xmalloc (sizeof (struct expression)
2777 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
2778 struct expression *exp = *expp;
2780 newexp->nelts = exp->nelts + 7 - oplen;
2781 newexp->language_defn = exp->language_defn;
2782 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
2783 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
2784 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
2786 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
2787 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
2789 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
2790 newexp->elts[pc + 4].block = block;
2791 newexp->elts[pc + 5].symbol = sym;
2797 /* Type-class predicates */
2799 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), or */
2803 numeric_type_p (struct type *type)
2809 switch (TYPE_CODE (type))
2814 case TYPE_CODE_RANGE:
2815 return (type == TYPE_TARGET_TYPE (type)
2816 || numeric_type_p (TYPE_TARGET_TYPE (type)));
2823 /* True iff TYPE is integral (an INT or RANGE of INTs). */
2826 integer_type_p (struct type *type)
2832 switch (TYPE_CODE (type))
2836 case TYPE_CODE_RANGE:
2837 return (type == TYPE_TARGET_TYPE (type)
2838 || integer_type_p (TYPE_TARGET_TYPE (type)));
2845 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
2848 scalar_type_p (struct type *type)
2854 switch (TYPE_CODE (type))
2857 case TYPE_CODE_RANGE:
2858 case TYPE_CODE_ENUM:
2867 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
2870 discrete_type_p (struct type *type)
2876 switch (TYPE_CODE (type))
2879 case TYPE_CODE_RANGE:
2880 case TYPE_CODE_ENUM:
2888 /* Returns non-zero if OP with operatands in the vector ARGS could be
2889 a user-defined function. Errs on the side of pre-defined operators
2890 (i.e., result 0). */
2893 possible_user_operator_p (enum exp_opcode op, struct value *args[])
2895 struct type *type0 = check_typedef (VALUE_TYPE (args[0]));
2896 struct type *type1 =
2897 (args[1] == NULL) ? NULL : check_typedef (VALUE_TYPE (args[1]));
2908 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
2912 case BINOP_BITWISE_AND:
2913 case BINOP_BITWISE_IOR:
2914 case BINOP_BITWISE_XOR:
2915 return (!(integer_type_p (type0) && integer_type_p (type1)));
2918 case BINOP_NOTEQUAL:
2923 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
2926 return ((TYPE_CODE (type0) != TYPE_CODE_ARRAY &&
2927 (TYPE_CODE (type0) != TYPE_CODE_PTR ||
2928 TYPE_CODE (TYPE_TARGET_TYPE (type0))
2929 != TYPE_CODE_ARRAY))
2930 || (TYPE_CODE (type1) != TYPE_CODE_ARRAY &&
2931 (TYPE_CODE (type1) != TYPE_CODE_PTR ||
2932 TYPE_CODE (TYPE_TARGET_TYPE (type1)) != TYPE_CODE_ARRAY)));
2935 return (!(numeric_type_p (type0) && integer_type_p (type1)));
2939 case UNOP_LOGICAL_NOT:
2941 return (!numeric_type_p (type0));
2948 /** NOTE: In the following, we assume that a renaming type's name may
2949 * have an ___XD suffix. It would be nice if this went away at some
2952 /* If TYPE encodes a renaming, returns the renaming suffix, which
2953 * is XR for an object renaming, XRP for a procedure renaming, XRE for
2954 * an exception renaming, and XRS for a subprogram renaming. Returns
2955 * NULL if NAME encodes none of these. */
2957 ada_renaming_type (struct type *type)
2959 if (type != NULL && TYPE_CODE (type) == TYPE_CODE_ENUM)
2961 const char *name = type_name_no_tag (type);
2962 const char *suffix = (name == NULL) ? NULL : strstr (name, "___XR");
2964 || (suffix[5] != '\000' && strchr ("PES_", suffix[5]) == NULL))
2973 /* Return non-zero iff SYM encodes an object renaming. */
2975 ada_is_object_renaming (struct symbol *sym)
2977 const char *renaming_type = ada_renaming_type (SYMBOL_TYPE (sym));
2978 return renaming_type != NULL
2979 && (renaming_type[2] == '\0' || renaming_type[2] == '_');
2982 /* Assuming that SYM encodes a non-object renaming, returns the original
2983 * name of the renamed entity. The name is good until the end of
2986 ada_simple_renamed_entity (struct symbol *sym)
2989 const char *raw_name;
2993 type = SYMBOL_TYPE (sym);
2994 if (type == NULL || TYPE_NFIELDS (type) < 1)
2995 error ("Improperly encoded renaming.");
2997 raw_name = TYPE_FIELD_NAME (type, 0);
2998 len = (raw_name == NULL ? 0 : strlen (raw_name)) - 5;
3000 error ("Improperly encoded renaming.");
3002 result = xmalloc (len + 1);
3003 /* FIXME: add_name_string_cleanup should be defined in parse.c */
3004 /* add_name_string_cleanup (result); */
3005 strncpy (result, raw_name, len);
3006 result[len] = '\000';
3011 /* Evaluation: Function Calls */
3013 /* Copy VAL onto the stack, using and updating *SP as the stack
3014 pointer. Return VAL as an lvalue. */
3016 static struct value *
3017 place_on_stack (struct value *val, CORE_ADDR *sp)
3019 CORE_ADDR old_sp = *sp;
3022 *sp = push_bytes (*sp, VALUE_CONTENTS_RAW (val),
3023 STACK_ALIGN (TYPE_LENGTH
3024 (check_typedef (VALUE_TYPE (val)))));
3026 *sp = push_bytes (*sp, VALUE_CONTENTS_RAW (val),
3027 TYPE_LENGTH (check_typedef (VALUE_TYPE (val))));
3030 VALUE_LVAL (val) = lval_memory;
3031 if (INNER_THAN (1, 2))
3032 VALUE_ADDRESS (val) = *sp;
3034 VALUE_ADDRESS (val) = old_sp;
3039 /* Return the value ACTUAL, converted to be an appropriate value for a
3040 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3041 allocating any necessary descriptors (fat pointers), or copies of
3042 values not residing in memory, updating it as needed. */
3044 static struct value *
3045 convert_actual (struct value *actual, struct type *formal_type0,
3048 struct type *actual_type = check_typedef (VALUE_TYPE (actual));
3049 struct type *formal_type = check_typedef (formal_type0);
3050 struct type *formal_target =
3051 TYPE_CODE (formal_type) == TYPE_CODE_PTR
3052 ? check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
3053 struct type *actual_target =
3054 TYPE_CODE (actual_type) == TYPE_CODE_PTR
3055 ? check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
3057 if (ada_is_array_descriptor (formal_target)
3058 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
3059 return make_array_descriptor (formal_type, actual, sp);
3060 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR)
3062 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
3063 && ada_is_array_descriptor (actual_target))
3064 return desc_data (actual);
3065 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
3067 if (VALUE_LVAL (actual) != lval_memory)
3070 actual_type = check_typedef (VALUE_TYPE (actual));
3071 val = allocate_value (actual_type);
3072 memcpy ((char *) VALUE_CONTENTS_RAW (val),
3073 (char *) VALUE_CONTENTS (actual),
3074 TYPE_LENGTH (actual_type));
3075 actual = place_on_stack (val, sp);
3077 return value_addr (actual);
3080 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
3081 return ada_value_ind (actual);
3087 /* Push a descriptor of type TYPE for array value ARR on the stack at
3088 *SP, updating *SP to reflect the new descriptor. Return either
3089 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3090 to-descriptor type rather than a descriptor type), a struct value*
3091 representing a pointer to this descriptor. */
3093 static struct value *
3094 make_array_descriptor (struct type *type, struct value *arr, CORE_ADDR *sp)
3096 struct type *bounds_type = desc_bounds_type (type);
3097 struct type *desc_type = desc_base_type (type);
3098 struct value *descriptor = allocate_value (desc_type);
3099 struct value *bounds = allocate_value (bounds_type);
3100 CORE_ADDR bounds_addr;
3103 for (i = ada_array_arity (check_typedef (VALUE_TYPE (arr))); i > 0; i -= 1)
3105 modify_general_field (VALUE_CONTENTS (bounds),
3106 value_as_long (ada_array_bound (arr, i, 0)),
3107 desc_bound_bitpos (bounds_type, i, 0),
3108 desc_bound_bitsize (bounds_type, i, 0));
3109 modify_general_field (VALUE_CONTENTS (bounds),
3110 value_as_long (ada_array_bound (arr, i, 1)),
3111 desc_bound_bitpos (bounds_type, i, 1),
3112 desc_bound_bitsize (bounds_type, i, 1));
3115 bounds = place_on_stack (bounds, sp);
3117 modify_general_field (VALUE_CONTENTS (descriptor),
3119 fat_pntr_data_bitpos (desc_type),
3120 fat_pntr_data_bitsize (desc_type));
3121 modify_general_field (VALUE_CONTENTS (descriptor),
3122 VALUE_ADDRESS (bounds),
3123 fat_pntr_bounds_bitpos (desc_type),
3124 fat_pntr_bounds_bitsize (desc_type));
3126 descriptor = place_on_stack (descriptor, sp);
3128 if (TYPE_CODE (type) == TYPE_CODE_PTR)
3129 return value_addr (descriptor);
3135 /* Assuming a dummy frame has been established on the target, perform any
3136 conversions needed for calling function FUNC on the NARGS actual
3137 parameters in ARGS, other than standard C conversions. Does
3138 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3139 does not match the number of arguments expected. Use *SP as a
3140 stack pointer for additional data that must be pushed, updating its
3144 ada_convert_actuals (struct value *func, int nargs, struct value *args[],
3149 if (TYPE_NFIELDS (VALUE_TYPE (func)) == 0
3150 || nargs != TYPE_NFIELDS (VALUE_TYPE (func)))
3153 for (i = 0; i < nargs; i += 1)
3155 convert_actual (args[i], TYPE_FIELD_TYPE (VALUE_TYPE (func), i), sp);
3162 /* The vectors of symbols and blocks ultimately returned from */
3163 /* ada_lookup_symbol_list. */
3165 /* Current size of defn_symbols and defn_blocks */
3166 static size_t defn_vector_size = 0;
3168 /* Current number of symbols found. */
3169 static int ndefns = 0;
3171 static struct symbol **defn_symbols = NULL;
3172 static struct block **defn_blocks = NULL;
3174 /* Return the result of a standard (literal, C-like) lookup of NAME in
3175 * given NAMESPACE. */
3177 static struct symbol *
3178 standard_lookup (const char *name, namespace_enum namespace)
3181 struct symtab *symtab;
3182 sym = lookup_symbol (name, (struct block *) NULL, namespace, 0, &symtab);
3187 /* Non-zero iff there is at least one non-function/non-enumeral symbol */
3188 /* in SYMS[0..N-1]. We treat enumerals as functions, since they */
3189 /* contend in overloading in the same way. */
3191 is_nonfunction (struct symbol *syms[], int n)
3195 for (i = 0; i < n; i += 1)
3196 if (TYPE_CODE (SYMBOL_TYPE (syms[i])) != TYPE_CODE_FUNC
3197 && TYPE_CODE (SYMBOL_TYPE (syms[i])) != TYPE_CODE_ENUM)
3203 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3204 struct types. Otherwise, they may not. */
3207 equiv_types (struct type *type0, struct type *type1)
3211 if (type0 == NULL || type1 == NULL
3212 || TYPE_CODE (type0) != TYPE_CODE (type1))
3214 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
3215 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
3216 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
3217 && STREQ (ada_type_name (type0), ada_type_name (type1)))
3223 /* True iff SYM0 represents the same entity as SYM1, or one that is
3224 no more defined than that of SYM1. */
3227 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
3231 if (SYMBOL_NAMESPACE (sym0) != SYMBOL_NAMESPACE (sym1)
3232 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
3235 switch (SYMBOL_CLASS (sym0))
3241 struct type *type0 = SYMBOL_TYPE (sym0);
3242 struct type *type1 = SYMBOL_TYPE (sym1);
3243 char *name0 = SYMBOL_NAME (sym0);
3244 char *name1 = SYMBOL_NAME (sym1);
3245 int len0 = strlen (name0);
3247 TYPE_CODE (type0) == TYPE_CODE (type1)
3248 && (equiv_types (type0, type1)
3249 || (len0 < strlen (name1) && STREQN (name0, name1, len0)
3250 && STREQN (name1 + len0, "___XV", 5)));
3253 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
3254 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
3260 /* Append SYM to the end of defn_symbols, and BLOCK to the end of
3261 defn_blocks, updating ndefns, and expanding defn_symbols and
3262 defn_blocks as needed. Do not include SYM if it is a duplicate. */
3265 add_defn_to_vec (struct symbol *sym, struct block *block)
3270 if (SYMBOL_TYPE (sym) != NULL)
3271 CHECK_TYPEDEF (SYMBOL_TYPE (sym));
3272 for (i = 0; i < ndefns; i += 1)
3274 if (lesseq_defined_than (sym, defn_symbols[i]))
3276 else if (lesseq_defined_than (defn_symbols[i], sym))
3278 defn_symbols[i] = sym;
3279 defn_blocks[i] = block;
3284 tmp = defn_vector_size;
3285 GROW_VECT (defn_symbols, tmp, ndefns + 2);
3286 GROW_VECT (defn_blocks, defn_vector_size, ndefns + 2);
3288 defn_symbols[ndefns] = sym;
3289 defn_blocks[ndefns] = block;
3293 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3294 Check the global symbols if GLOBAL, the static symbols if not. Do
3295 wild-card match if WILD. */
3297 static struct partial_symbol *
3298 ada_lookup_partial_symbol (struct partial_symtab *pst, const char *name,
3299 int global, namespace_enum namespace, int wild)
3301 struct partial_symbol **start;
3302 int name_len = strlen (name);
3303 int length = (global ? pst->n_global_syms : pst->n_static_syms);
3312 pst->objfile->global_psymbols.list + pst->globals_offset :
3313 pst->objfile->static_psymbols.list + pst->statics_offset);
3317 for (i = 0; i < length; i += 1)
3319 struct partial_symbol *psym = start[i];
3321 if (SYMBOL_NAMESPACE (psym) == namespace &&
3322 wild_match (name, name_len, SYMBOL_NAME (psym)))
3336 int M = (U + i) >> 1;
3337 struct partial_symbol *psym = start[M];
3338 if (SYMBOL_NAME (psym)[0] < name[0])
3340 else if (SYMBOL_NAME (psym)[0] > name[0])
3342 else if (strcmp (SYMBOL_NAME (psym), name) < 0)
3353 struct partial_symbol *psym = start[i];
3355 if (SYMBOL_NAMESPACE (psym) == namespace)
3357 int cmp = strncmp (name, SYMBOL_NAME (psym), name_len);
3365 && is_name_suffix (SYMBOL_NAME (psym) + name_len))
3378 int M = (U + i) >> 1;
3379 struct partial_symbol *psym = start[M];
3380 if (SYMBOL_NAME (psym)[0] < '_')
3382 else if (SYMBOL_NAME (psym)[0] > '_')
3384 else if (strcmp (SYMBOL_NAME (psym), "_ada_") < 0)
3395 struct partial_symbol *psym = start[i];
3397 if (SYMBOL_NAMESPACE (psym) == namespace)
3401 cmp = (int) '_' - (int) SYMBOL_NAME (psym)[0];
3404 cmp = strncmp ("_ada_", SYMBOL_NAME (psym), 5);
3406 cmp = strncmp (name, SYMBOL_NAME (psym) + 5, name_len);
3415 && is_name_suffix (SYMBOL_NAME (psym) + name_len + 5))
3426 /* Find a symbol table containing symbol SYM or NULL if none. */
3427 static struct symtab *
3428 symtab_for_sym (struct symbol *sym)
3431 struct objfile *objfile;
3433 struct symbol *tmp_sym;
3436 ALL_SYMTABS (objfile, s)
3438 switch (SYMBOL_CLASS (sym))
3446 case LOC_CONST_BYTES:
3447 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
3448 ALL_BLOCK_SYMBOLS (b, i, tmp_sym) if (sym == tmp_sym)
3450 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
3451 ALL_BLOCK_SYMBOLS (b, i, tmp_sym) if (sym == tmp_sym)
3457 switch (SYMBOL_CLASS (sym))
3463 case LOC_REGPARM_ADDR:
3468 case LOC_BASEREG_ARG:
3469 for (j = FIRST_LOCAL_BLOCK;
3470 j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s)); j += 1)
3472 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), j);
3473 ALL_BLOCK_SYMBOLS (b, i, tmp_sym) if (sym == tmp_sym)
3484 /* Return a minimal symbol matching NAME according to Ada demangling
3485 rules. Returns NULL if there is no such minimal symbol. */
3487 struct minimal_symbol *
3488 ada_lookup_minimal_symbol (const char *name)
3490 struct objfile *objfile;
3491 struct minimal_symbol *msymbol;
3492 int wild_match = (strstr (name, "__") == NULL);
3494 ALL_MSYMBOLS (objfile, msymbol)
3496 if (ada_match_name (SYMBOL_NAME (msymbol), name, wild_match)
3497 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
3504 /* For all subprograms that statically enclose the subprogram of the
3505 * selected frame, add symbols matching identifier NAME in NAMESPACE
3506 * and their blocks to vectors *defn_symbols and *defn_blocks, as for
3507 * ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
3508 * wildcard prefix. At the moment, this function uses a heuristic to
3509 * find the frames of enclosing subprograms: it treats the
3510 * pointer-sized value at location 0 from the local-variable base of a
3511 * frame as a static link, and then searches up the call stack for a
3512 * frame with that same local-variable base. */
3514 add_symbols_from_enclosing_procs (const char *name, namespace_enum namespace,
3518 static struct symbol static_link_sym;
3519 static struct symbol *static_link;
3521 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
3522 struct frame_info *frame;
3523 struct frame_info *target_frame;
3525 if (static_link == NULL)
3527 /* Initialize the local variable symbol that stands for the
3528 * static link (when it exists). */
3529 static_link = &static_link_sym;
3530 SYMBOL_NAME (static_link) = "";
3531 SYMBOL_LANGUAGE (static_link) = language_unknown;
3532 SYMBOL_CLASS (static_link) = LOC_LOCAL;
3533 SYMBOL_NAMESPACE (static_link) = VAR_NAMESPACE;
3534 SYMBOL_TYPE (static_link) = lookup_pointer_type (builtin_type_void);
3535 SYMBOL_VALUE (static_link) =
3536 -(long) TYPE_LENGTH (SYMBOL_TYPE (static_link));
3539 frame = deprecated_selected_frame;
3540 while (frame != NULL && ndefns == 0)
3542 struct block *block;
3543 struct value *target_link_val = read_var_value (static_link, frame);
3544 CORE_ADDR target_link;
3546 if (target_link_val == NULL)
3550 target_link = target_link_val;
3554 frame = get_prev_frame (frame);
3556 while (frame != NULL && FRAME_LOCALS_ADDRESS (frame) != target_link);
3561 block = get_frame_block (frame, 0);
3562 while (block != NULL && block_function (block) != NULL && ndefns == 0)
3564 ada_add_block_symbols (block, name, namespace, NULL, wild_match);
3566 block = BLOCK_SUPERBLOCK (block);
3570 do_cleanups (old_chain);
3574 /* True if TYPE is definitely an artificial type supplied to a symbol
3575 * for which no debugging information was given in the symbol file. */
3577 is_nondebugging_type (struct type *type)
3579 char *name = ada_type_name (type);
3580 return (name != NULL && STREQ (name, "<variable, no debug info>"));
3583 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
3584 * duplicate other symbols in the list. (The only case I know of where
3585 * this happens is when object files containing stabs-in-ecoff are
3586 * linked with files containing ordinary ecoff debugging symbols (or no
3587 * debugging symbols)). Modifies SYMS to squeeze out deleted symbols,
3588 * and applies the same modification to BLOCKS to maintain the
3589 * correspondence between SYMS[i] and BLOCKS[i]. Returns the number
3590 * of symbols in the modified list. */
3592 remove_extra_symbols (struct symbol **syms, struct block **blocks, int nsyms)
3599 if (SYMBOL_NAME (syms[i]) != NULL
3600 && SYMBOL_CLASS (syms[i]) == LOC_STATIC
3601 && is_nondebugging_type (SYMBOL_TYPE (syms[i])))
3603 for (j = 0; j < nsyms; j += 1)
3606 && SYMBOL_NAME (syms[j]) != NULL
3607 && STREQ (SYMBOL_NAME (syms[i]), SYMBOL_NAME (syms[j]))
3608 && SYMBOL_CLASS (syms[i]) == SYMBOL_CLASS (syms[j])
3609 && SYMBOL_VALUE_ADDRESS (syms[i])
3610 == SYMBOL_VALUE_ADDRESS (syms[j]))
3613 for (k = i + 1; k < nsyms; k += 1)
3615 syms[k - 1] = syms[k];
3616 blocks[k - 1] = blocks[k];
3630 /* Find symbols in NAMESPACE matching NAME, in BLOCK0 and enclosing
3631 scope and in global scopes, returning the number of matches. Sets
3632 *SYMS to point to a vector of matching symbols, with *BLOCKS
3633 pointing to the vector of corresponding blocks in which those
3634 symbols reside. These two vectors are transient---good only to the
3635 next call of ada_lookup_symbol_list. Any non-function/non-enumeral symbol
3636 match within the nest of blocks whose innermost member is BLOCK0,
3637 is the outermost match returned (no other matches in that or
3638 enclosing blocks is returned). If there are any matches in or
3639 surrounding BLOCK0, then these alone are returned. */
3642 ada_lookup_symbol_list (const char *name, struct block *block0,
3643 namespace_enum namespace, struct symbol ***syms,
3644 struct block ***blocks)
3648 struct partial_symtab *ps;
3649 struct blockvector *bv;
3650 struct objfile *objfile;
3652 struct block *block;
3653 struct minimal_symbol *msymbol;
3654 int wild_match = (strstr (name, "__") == NULL);
3664 /* Search specified block and its superiors. */
3667 while (block != NULL)
3669 ada_add_block_symbols (block, name, namespace, NULL, wild_match);
3671 /* If we found a non-function match, assume that's the one. */
3672 if (is_nonfunction (defn_symbols, ndefns))
3675 block = BLOCK_SUPERBLOCK (block);
3678 /* If we found ANY matches in the specified BLOCK, we're done. */
3685 /* Now add symbols from all global blocks: symbol tables, minimal symbol
3686 tables, and psymtab's */
3688 ALL_SYMTABS (objfile, s)
3693 bv = BLOCKVECTOR (s);
3694 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
3695 ada_add_block_symbols (block, name, namespace, objfile, wild_match);
3698 if (namespace == VAR_NAMESPACE)
3700 ALL_MSYMBOLS (objfile, msymbol)
3702 if (ada_match_name (SYMBOL_NAME (msymbol), name, wild_match))
3704 switch (MSYMBOL_TYPE (msymbol))
3706 case mst_solib_trampoline:
3709 s = find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol));
3712 int old_ndefns = ndefns;
3714 bv = BLOCKVECTOR (s);
3715 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
3716 ada_add_block_symbols (block,
3717 SYMBOL_NAME (msymbol),
3718 namespace, objfile, wild_match);
3719 if (ndefns == old_ndefns)
3721 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
3722 ada_add_block_symbols (block,
3723 SYMBOL_NAME (msymbol),
3733 ALL_PSYMTABS (objfile, ps)
3737 && ada_lookup_partial_symbol (ps, name, 1, namespace, wild_match))
3739 s = PSYMTAB_TO_SYMTAB (ps);
3742 bv = BLOCKVECTOR (s);
3743 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
3744 ada_add_block_symbols (block, name, namespace, objfile, wild_match);
3748 /* Now add symbols from all per-file blocks if we've gotten no hits.
3749 (Not strictly correct, but perhaps better than an error).
3750 Do the symtabs first, then check the psymtabs */
3755 ALL_SYMTABS (objfile, s)
3760 bv = BLOCKVECTOR (s);
3761 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
3762 ada_add_block_symbols (block, name, namespace, objfile, wild_match);
3765 ALL_PSYMTABS (objfile, ps)
3769 && ada_lookup_partial_symbol (ps, name, 0, namespace, wild_match))
3771 s = PSYMTAB_TO_SYMTAB (ps);
3772 bv = BLOCKVECTOR (s);
3775 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
3776 ada_add_block_symbols (block, name, namespace,
3777 objfile, wild_match);
3782 /* Finally, we try to find NAME as a local symbol in some lexically
3783 enclosing block. We do this last, expecting this case to be
3787 add_symbols_from_enclosing_procs (name, namespace, wild_match);
3793 ndefns = remove_extra_symbols (defn_symbols, defn_blocks, ndefns);
3796 *syms = defn_symbols;
3797 *blocks = defn_blocks;
3804 /* Return a symbol in NAMESPACE matching NAME, in BLOCK0 and enclosing
3805 * scope and in global scopes, or NULL if none. NAME is folded to
3806 * lower case first, unless it is surrounded in single quotes.
3807 * Otherwise, the result is as for ada_lookup_symbol_list, but is
3808 * disambiguated by user query if needed. */
3811 ada_lookup_symbol (const char *name, struct block *block0,
3812 namespace_enum namespace)
3814 struct symbol **candidate_syms;
3815 struct block **candidate_blocks;
3818 n_candidates = ada_lookup_symbol_list (name,
3820 &candidate_syms, &candidate_blocks);
3822 if (n_candidates == 0)
3824 else if (n_candidates != 1)
3825 user_select_syms (candidate_syms, candidate_blocks, n_candidates, 1);
3827 return candidate_syms[0];
3831 /* True iff STR is a possible encoded suffix of a normal Ada name
3832 * that is to be ignored for matching purposes. Suffixes of parallel
3833 * names (e.g., XVE) are not included here. Currently, the possible suffixes
3834 * are given by the regular expression:
3835 * (X[nb]*)?(__[0-9]+|\$[0-9]+|___(LJM|X([FDBUP].*|R[^T]?)))?$
3839 is_name_suffix (const char *str)
3845 while (str[0] != '_' && str[0] != '\0')
3847 if (str[0] != 'n' && str[0] != 'b')
3852 if (str[0] == '\000')
3856 if (str[1] != '_' || str[2] == '\000')
3860 if (STREQ (str + 3, "LJM"))
3864 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B' ||
3865 str[4] == 'U' || str[4] == 'P')
3867 if (str[4] == 'R' && str[5] != 'T')
3871 for (k = 2; str[k] != '\0'; k += 1)
3872 if (!isdigit (str[k]))
3876 if (str[0] == '$' && str[1] != '\000')
3878 for (k = 1; str[k] != '\0'; k += 1)
3879 if (!isdigit (str[k]))
3886 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
3887 * PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
3888 * informational suffixes of NAME (i.e., for which is_name_suffix is
3891 wild_match (const char *patn, int patn_len, const char *name)
3896 name_len = strlen (name);
3897 if (name_len >= patn_len + 5 && STREQN (name, "_ada_", 5)
3898 && STREQN (patn, name + 5, patn_len)
3899 && is_name_suffix (name + patn_len + 5))
3902 while (name_len >= patn_len)
3904 if (STREQN (patn, name, patn_len) && is_name_suffix (name + patn_len))
3912 && name[0] != '.' && (name[0] != '_' || name[1] != '_'));
3917 if (!islower (name[2]))
3924 if (!islower (name[1]))
3935 /* Add symbols from BLOCK matching identifier NAME in NAMESPACE to
3936 vector *defn_symbols, updating *defn_symbols (if necessary), *SZ (the size of
3937 the vector *defn_symbols), and *ndefns (the number of symbols
3938 currently stored in *defn_symbols). If WILD, treat as NAME with a
3939 wildcard prefix. OBJFILE is the section containing BLOCK. */
3942 ada_add_block_symbols (struct block *block, const char *name,
3943 namespace_enum namespace, struct objfile *objfile,
3947 int name_len = strlen (name);
3948 /* A matching argument symbol, if any. */
3949 struct symbol *arg_sym;
3950 /* Set true when we find a matching non-argument symbol */
3952 int is_sorted = BLOCK_SHOULD_SORT (block);
3960 ALL_BLOCK_SYMBOLS (block, i, sym)
3962 if (SYMBOL_NAMESPACE (sym) == namespace &&
3963 wild_match (name, name_len, SYMBOL_NAME (sym)))
3965 switch (SYMBOL_CLASS (sym))
3971 case LOC_REGPARM_ADDR:
3972 case LOC_BASEREG_ARG:
3975 case LOC_UNRESOLVED:
3979 fill_in_ada_prototype (sym);
3980 add_defn_to_vec (fixup_symbol_section (sym, objfile), block);
3992 U = BLOCK_NSYMS (block) - 1;
3995 int M = (U + i) >> 1;
3996 struct symbol *sym = BLOCK_SYM (block, M);
3997 if (SYMBOL_NAME (sym)[0] < name[0])
3999 else if (SYMBOL_NAME (sym)[0] > name[0])
4001 else if (strcmp (SYMBOL_NAME (sym), name) < 0)
4010 for (; i < BLOCK_BUCKETS (block); i += 1)
4011 for (sym = BLOCK_BUCKET (block, i); sym != NULL; sym = sym->hash_next)
4013 if (SYMBOL_NAMESPACE (sym) == namespace)
4015 int cmp = strncmp (name, SYMBOL_NAME (sym), name_len);
4021 i = BLOCK_BUCKETS (block);
4026 && is_name_suffix (SYMBOL_NAME (sym) + name_len))
4028 switch (SYMBOL_CLASS (sym))
4034 case LOC_REGPARM_ADDR:
4035 case LOC_BASEREG_ARG:
4038 case LOC_UNRESOLVED:
4042 fill_in_ada_prototype (sym);
4043 add_defn_to_vec (fixup_symbol_section (sym, objfile),
4052 if (!found_sym && arg_sym != NULL)
4054 fill_in_ada_prototype (arg_sym);
4055 add_defn_to_vec (fixup_symbol_section (arg_sym, objfile), block);
4066 U = BLOCK_NSYMS (block) - 1;
4069 int M = (U + i) >> 1;
4070 struct symbol *sym = BLOCK_SYM (block, M);
4071 if (SYMBOL_NAME (sym)[0] < '_')
4073 else if (SYMBOL_NAME (sym)[0] > '_')
4075 else if (strcmp (SYMBOL_NAME (sym), "_ada_") < 0)
4084 for (; i < BLOCK_BUCKETS (block); i += 1)
4085 for (sym = BLOCK_BUCKET (block, i); sym != NULL; sym = sym->hash_next)
4087 struct symbol *sym = BLOCK_SYM (block, i);
4089 if (SYMBOL_NAMESPACE (sym) == namespace)
4093 cmp = (int) '_' - (int) SYMBOL_NAME (sym)[0];
4096 cmp = strncmp ("_ada_", SYMBOL_NAME (sym), 5);
4098 cmp = strncmp (name, SYMBOL_NAME (sym) + 5, name_len);
4105 i = BLOCK_BUCKETS (block);
4110 && is_name_suffix (SYMBOL_NAME (sym) + name_len + 5))
4112 switch (SYMBOL_CLASS (sym))
4118 case LOC_REGPARM_ADDR:
4119 case LOC_BASEREG_ARG:
4122 case LOC_UNRESOLVED:
4126 fill_in_ada_prototype (sym);
4127 add_defn_to_vec (fixup_symbol_section (sym, objfile),
4135 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4136 They aren't parameters, right? */
4137 if (!found_sym && arg_sym != NULL)
4139 fill_in_ada_prototype (arg_sym);
4140 add_defn_to_vec (fixup_symbol_section (arg_sym, objfile), block);
4146 /* Function Types */
4148 /* Assuming that SYM is the symbol for a function, fill in its type
4149 with prototype information, if it is not already there. */
4152 fill_in_ada_prototype (struct symbol *func)
4163 || TYPE_CODE (SYMBOL_TYPE (func)) != TYPE_CODE_FUNC
4164 || TYPE_FIELDS (SYMBOL_TYPE (func)) != NULL)
4167 /* We make each function type unique, so that each may have its own */
4168 /* parameter types. This particular way of doing so wastes space: */
4169 /* it would be nicer to build the argument types while the original */
4170 /* function type is being built (FIXME). */
4171 rtype = check_typedef (TYPE_TARGET_TYPE (SYMBOL_TYPE (func)));
4172 ftype = alloc_type (TYPE_OBJFILE (SYMBOL_TYPE (func)));
4173 make_function_type (rtype, &ftype);
4174 SYMBOL_TYPE (func) = ftype;
4176 b = SYMBOL_BLOCK_VALUE (func);
4180 TYPE_FIELDS (ftype) =
4181 (struct field *) xmalloc (sizeof (struct field) * max_fields);
4182 ALL_BLOCK_SYMBOLS (b, i, sym)
4184 GROW_VECT (TYPE_FIELDS (ftype), max_fields, nargs + 1);
4186 switch (SYMBOL_CLASS (sym))
4189 case LOC_REGPARM_ADDR:
4190 TYPE_FIELD_BITPOS (ftype, nargs) = nargs;
4191 TYPE_FIELD_BITSIZE (ftype, nargs) = 0;
4192 TYPE_FIELD_STATIC_KIND (ftype, nargs) = 0;
4193 TYPE_FIELD_TYPE (ftype, nargs) =
4194 lookup_pointer_type (check_typedef (SYMBOL_TYPE (sym)));
4195 TYPE_FIELD_NAME (ftype, nargs) = SYMBOL_NAME (sym);
4203 case LOC_BASEREG_ARG:
4204 TYPE_FIELD_BITPOS (ftype, nargs) = nargs;
4205 TYPE_FIELD_BITSIZE (ftype, nargs) = 0;
4206 TYPE_FIELD_STATIC_KIND (ftype, nargs) = 0;
4207 TYPE_FIELD_TYPE (ftype, nargs) = check_typedef (SYMBOL_TYPE (sym));
4208 TYPE_FIELD_NAME (ftype, nargs) = SYMBOL_NAME (sym);
4218 /* Re-allocate fields vector; if there are no fields, make the */
4219 /* fields pointer non-null anyway, to mark that this function type */
4220 /* has been filled in. */
4222 TYPE_NFIELDS (ftype) = nargs;
4225 static struct field dummy_field = { 0, 0, 0, 0 };
4226 xfree (TYPE_FIELDS (ftype));
4227 TYPE_FIELDS (ftype) = &dummy_field;
4231 struct field *fields =
4232 (struct field *) TYPE_ALLOC (ftype, nargs * sizeof (struct field));
4233 memcpy ((char *) fields,
4234 (char *) TYPE_FIELDS (ftype), nargs * sizeof (struct field));
4235 xfree (TYPE_FIELDS (ftype));
4236 TYPE_FIELDS (ftype) = fields;
4241 /* Breakpoint-related */
4243 char no_symtab_msg[] =
4244 "No symbol table is loaded. Use the \"file\" command.";
4246 /* Assuming that LINE is pointing at the beginning of an argument to
4247 'break', return a pointer to the delimiter for the initial segment
4248 of that name. This is the first ':', ' ', or end of LINE.
4251 ada_start_decode_line_1 (char *line)
4253 /* [NOTE: strpbrk would be more elegant, but I am reluctant to be
4254 the first to use such a library function in GDB code.] */
4256 for (p = line; *p != '\000' && *p != ' ' && *p != ':'; p += 1)
4261 /* *SPEC points to a function and line number spec (as in a break
4262 command), following any initial file name specification.
4264 Return all symbol table/line specfications (sals) consistent with the
4265 information in *SPEC and FILE_TABLE in the
4267 + FILE_TABLE is null, or the sal refers to a line in the file
4268 named by FILE_TABLE.
4269 + If *SPEC points to an argument with a trailing ':LINENUM',
4270 then the sal refers to that line (or one following it as closely as
4272 + If *SPEC does not start with '*', the sal is in a function with
4275 Returns with 0 elements if no matching non-minimal symbols found.
4277 If *SPEC begins with a function name of the form <NAME>, then NAME
4278 is taken as a literal name; otherwise the function name is subject
4279 to the usual mangling.
4281 *SPEC is updated to point after the function/line number specification.
4283 FUNFIRSTLINE is non-zero if we desire the first line of real code
4284 in each function (this is ignored in the presence of a LINENUM spec.).
4286 If CANONICAL is non-NULL, and if any of the sals require a
4287 'canonical line spec', then *CANONICAL is set to point to an array
4288 of strings, corresponding to and equal in length to the returned
4289 list of sals, such that (*CANONICAL)[i] is non-null and contains a
4290 canonical line spec for the ith returned sal, if needed. If no
4291 canonical line specs are required and CANONICAL is non-null,
4292 *CANONICAL is set to NULL.
4294 A 'canonical line spec' is simply a name (in the format of the
4295 breakpoint command) that uniquely identifies a breakpoint position,
4296 with no further contextual information or user selection. It is
4297 needed whenever the file name, function name, and line number
4298 information supplied is insufficient for this unique
4299 identification. Currently overloaded functions, the name '*',
4300 or static functions without a filename yield a canonical line spec.
4301 The array and the line spec strings are allocated on the heap; it
4302 is the caller's responsibility to free them. */
4304 struct symtabs_and_lines
4305 ada_finish_decode_line_1 (char **spec, struct symtab *file_table,
4306 int funfirstline, char ***canonical)
4308 struct symbol **symbols;
4309 struct block **blocks;
4310 struct block *block;
4311 int n_matches, i, line_num;
4312 struct symtabs_and_lines selected;
4313 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
4318 char *unquoted_name;
4320 if (file_table == NULL)
4321 block = get_selected_block (NULL);
4323 block = BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table), STATIC_BLOCK);
4325 if (canonical != NULL)
4326 *canonical = (char **) NULL;
4333 while (**spec != '\000' &&
4334 !strchr (ada_completer_word_break_characters, **spec))
4340 if (file_table != NULL && (*spec)[0] == ':' && isdigit ((*spec)[1]))
4342 line_num = strtol (*spec + 1, spec, 10);
4343 while (**spec == ' ' || **spec == '\t')
4350 error ("Wild-card function with no line number or file name.");
4352 return all_sals_for_line (file_table->filename, line_num, canonical);
4355 if (name[0] == '\'')
4363 unquoted_name = (char *) alloca (len - 1);
4364 memcpy (unquoted_name, name + 1, len - 2);
4365 unquoted_name[len - 2] = '\000';
4370 unquoted_name = (char *) alloca (len + 1);
4371 memcpy (unquoted_name, name, len);
4372 unquoted_name[len] = '\000';
4373 lower_name = (char *) alloca (len + 1);
4374 for (i = 0; i < len; i += 1)
4375 lower_name[i] = tolower (name[i]);
4376 lower_name[len] = '\000';
4380 if (lower_name != NULL)
4381 n_matches = ada_lookup_symbol_list (ada_mangle (lower_name), block,
4382 VAR_NAMESPACE, &symbols, &blocks);
4384 n_matches = ada_lookup_symbol_list (unquoted_name, block,
4385 VAR_NAMESPACE, &symbols, &blocks);
4386 if (n_matches == 0 && line_num >= 0)
4387 error ("No line number information found for %s.", unquoted_name);
4388 else if (n_matches == 0)
4390 #ifdef HPPA_COMPILER_BUG
4391 /* FIXME: See comment in symtab.c::decode_line_1 */
4393 volatile struct symtab_and_line val;
4394 #define volatile /*nothing */
4396 struct symtab_and_line val;
4398 struct minimal_symbol *msymbol;
4403 if (lower_name != NULL)
4404 msymbol = ada_lookup_minimal_symbol (ada_mangle (lower_name));
4405 if (msymbol == NULL)
4406 msymbol = ada_lookup_minimal_symbol (unquoted_name);
4407 if (msymbol != NULL)
4409 val.pc = SYMBOL_VALUE_ADDRESS (msymbol);
4410 val.section = SYMBOL_BFD_SECTION (msymbol);
4413 val.pc += FUNCTION_START_OFFSET;
4414 SKIP_PROLOGUE (val.pc);
4416 selected.sals = (struct symtab_and_line *)
4417 xmalloc (sizeof (struct symtab_and_line));
4418 selected.sals[0] = val;
4423 if (!have_full_symbols () &&
4424 !have_partial_symbols () && !have_minimal_symbols ())
4425 error (no_symtab_msg);
4427 error ("Function \"%s\" not defined.", unquoted_name);
4428 return selected; /* for lint */
4434 find_sal_from_funcs_and_line (file_table->filename, line_num,
4435 symbols, n_matches);
4440 user_select_syms (symbols, blocks, n_matches, n_matches);
4443 selected.sals = (struct symtab_and_line *)
4444 xmalloc (sizeof (struct symtab_and_line) * selected.nelts);
4445 memset (selected.sals, 0, selected.nelts * sizeof (selected.sals[i]));
4446 make_cleanup (xfree, selected.sals);
4449 while (i < selected.nelts)
4451 if (SYMBOL_CLASS (symbols[i]) == LOC_BLOCK)
4452 selected.sals[i] = find_function_start_sal (symbols[i], funfirstline);
4453 else if (SYMBOL_LINE (symbols[i]) != 0)
4455 selected.sals[i].symtab = symtab_for_sym (symbols[i]);
4456 selected.sals[i].line = SYMBOL_LINE (symbols[i]);
4458 else if (line_num >= 0)
4460 /* Ignore this choice */
4461 symbols[i] = symbols[selected.nelts - 1];
4462 blocks[i] = blocks[selected.nelts - 1];
4463 selected.nelts -= 1;
4467 error ("Line number not known for symbol \"%s\"", unquoted_name);
4471 if (canonical != NULL && (line_num >= 0 || n_matches > 1))
4473 *canonical = (char **) xmalloc (sizeof (char *) * selected.nelts);
4474 for (i = 0; i < selected.nelts; i += 1)
4476 extended_canonical_line_spec (selected.sals[i],
4477 SYMBOL_PRINT_NAME (symbols[i]));
4480 discard_cleanups (old_chain);
4484 /* The (single) sal corresponding to line LINE_NUM in a symbol table
4485 with file name FILENAME that occurs in one of the functions listed
4486 in SYMBOLS[0 .. NSYMS-1]. */
4487 static struct symtabs_and_lines
4488 find_sal_from_funcs_and_line (const char *filename, int line_num,
4489 struct symbol **symbols, int nsyms)
4491 struct symtabs_and_lines sals;
4492 int best_index, best;
4493 struct linetable *best_linetable;
4494 struct objfile *objfile;
4496 struct symtab *best_symtab;
4498 read_all_symtabs (filename);
4501 best_linetable = NULL;
4504 ALL_SYMTABS (objfile, s)
4506 struct linetable *l;
4511 if (!STREQ (filename, s->filename))
4514 ind = find_line_in_linetable (l, line_num, symbols, nsyms, &exact);
4524 if (best == 0 || l->item[ind].line < best)
4526 best = l->item[ind].line;
4535 error ("Line number not found in designated function.");
4540 sals.sals = (struct symtab_and_line *) xmalloc (sizeof (sals.sals[0]));
4542 init_sal (&sals.sals[0]);
4544 sals.sals[0].line = best_linetable->item[best_index].line;
4545 sals.sals[0].pc = best_linetable->item[best_index].pc;
4546 sals.sals[0].symtab = best_symtab;
4551 /* Return the index in LINETABLE of the best match for LINE_NUM whose
4552 pc falls within one of the functions denoted by SYMBOLS[0..NSYMS-1].
4553 Set *EXACTP to the 1 if the match is exact, and 0 otherwise. */
4555 find_line_in_linetable (struct linetable *linetable, int line_num,
4556 struct symbol **symbols, int nsyms, int *exactp)
4558 int i, len, best_index, best;
4560 if (line_num <= 0 || linetable == NULL)
4563 len = linetable->nitems;
4564 for (i = 0, best_index = -1, best = 0; i < len; i += 1)
4567 struct linetable_entry *item = &(linetable->item[i]);
4569 for (k = 0; k < nsyms; k += 1)
4571 if (symbols[k] != NULL && SYMBOL_CLASS (symbols[k]) == LOC_BLOCK
4572 && item->pc >= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols[k]))
4573 && item->pc < BLOCK_END (SYMBOL_BLOCK_VALUE (symbols[k])))
4580 if (item->line == line_num)
4586 if (item->line > line_num && (best == 0 || item->line < best))
4597 /* Find the smallest k >= LINE_NUM such that k is a line number in
4598 LINETABLE, and k falls strictly within a named function that begins at
4599 or before LINE_NUM. Return -1 if there is no such k. */
4601 nearest_line_number_in_linetable (struct linetable *linetable, int line_num)
4605 if (line_num <= 0 || linetable == NULL || linetable->nitems == 0)
4607 len = linetable->nitems;
4614 struct linetable_entry *item = &(linetable->item[i]);
4616 if (item->line >= line_num && item->line < best)
4619 CORE_ADDR start, end;
4622 find_pc_partial_function (item->pc, &func_name, &start, &end);
4624 if (func_name != NULL && item->pc < end)
4626 if (item->line == line_num)
4630 struct symbol *sym =
4631 standard_lookup (func_name, VAR_NAMESPACE);
4632 if (is_plausible_func_for_line (sym, line_num))
4638 while (i < len && linetable->item[i].pc < end);
4648 return (best == INT_MAX) ? -1 : best;
4652 /* Return the next higher index, k, into LINETABLE such that k > IND,
4653 entry k in LINETABLE has a line number equal to LINE_NUM, k
4654 corresponds to a PC that is in a function different from that
4655 corresponding to IND, and falls strictly within a named function
4656 that begins at a line at or preceding STARTING_LINE.
4657 Return -1 if there is no such k.
4658 IND == -1 corresponds to no function. */
4661 find_next_line_in_linetable (struct linetable *linetable, int line_num,
4662 int starting_line, int ind)
4666 if (line_num <= 0 || linetable == NULL || ind >= linetable->nitems)
4668 len = linetable->nitems;
4672 CORE_ADDR start, end;
4674 if (find_pc_partial_function (linetable->item[ind].pc,
4675 (char **) NULL, &start, &end))
4677 while (ind < len && linetable->item[ind].pc < end)
4690 struct linetable_entry *item = &(linetable->item[i]);
4692 if (item->line >= line_num)
4695 CORE_ADDR start, end;
4698 find_pc_partial_function (item->pc, &func_name, &start, &end);
4700 if (func_name != NULL && item->pc < end)
4702 if (item->line == line_num)
4704 struct symbol *sym =
4705 standard_lookup (func_name, VAR_NAMESPACE);
4706 if (is_plausible_func_for_line (sym, starting_line))
4710 while ((i + 1) < len && linetable->item[i + 1].pc < end)
4722 /* True iff function symbol SYM starts somewhere at or before line #
4725 is_plausible_func_for_line (struct symbol *sym, int line_num)
4727 struct symtab_and_line start_sal;
4732 start_sal = find_function_start_sal (sym, 0);
4734 return (start_sal.line != 0 && line_num >= start_sal.line);
4738 debug_print_lines (struct linetable *lt)
4745 fprintf (stderr, "\t");
4746 for (i = 0; i < lt->nitems; i += 1)
4747 fprintf (stderr, "(%d->%p) ", lt->item[i].line, (void *) lt->item[i].pc);
4748 fprintf (stderr, "\n");
4752 debug_print_block (struct block *b)
4757 fprintf (stderr, "Block: %p; [0x%lx, 0x%lx]",
4758 b, BLOCK_START (b), BLOCK_END (b));
4759 if (BLOCK_FUNCTION (b) != NULL)
4760 fprintf (stderr, " Function: %s", SYMBOL_NAME (BLOCK_FUNCTION (b)));
4761 fprintf (stderr, "\n");
4762 fprintf (stderr, "\t Superblock: %p\n", BLOCK_SUPERBLOCK (b));
4763 fprintf (stderr, "\t Symbols:");
4764 ALL_BLOCK_SYMBOLS (b, i, sym)
4766 if (i > 0 && i % 4 == 0)
4767 fprintf (stderr, "\n\t\t ");
4768 fprintf (stderr, " %s", SYMBOL_NAME (sym));
4770 fprintf (stderr, "\n");
4774 debug_print_blocks (struct blockvector *bv)
4780 for (i = 0; i < BLOCKVECTOR_NBLOCKS (bv); i += 1)
4782 fprintf (stderr, "%6d. ", i);
4783 debug_print_block (BLOCKVECTOR_BLOCK (bv, i));
4788 debug_print_symtab (struct symtab *s)
4790 fprintf (stderr, "Symtab %p\n File: %s; Dir: %s\n", s,
4791 s->filename, s->dirname);
4792 fprintf (stderr, " Blockvector: %p, Primary: %d\n",
4793 BLOCKVECTOR (s), s->primary);
4794 debug_print_blocks (BLOCKVECTOR (s));
4795 fprintf (stderr, " Line table: %p\n", LINETABLE (s));
4796 debug_print_lines (LINETABLE (s));
4799 /* Read in all symbol tables corresponding to partial symbol tables
4800 with file name FILENAME. */
4802 read_all_symtabs (const char *filename)
4804 struct partial_symtab *ps;
4805 struct objfile *objfile;
4807 ALL_PSYMTABS (objfile, ps)
4811 if (STREQ (filename, ps->filename))
4812 PSYMTAB_TO_SYMTAB (ps);
4816 /* All sals corresponding to line LINE_NUM in a symbol table from file
4817 FILENAME, as filtered by the user. If CANONICAL is not null, set
4818 it to a corresponding array of canonical line specs. */
4819 static struct symtabs_and_lines
4820 all_sals_for_line (const char *filename, int line_num, char ***canonical)
4822 struct symtabs_and_lines result;
4823 struct objfile *objfile;
4825 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
4828 read_all_symtabs (filename);
4831 (struct symtab_and_line *) xmalloc (4 * sizeof (result.sals[0]));
4834 make_cleanup (free_current_contents, &result.sals);
4836 ALL_SYMTABS (objfile, s)
4838 int ind, target_line_num;
4842 if (!STREQ (s->filename, filename))
4846 nearest_line_number_in_linetable (LINETABLE (s), line_num);
4847 if (target_line_num == -1)
4854 find_next_line_in_linetable (LINETABLE (s),
4855 target_line_num, line_num, ind);
4860 GROW_VECT (result.sals, len, result.nelts + 1);
4861 init_sal (&result.sals[result.nelts]);
4862 result.sals[result.nelts].line = LINETABLE (s)->item[ind].line;
4863 result.sals[result.nelts].pc = LINETABLE (s)->item[ind].pc;
4864 result.sals[result.nelts].symtab = s;
4869 if (canonical != NULL || result.nelts > 1)
4872 char **func_names = (char **) alloca (result.nelts * sizeof (char *));
4873 int first_choice = (result.nelts > 1) ? 2 : 1;
4875 int *choices = (int *) alloca (result.nelts * sizeof (int));
4877 for (k = 0; k < result.nelts; k += 1)
4879 find_pc_partial_function (result.sals[k].pc, &func_names[k],
4880 (CORE_ADDR *) NULL, (CORE_ADDR *) NULL);
4881 if (func_names[k] == NULL)
4882 error ("Could not find function for one or more breakpoints.");
4885 if (result.nelts > 1)
4887 printf_unfiltered ("[0] cancel\n");
4888 if (result.nelts > 1)
4889 printf_unfiltered ("[1] all\n");
4890 for (k = 0; k < result.nelts; k += 1)
4891 printf_unfiltered ("[%d] %s\n", k + first_choice,
4892 ada_demangle (func_names[k]));
4894 n = get_selections (choices, result.nelts, result.nelts,
4895 result.nelts > 1, "instance-choice");
4897 for (k = 0; k < n; k += 1)
4899 result.sals[k] = result.sals[choices[k]];
4900 func_names[k] = func_names[choices[k]];
4905 if (canonical != NULL)
4907 *canonical = (char **) xmalloc (result.nelts * sizeof (char **));
4908 make_cleanup (xfree, *canonical);
4909 for (k = 0; k < result.nelts; k += 1)
4912 extended_canonical_line_spec (result.sals[k], func_names[k]);
4913 if ((*canonical)[k] == NULL)
4914 error ("Could not locate one or more breakpoints.");
4915 make_cleanup (xfree, (*canonical)[k]);
4920 discard_cleanups (old_chain);
4925 /* A canonical line specification of the form FILE:NAME:LINENUM for
4926 symbol table and line data SAL. NULL if insufficient
4927 information. The caller is responsible for releasing any space
4931 extended_canonical_line_spec (struct symtab_and_line sal, const char *name)
4935 if (sal.symtab == NULL || sal.symtab->filename == NULL || sal.line <= 0)
4938 r = (char *) xmalloc (strlen (name) + strlen (sal.symtab->filename)
4939 + sizeof (sal.line) * 3 + 3);
4940 sprintf (r, "%s:'%s':%d", sal.symtab->filename, name, sal.line);
4945 int begin_bnum = -1;
4947 int begin_annotate_level = 0;
4950 begin_cleanup (void *dummy)
4952 begin_annotate_level = 0;
4956 begin_command (char *args, int from_tty)
4958 struct minimal_symbol *msym;
4959 CORE_ADDR main_program_name_addr;
4960 char main_program_name[1024];
4961 struct cleanup *old_chain = make_cleanup (begin_cleanup, NULL);
4962 begin_annotate_level = 2;
4964 /* Check that there is a program to debug */
4965 if (!have_full_symbols () && !have_partial_symbols ())
4966 error ("No symbol table is loaded. Use the \"file\" command.");
4968 /* Check that we are debugging an Ada program */
4969 /* if (ada_update_initial_language (language_unknown, NULL) != language_ada)
4970 error ("Cannot find the Ada initialization procedure. Is this an Ada main program?");
4972 /* FIXME: language_ada should be defined in defs.h */
4974 /* Get the address of the name of the main procedure */
4975 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
4979 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
4980 if (main_program_name_addr == 0)
4981 error ("Invalid address for Ada main program name.");
4983 /* Read the name of the main procedure */
4984 extract_string (main_program_name_addr, main_program_name);
4986 /* Put a temporary breakpoint in the Ada main program and run */
4987 do_command ("tbreak ", main_program_name, 0);
4988 do_command ("run ", args, 0);
4992 /* If we could not find the symbol containing the name of the
4993 main program, that means that the compiler that was used to build
4994 was not recent enough. In that case, we fallback to the previous
4995 mechanism, which is a little bit less reliable, but has proved to work
4996 in most cases. The only cases where it will fail is when the user
4997 has set some breakpoints which will be hit before the end of the
4998 begin command processing (eg in the initialization code).
5000 The begining of the main Ada subprogram is located by breaking
5001 on the adainit procedure. Since we know that the binder generates
5002 the call to this procedure exactly 2 calls before the call to the
5003 Ada main subprogram, it is then easy to put a breakpoint on this
5004 Ada main subprogram once we hit adainit.
5006 do_command ("tbreak adainit", 0);
5007 do_command ("run ", args, 0);
5008 do_command ("up", 0);
5009 do_command ("tbreak +2", 0);
5010 do_command ("continue", 0);
5011 do_command ("step", 0);
5014 do_cleanups (old_chain);
5018 is_ada_runtime_file (char *filename)
5020 return (STREQN (filename, "s-", 2) ||
5021 STREQN (filename, "a-", 2) ||
5022 STREQN (filename, "g-", 2) || STREQN (filename, "i-", 2));
5025 /* find the first frame that contains debugging information and that is not
5026 part of the Ada run-time, starting from fi and moving upward. */
5029 find_printable_frame (struct frame_info *fi, int level)
5031 struct symtab_and_line sal;
5033 for (; fi != NULL; level += 1, fi = get_prev_frame (fi))
5035 find_frame_sal (fi, &sal);
5036 if (sal.symtab && !is_ada_runtime_file (sal.symtab->filename))
5038 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
5039 /* libpthread.so contains some debugging information that prevents us
5040 from finding the right frame */
5042 if (sal.symtab->objfile &&
5043 STREQ (sal.symtab->objfile->name, "/usr/shlib/libpthread.so"))
5046 deprecated_selected_frame = fi;
5055 ada_report_exception_break (struct breakpoint *b)
5057 /* FIXME: break_on_exception should be defined in breakpoint.h */
5058 /* if (b->break_on_exception == 1)
5060 /* Assume that cond has 16 elements, the 15th
5061 being the exception *//*
5062 if (b->cond && b->cond->nelts == 16)
5064 ui_out_text (uiout, "on ");
5065 ui_out_field_string (uiout, "exception",
5066 SYMBOL_NAME (b->cond->elts[14].symbol));
5069 ui_out_text (uiout, "on all exceptions");
5071 else if (b->break_on_exception == 2)
5072 ui_out_text (uiout, "on unhandled exception");
5073 else if (b->break_on_exception == 3)
5074 ui_out_text (uiout, "on assert failure");
5076 if (b->break_on_exception == 1)
5078 /* Assume that cond has 16 elements, the 15th
5079 being the exception *//*
5080 if (b->cond && b->cond->nelts == 16)
5082 fputs_filtered ("on ", gdb_stdout);
5083 fputs_filtered (SYMBOL_NAME
5084 (b->cond->elts[14].symbol), gdb_stdout);
5087 fputs_filtered ("on all exceptions", gdb_stdout);
5089 else if (b->break_on_exception == 2)
5090 fputs_filtered ("on unhandled exception", gdb_stdout);
5091 else if (b->break_on_exception == 3)
5092 fputs_filtered ("on assert failure", gdb_stdout);
5097 ada_is_exception_sym (struct symbol *sym)
5099 char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
5101 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
5102 && SYMBOL_CLASS (sym) != LOC_BLOCK
5103 && SYMBOL_CLASS (sym) != LOC_CONST
5104 && type_name != NULL && STREQ (type_name, "exception"));
5108 ada_maybe_exception_partial_symbol (struct partial_symbol *sym)
5110 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
5111 && SYMBOL_CLASS (sym) != LOC_BLOCK
5112 && SYMBOL_CLASS (sym) != LOC_CONST);
5115 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5116 into equivalent form. Return resulting argument string. Set
5117 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5118 break on unhandled, 3 for assert, 0 otherwise. */
5120 ada_breakpoint_rewrite (char *arg, int *break_on_exceptionp)
5124 *break_on_exceptionp = 0;
5125 /* FIXME: language_ada should be defined in defs.h */
5126 /* if (current_language->la_language == language_ada
5127 && STREQN (arg, "exception", 9) &&
5128 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5130 char *tok, *end_tok;
5133 *break_on_exceptionp = 1;
5136 while (*tok == ' ' || *tok == '\t')
5141 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5144 toklen = end_tok - tok;
5146 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5147 "long_integer(e) = long_integer(&)")
5149 make_cleanup (xfree, arg);
5151 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5152 else if (STREQN (tok, "unhandled", toklen))
5154 *break_on_exceptionp = 2;
5155 strcpy (arg, "__gnat_unhandled_exception");
5159 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5160 "long_integer(e) = long_integer(&%.*s)",
5164 else if (current_language->la_language == language_ada
5165 && STREQN (arg, "assert", 6) &&
5166 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5168 char *tok = arg + 6;
5170 *break_on_exceptionp = 3;
5173 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5174 + strlen (tok) + 1);
5175 make_cleanup (xfree, arg);
5176 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5185 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5186 to be invisible to users. */
5189 ada_is_ignored_field (struct type *type, int field_num)
5191 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
5195 const char *name = TYPE_FIELD_NAME (type, field_num);
5196 return (name == NULL
5197 || (name[0] == '_' && !STREQN (name, "_parent", 7)));
5201 /* True iff structure type TYPE has a tag field. */
5204 ada_is_tagged_type (struct type *type)
5206 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5209 return (ada_lookup_struct_elt_type (type, "_tag", 1, NULL) != NULL);
5212 /* The type of the tag on VAL. */
5215 ada_tag_type (struct value *val)
5217 return ada_lookup_struct_elt_type (VALUE_TYPE (val), "_tag", 0, NULL);
5220 /* The value of the tag on VAL. */
5223 ada_value_tag (struct value *val)
5225 return ada_value_struct_elt (val, "_tag", "record");
5228 /* The parent type of TYPE, or NULL if none. */
5231 ada_parent_type (struct type *type)
5235 CHECK_TYPEDEF (type);
5237 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
5240 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5241 if (ada_is_parent_field (type, i))
5242 return check_typedef (TYPE_FIELD_TYPE (type, i));
5247 /* True iff field number FIELD_NUM of structure type TYPE contains the
5248 parent-type (inherited) fields of a derived type. Assumes TYPE is
5249 a structure type with at least FIELD_NUM+1 fields. */
5252 ada_is_parent_field (struct type *type, int field_num)
5254 const char *name = TYPE_FIELD_NAME (check_typedef (type), field_num);
5255 return (name != NULL &&
5256 (STREQN (name, "PARENT", 6) || STREQN (name, "_parent", 7)));
5259 /* True iff field number FIELD_NUM of structure type TYPE is a
5260 transparent wrapper field (which should be silently traversed when doing
5261 field selection and flattened when printing). Assumes TYPE is a
5262 structure type with at least FIELD_NUM+1 fields. Such fields are always
5266 ada_is_wrapper_field (struct type *type, int field_num)
5268 const char *name = TYPE_FIELD_NAME (type, field_num);
5269 return (name != NULL
5270 && (STREQN (name, "PARENT", 6) || STREQ (name, "REP")
5271 || STREQN (name, "_parent", 7)
5272 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
5275 /* True iff field number FIELD_NUM of structure or union type TYPE
5276 is a variant wrapper. Assumes TYPE is a structure type with at least
5277 FIELD_NUM+1 fields. */
5280 ada_is_variant_part (struct type *type, int field_num)
5282 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
5283 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
5284 || (is_dynamic_field (type, field_num)
5285 && TYPE_CODE (TYPE_TARGET_TYPE (field_type)) ==
5289 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5290 whose discriminants are contained in the record type OUTER_TYPE,
5291 returns the type of the controlling discriminant for the variant. */
5294 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
5296 char *name = ada_variant_discrim_name (var_type);
5297 struct type *type = ada_lookup_struct_elt_type (outer_type, name, 1, NULL);
5299 return builtin_type_int;
5304 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5305 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5306 represents a 'when others' clause; otherwise 0. */
5309 ada_is_others_clause (struct type *type, int field_num)
5311 const char *name = TYPE_FIELD_NAME (type, field_num);
5312 return (name != NULL && name[0] == 'O');
5315 /* Assuming that TYPE0 is the type of the variant part of a record,
5316 returns the name of the discriminant controlling the variant. The
5317 value is valid until the next call to ada_variant_discrim_name. */
5320 ada_variant_discrim_name (struct type *type0)
5322 static char *result = NULL;
5323 static size_t result_len = 0;
5326 const char *discrim_end;
5327 const char *discrim_start;
5329 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
5330 type = TYPE_TARGET_TYPE (type0);
5334 name = ada_type_name (type);
5336 if (name == NULL || name[0] == '\000')
5339 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
5342 if (STREQN (discrim_end, "___XVN", 6))
5345 if (discrim_end == name)
5348 for (discrim_start = discrim_end; discrim_start != name + 3;
5351 if (discrim_start == name + 1)
5353 if ((discrim_start > name + 3 && STREQN (discrim_start - 3, "___", 3))
5354 || discrim_start[-1] == '.')
5358 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
5359 strncpy (result, discrim_start, discrim_end - discrim_start);
5360 result[discrim_end - discrim_start] = '\0';
5364 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5365 position of the character just past the number scanned in *NEW_K,
5366 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5367 if there was a valid number at the given position, and 0 otherwise. A
5368 "subtype-encoded" number consists of the absolute value in decimal,
5369 followed by the letter 'm' to indicate a negative number. Assumes 0m
5373 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
5377 if (!isdigit (str[k]))
5380 /* Do it the hard way so as not to make any assumption about
5381 the relationship of unsigned long (%lu scan format code) and
5384 while (isdigit (str[k]))
5386 RU = RU * 10 + (str[k] - '0');
5393 *R = (-(LONGEST) (RU - 1)) - 1;
5399 /* NOTE on the above: Technically, C does not say what the results of
5400 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5401 number representable as a LONGEST (although either would probably work
5402 in most implementations). When RU>0, the locution in the then branch
5403 above is always equivalent to the negative of RU. */
5410 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5411 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5412 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5415 ada_in_variant (LONGEST val, struct type *type, int field_num)
5417 const char *name = TYPE_FIELD_NAME (type, field_num);
5430 if (!ada_scan_number (name, p + 1, &W, &p))
5439 if (!ada_scan_number (name, p + 1, &L, &p)
5440 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
5442 if (val >= L && val <= U)
5454 /* Given a value ARG1 (offset by OFFSET bytes)
5455 of a struct or union type ARG_TYPE,
5456 extract and return the value of one of its (non-static) fields.
5457 FIELDNO says which field. Differs from value_primitive_field only
5458 in that it can handle packed values of arbitrary type. */
5461 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
5462 struct type *arg_type)
5467 CHECK_TYPEDEF (arg_type);
5468 type = TYPE_FIELD_TYPE (arg_type, fieldno);
5470 /* Handle packed fields */
5472 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
5474 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
5475 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
5477 return ada_value_primitive_packed_val (arg1, VALUE_CONTENTS (arg1),
5478 offset + bit_pos / 8,
5479 bit_pos % 8, bit_size, type);
5482 return value_primitive_field (arg1, offset, fieldno, arg_type);
5486 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5487 and search in it assuming it has (class) type TYPE.
5488 If found, return value, else return NULL.
5490 Searches recursively through wrapper fields (e.g., '_parent'). */
5493 ada_search_struct_field (char *name, struct value *arg, int offset,
5497 CHECK_TYPEDEF (type);
5499 for (i = TYPE_NFIELDS (type) - 1; i >= 0; i -= 1)
5501 char *t_field_name = TYPE_FIELD_NAME (type, i);
5503 if (t_field_name == NULL)
5506 else if (field_name_match (t_field_name, name))
5507 return ada_value_primitive_field (arg, offset, i, type);
5509 else if (ada_is_wrapper_field (type, i))
5511 struct value *v = ada_search_struct_field (name, arg,
5513 TYPE_FIELD_BITPOS (type,
5516 TYPE_FIELD_TYPE (type,
5522 else if (ada_is_variant_part (type, i))
5525 struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, i));
5526 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
5528 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
5530 struct value *v = ada_search_struct_field (name, arg,
5534 (field_type, j) / 8,
5545 /* Given ARG, a value of type (pointer to a)* structure/union,
5546 extract the component named NAME from the ultimate target structure/union
5547 and return it as a value with its appropriate type.
5549 The routine searches for NAME among all members of the structure itself
5550 and (recursively) among all members of any wrapper members
5553 ERR is a name (for use in error messages) that identifies the class
5554 of entity that ARG is supposed to be. */
5557 ada_value_struct_elt (struct value *arg, char *name, char *err)
5562 arg = ada_coerce_ref (arg);
5563 t = check_typedef (VALUE_TYPE (arg));
5565 /* Follow pointers until we get to a non-pointer. */
5567 while (TYPE_CODE (t) == TYPE_CODE_PTR || TYPE_CODE (t) == TYPE_CODE_REF)
5569 arg = ada_value_ind (arg);
5570 t = check_typedef (VALUE_TYPE (arg));
5573 if (TYPE_CODE (t) != TYPE_CODE_STRUCT && TYPE_CODE (t) != TYPE_CODE_UNION)
5574 error ("Attempt to extract a component of a value that is not a %s.",
5577 v = ada_search_struct_field (name, arg, 0, t);
5579 error ("There is no member named %s.", name);
5584 /* Given a type TYPE, look up the type of the component of type named NAME.
5585 If DISPP is non-null, add its byte displacement from the beginning of a
5586 structure (pointed to by a value) of type TYPE to *DISPP (does not
5587 work for packed fields).
5589 Matches any field whose name has NAME as a prefix, possibly
5592 TYPE can be either a struct or union, or a pointer or reference to
5593 a struct or union. If it is a pointer or reference, its target
5594 type is automatically used.
5596 Looks recursively into variant clauses and parent types.
5598 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5601 ada_lookup_struct_elt_type (struct type *type, char *name, int noerr,
5611 CHECK_TYPEDEF (type);
5612 if (TYPE_CODE (type) != TYPE_CODE_PTR
5613 && TYPE_CODE (type) != TYPE_CODE_REF)
5615 type = TYPE_TARGET_TYPE (type);
5618 if (TYPE_CODE (type) != TYPE_CODE_STRUCT &&
5619 TYPE_CODE (type) != TYPE_CODE_UNION)
5621 target_terminal_ours ();
5622 gdb_flush (gdb_stdout);
5623 fprintf_unfiltered (gdb_stderr, "Type ");
5624 type_print (type, "", gdb_stderr, -1);
5625 error (" is not a structure or union type");
5628 type = to_static_fixed_type (type);
5630 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
5632 char *t_field_name = TYPE_FIELD_NAME (type, i);
5636 if (t_field_name == NULL)
5639 else if (field_name_match (t_field_name, name))
5642 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
5643 return check_typedef (TYPE_FIELD_TYPE (type, i));
5646 else if (ada_is_wrapper_field (type, i))
5649 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
5654 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
5659 else if (ada_is_variant_part (type, i))
5662 struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, i));
5664 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
5667 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
5672 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
5683 target_terminal_ours ();
5684 gdb_flush (gdb_stdout);
5685 fprintf_unfiltered (gdb_stderr, "Type ");
5686 type_print (type, "", gdb_stderr, -1);
5687 fprintf_unfiltered (gdb_stderr, " has no component named ");
5688 error ("%s", name == NULL ? "<null>" : name);
5694 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5695 within a value of type OUTER_TYPE that is stored in GDB at
5696 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5697 numbering from 0) is applicable. Returns -1 if none are. */
5700 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
5701 char *outer_valaddr)
5706 struct type *discrim_type;
5707 char *discrim_name = ada_variant_discrim_name (var_type);
5708 LONGEST discrim_val;
5712 ada_lookup_struct_elt_type (outer_type, discrim_name, 1, &disp);
5713 if (discrim_type == NULL)
5715 discrim_val = unpack_long (discrim_type, outer_valaddr + disp);
5718 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
5720 if (ada_is_others_clause (var_type, i))
5722 else if (ada_in_variant (discrim_val, var_type, i))
5726 return others_clause;
5731 /* Dynamic-Sized Records */
5733 /* Strategy: The type ostensibly attached to a value with dynamic size
5734 (i.e., a size that is not statically recorded in the debugging
5735 data) does not accurately reflect the size or layout of the value.
5736 Our strategy is to convert these values to values with accurate,
5737 conventional types that are constructed on the fly. */
5739 /* There is a subtle and tricky problem here. In general, we cannot
5740 determine the size of dynamic records without its data. However,
5741 the 'struct value' data structure, which GDB uses to represent
5742 quantities in the inferior process (the target), requires the size
5743 of the type at the time of its allocation in order to reserve space
5744 for GDB's internal copy of the data. That's why the
5745 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5746 rather than struct value*s.
5748 However, GDB's internal history variables ($1, $2, etc.) are
5749 struct value*s containing internal copies of the data that are not, in
5750 general, the same as the data at their corresponding addresses in
5751 the target. Fortunately, the types we give to these values are all
5752 conventional, fixed-size types (as per the strategy described
5753 above), so that we don't usually have to perform the
5754 'to_fixed_xxx_type' conversions to look at their values.
5755 Unfortunately, there is one exception: if one of the internal
5756 history variables is an array whose elements are unconstrained
5757 records, then we will need to create distinct fixed types for each
5758 element selected. */
5760 /* The upshot of all of this is that many routines take a (type, host
5761 address, target address) triple as arguments to represent a value.
5762 The host address, if non-null, is supposed to contain an internal
5763 copy of the relevant data; otherwise, the program is to consult the
5764 target at the target address. */
5766 /* Assuming that VAL0 represents a pointer value, the result of
5767 dereferencing it. Differs from value_ind in its treatment of
5768 dynamic-sized types. */
5771 ada_value_ind (struct value *val0)
5773 struct value *val = unwrap_value (value_ind (val0));
5774 return ada_to_fixed_value (VALUE_TYPE (val), 0,
5775 VALUE_ADDRESS (val) + VALUE_OFFSET (val), val);
5778 /* The value resulting from dereferencing any "reference to"
5779 * qualifiers on VAL0. */
5780 static struct value *
5781 ada_coerce_ref (struct value *val0)
5783 if (TYPE_CODE (VALUE_TYPE (val0)) == TYPE_CODE_REF)
5785 struct value *val = val0;
5787 val = unwrap_value (val);
5788 return ada_to_fixed_value (VALUE_TYPE (val), 0,
5789 VALUE_ADDRESS (val) + VALUE_OFFSET (val),
5796 /* Return OFF rounded upward if necessary to a multiple of
5797 ALIGNMENT (a power of 2). */
5800 align_value (unsigned int off, unsigned int alignment)
5802 return (off + alignment - 1) & ~(alignment - 1);
5805 /* Return the additional bit offset required by field F of template
5809 field_offset (struct type *type, int f)
5811 int n = TYPE_FIELD_BITPOS (type, f);
5812 /* Kludge (temporary?) to fix problem with dwarf output. */
5814 return (unsigned int) n & 0xffff;
5820 /* Return the bit alignment required for field #F of template type TYPE. */
5823 field_alignment (struct type *type, int f)
5825 const char *name = TYPE_FIELD_NAME (type, f);
5826 int len = (name == NULL) ? 0 : strlen (name);
5829 if (len < 8 || !isdigit (name[len - 1]))
5830 return TARGET_CHAR_BIT;
5832 if (isdigit (name[len - 2]))
5833 align_offset = len - 2;
5835 align_offset = len - 1;
5837 if (align_offset < 7 || !STREQN ("___XV", name + align_offset - 6, 5))
5838 return TARGET_CHAR_BIT;
5840 return atoi (name + align_offset) * TARGET_CHAR_BIT;
5843 /* Find a type named NAME. Ignores ambiguity. */
5845 ada_find_any_type (const char *name)
5849 sym = standard_lookup (name, VAR_NAMESPACE);
5850 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5851 return SYMBOL_TYPE (sym);
5853 sym = standard_lookup (name, STRUCT_NAMESPACE);
5855 return SYMBOL_TYPE (sym);
5860 /* Because of GNAT encoding conventions, several GDB symbols may match a
5861 given type name. If the type denoted by TYPE0 is to be preferred to
5862 that of TYPE1 for purposes of type printing, return non-zero;
5863 otherwise return 0. */
5865 ada_prefer_type (struct type *type0, struct type *type1)
5869 else if (type0 == NULL)
5871 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
5873 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
5875 else if (ada_is_packed_array_type (type0))
5877 else if (ada_is_array_descriptor (type0)
5878 && !ada_is_array_descriptor (type1))
5880 else if (ada_renaming_type (type0) != NULL
5881 && ada_renaming_type (type1) == NULL)
5886 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5887 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5889 ada_type_name (struct type *type)
5893 else if (TYPE_NAME (type) != NULL)
5894 return TYPE_NAME (type);
5896 return TYPE_TAG_NAME (type);
5899 /* Find a parallel type to TYPE whose name is formed by appending
5900 SUFFIX to the name of TYPE. */
5903 ada_find_parallel_type (struct type *type, const char *suffix)
5906 static size_t name_len = 0;
5907 struct symbol **syms;
5908 struct block **blocks;
5911 char *typename = ada_type_name (type);
5913 if (typename == NULL)
5916 len = strlen (typename);
5918 GROW_VECT (name, name_len, len + strlen (suffix) + 1);
5920 strcpy (name, typename);
5921 strcpy (name + len, suffix);
5923 return ada_find_any_type (name);
5927 /* If TYPE is a variable-size record type, return the corresponding template
5928 type describing its fields. Otherwise, return NULL. */
5930 static struct type *
5931 dynamic_template_type (struct type *type)
5933 CHECK_TYPEDEF (type);
5935 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
5936 || ada_type_name (type) == NULL)
5940 int len = strlen (ada_type_name (type));
5941 if (len > 6 && STREQ (ada_type_name (type) + len - 6, "___XVE"))
5944 return ada_find_parallel_type (type, "___XVE");
5948 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5949 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5952 is_dynamic_field (struct type *templ_type, int field_num)
5954 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
5956 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
5957 && strstr (name, "___XVL") != NULL;
5960 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
5961 contains a variant part. */
5964 contains_variant_part (struct type *type)
5968 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
5969 || TYPE_NFIELDS (type) <= 0)
5971 return ada_is_variant_part (type, TYPE_NFIELDS (type) - 1);
5974 /* A record type with no fields, . */
5975 static struct type *
5976 empty_record (struct objfile *objfile)
5978 struct type *type = alloc_type (objfile);
5979 TYPE_CODE (type) = TYPE_CODE_STRUCT;
5980 TYPE_NFIELDS (type) = 0;
5981 TYPE_FIELDS (type) = NULL;
5982 TYPE_NAME (type) = "<empty>";
5983 TYPE_TAG_NAME (type) = NULL;
5984 TYPE_FLAGS (type) = 0;
5985 TYPE_LENGTH (type) = 0;
5989 /* An ordinary record type (with fixed-length fields) that describes
5990 the value of type TYPE at VALADDR or ADDRESS (see comments at
5991 the beginning of this section) VAL according to GNAT conventions.
5992 DVAL0 should describe the (portion of a) record that contains any
5993 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
5994 an outer-level type (i.e., as opposed to a branch of a variant.) A
5995 variant field (unless unchecked) is replaced by a particular branch
5997 /* NOTE: Limitations: For now, we assume that dynamic fields and
5998 * variants occupy whole numbers of bytes. However, they need not be
6001 static struct type *
6002 template_to_fixed_record_type (struct type *type, char *valaddr,
6003 CORE_ADDR address, struct value *dval0)
6005 struct value *mark = value_mark ();
6008 int nfields, bit_len;
6012 nfields = TYPE_NFIELDS (type);
6013 rtype = alloc_type (TYPE_OBJFILE (type));
6014 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6015 INIT_CPLUS_SPECIFIC (rtype);
6016 TYPE_NFIELDS (rtype) = nfields;
6017 TYPE_FIELDS (rtype) = (struct field *)
6018 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6019 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
6020 TYPE_NAME (rtype) = ada_type_name (type);
6021 TYPE_TAG_NAME (rtype) = NULL;
6022 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
6024 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6028 for (f = 0; f < nfields; f += 1)
6030 int fld_bit_len, bit_incr;
6033 field_alignment (type, f)) + TYPE_FIELD_BITPOS (type, f);
6034 /* NOTE: used to use field_offset above, but that causes
6035 * problems with really negative bit positions. So, let's
6036 * rediscover why we needed field_offset and fix it properly. */
6037 TYPE_FIELD_BITPOS (rtype, f) = off;
6038 TYPE_FIELD_BITSIZE (rtype, f) = 0;
6039 TYPE_FIELD_STATIC_KIND (rtype, f) = 0;
6041 if (ada_is_variant_part (type, f))
6043 struct type *branch_type;
6046 dval = value_from_contents_and_address (rtype, valaddr, address);
6051 to_fixed_variant_branch_type
6052 (TYPE_FIELD_TYPE (type, f),
6053 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6054 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
6055 if (branch_type == NULL)
6056 TYPE_NFIELDS (rtype) -= 1;
6059 TYPE_FIELD_TYPE (rtype, f) = branch_type;
6060 TYPE_FIELD_NAME (rtype, f) = "S";
6064 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6066 else if (is_dynamic_field (type, f))
6069 dval = value_from_contents_and_address (rtype, valaddr, address);
6073 TYPE_FIELD_TYPE (rtype, f) =
6076 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
6077 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
6078 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
6079 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6080 bit_incr = fld_bit_len =
6081 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
6085 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
6086 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
6087 if (TYPE_FIELD_BITSIZE (type, f) > 0)
6088 bit_incr = fld_bit_len =
6089 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
6091 bit_incr = fld_bit_len =
6092 TYPE_LENGTH (TYPE_FIELD_TYPE (type, f)) * TARGET_CHAR_BIT;
6094 if (off + fld_bit_len > bit_len)
6095 bit_len = off + fld_bit_len;
6097 TYPE_LENGTH (rtype) = bit_len / TARGET_CHAR_BIT;
6099 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype), TYPE_LENGTH (type));
6101 value_free_to_mark (mark);
6102 if (TYPE_LENGTH (rtype) > varsize_limit)
6103 error ("record type with dynamic size is larger than varsize-limit");
6107 /* As for template_to_fixed_record_type, but uses no run-time values.
6108 As a result, this type can only be approximate, but that's OK,
6109 since it is used only for type determinations. Works on both
6111 Representation note: to save space, we memoize the result of this
6112 function in the TYPE_TARGET_TYPE of the template type. */
6114 static struct type *
6115 template_to_static_fixed_type (struct type *templ_type)
6121 if (TYPE_TARGET_TYPE (templ_type) != NULL)
6122 return TYPE_TARGET_TYPE (templ_type);
6124 nfields = TYPE_NFIELDS (templ_type);
6125 TYPE_TARGET_TYPE (templ_type) = type =
6126 alloc_type (TYPE_OBJFILE (templ_type));
6127 TYPE_CODE (type) = TYPE_CODE (templ_type);
6128 INIT_CPLUS_SPECIFIC (type);
6129 TYPE_NFIELDS (type) = nfields;
6130 TYPE_FIELDS (type) = (struct field *)
6131 TYPE_ALLOC (type, nfields * sizeof (struct field));
6132 memset (TYPE_FIELDS (type), 0, sizeof (struct field) * nfields);
6133 TYPE_NAME (type) = ada_type_name (templ_type);
6134 TYPE_TAG_NAME (type) = NULL;
6135 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6136 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6137 TYPE_LENGTH (type) = 0;
6139 for (f = 0; f < nfields; f += 1)
6141 TYPE_FIELD_BITPOS (type, f) = 0;
6142 TYPE_FIELD_BITSIZE (type, f) = 0;
6143 TYPE_FIELD_STATIC_KIND (type, f) = 0;
6145 if (is_dynamic_field (templ_type, f))
6147 TYPE_FIELD_TYPE (type, f) =
6148 to_static_fixed_type (TYPE_TARGET_TYPE
6149 (TYPE_FIELD_TYPE (templ_type, f)));
6150 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (templ_type, f);
6154 TYPE_FIELD_TYPE (type, f) =
6155 check_typedef (TYPE_FIELD_TYPE (templ_type, f));
6156 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (templ_type, f);
6163 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6164 part -- in which the variant part is replaced with the appropriate
6166 static struct type *
6167 to_record_with_fixed_variant_part (struct type *type, char *valaddr,
6168 CORE_ADDR address, struct value *dval)
6170 struct value *mark = value_mark ();
6172 struct type *branch_type;
6173 int nfields = TYPE_NFIELDS (type);
6178 rtype = alloc_type (TYPE_OBJFILE (type));
6179 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
6180 INIT_CPLUS_SPECIFIC (type);
6181 TYPE_NFIELDS (rtype) = TYPE_NFIELDS (type);
6182 TYPE_FIELDS (rtype) =
6183 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
6184 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
6185 sizeof (struct field) * nfields);
6186 TYPE_NAME (rtype) = ada_type_name (type);
6187 TYPE_TAG_NAME (rtype) = NULL;
6188 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6189 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6190 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
6193 to_fixed_variant_branch_type
6194 (TYPE_FIELD_TYPE (type, nfields - 1),
6195 cond_offset_host (valaddr,
6196 TYPE_FIELD_BITPOS (type,
6197 nfields - 1) / TARGET_CHAR_BIT),
6198 cond_offset_target (address,
6199 TYPE_FIELD_BITPOS (type,
6200 nfields - 1) / TARGET_CHAR_BIT),
6202 if (branch_type == NULL)
6204 TYPE_NFIELDS (rtype) -= 1;
6205 TYPE_LENGTH (rtype) -=
6206 TYPE_LENGTH (TYPE_FIELD_TYPE (type, nfields - 1));
6210 TYPE_FIELD_TYPE (rtype, nfields - 1) = branch_type;
6211 TYPE_FIELD_NAME (rtype, nfields - 1) = "S";
6212 TYPE_FIELD_BITSIZE (rtype, nfields - 1) = 0;
6213 TYPE_FIELD_STATIC_KIND (rtype, nfields - 1) = 0;
6214 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
6215 -TYPE_LENGTH (TYPE_FIELD_TYPE (type, nfields - 1));
6221 /* An ordinary record type (with fixed-length fields) that describes
6222 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6223 beginning of this section]. Any necessary discriminants' values
6224 should be in DVAL, a record value; it should be NULL if the object
6225 at ADDR itself contains any necessary discriminant values. A
6226 variant field (unless unchecked) is replaced by a particular branch
6229 static struct type *
6230 to_fixed_record_type (struct type *type0, char *valaddr, CORE_ADDR address,
6233 struct type *templ_type;
6235 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6236 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6239 templ_type = dynamic_template_type (type0);
6241 if (templ_type != NULL)
6242 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
6243 else if (contains_variant_part (type0))
6244 return to_record_with_fixed_variant_part (type0, valaddr, address, dval);
6247 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6248 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6254 /* An ordinary record type (with fixed-length fields) that describes
6255 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6256 union type. Any necessary discriminants' values should be in DVAL,
6257 a record value. That is, this routine selects the appropriate
6258 branch of the union at ADDR according to the discriminant value
6259 indicated in the union's type name. */
6261 static struct type *
6262 to_fixed_variant_branch_type (struct type *var_type0, char *valaddr,
6263 CORE_ADDR address, struct value *dval)
6266 struct type *templ_type;
6267 struct type *var_type;
6269 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
6270 var_type = TYPE_TARGET_TYPE (var_type0);
6272 var_type = var_type0;
6274 templ_type = ada_find_parallel_type (var_type, "___XVU");
6276 if (templ_type != NULL)
6277 var_type = templ_type;
6280 ada_which_variant_applies (var_type,
6281 VALUE_TYPE (dval), VALUE_CONTENTS (dval));
6284 return empty_record (TYPE_OBJFILE (var_type));
6285 else if (is_dynamic_field (var_type, which))
6287 to_fixed_record_type
6288 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
6289 valaddr, address, dval);
6290 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type, which)))
6292 to_fixed_record_type
6293 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
6295 return TYPE_FIELD_TYPE (var_type, which);
6298 /* Assuming that TYPE0 is an array type describing the type of a value
6299 at ADDR, and that DVAL describes a record containing any
6300 discriminants used in TYPE0, returns a type for the value that
6301 contains no dynamic components (that is, no components whose sizes
6302 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6303 true, gives an error message if the resulting type's size is over
6307 static struct type *
6308 to_fixed_array_type (struct type *type0, struct value *dval,
6311 struct type *index_type_desc;
6312 struct type *result;
6314 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6315 /* if (ada_is_packed_array_type (type0) /* revisit? *//*
6316 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6319 index_type_desc = ada_find_parallel_type (type0, "___XA");
6320 if (index_type_desc == NULL)
6322 struct type *elt_type0 = check_typedef (TYPE_TARGET_TYPE (type0));
6323 /* NOTE: elt_type---the fixed version of elt_type0---should never
6324 * depend on the contents of the array in properly constructed
6325 * debugging data. */
6326 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval);
6328 if (elt_type0 == elt_type)
6331 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
6332 elt_type, TYPE_INDEX_TYPE (type0));
6337 struct type *elt_type0;
6340 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
6341 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
6343 /* NOTE: result---the fixed version of elt_type0---should never
6344 * depend on the contents of the array in properly constructed
6345 * debugging data. */
6346 result = ada_to_fixed_type (check_typedef (elt_type0), 0, 0, dval);
6347 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
6349 struct type *range_type =
6350 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i),
6351 dval, TYPE_OBJFILE (type0));
6352 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
6353 result, range_type);
6355 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
6356 error ("array type with dynamic size is larger than varsize-limit");
6359 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6360 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6365 /* A standard type (containing no dynamically sized components)
6366 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6367 DVAL describes a record containing any discriminants used in TYPE0,
6368 and may be NULL if there are none. */
6371 ada_to_fixed_type (struct type *type, char *valaddr, CORE_ADDR address,
6374 CHECK_TYPEDEF (type);
6375 switch (TYPE_CODE (type))
6379 case TYPE_CODE_STRUCT:
6380 return to_fixed_record_type (type, valaddr, address, NULL);
6381 case TYPE_CODE_ARRAY:
6382 return to_fixed_array_type (type, dval, 0);
6383 case TYPE_CODE_UNION:
6387 return to_fixed_variant_branch_type (type, valaddr, address, dval);
6391 /* A standard (static-sized) type corresponding as well as possible to
6392 TYPE0, but based on no runtime data. */
6394 static struct type *
6395 to_static_fixed_type (struct type *type0)
6402 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6403 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6406 CHECK_TYPEDEF (type0);
6408 switch (TYPE_CODE (type0))
6412 case TYPE_CODE_STRUCT:
6413 type = dynamic_template_type (type0);
6415 return template_to_static_fixed_type (type);
6417 case TYPE_CODE_UNION:
6418 type = ada_find_parallel_type (type0, "___XVU");
6420 return template_to_static_fixed_type (type);
6425 /* A static approximation of TYPE with all type wrappers removed. */
6426 static struct type *
6427 static_unwrap_type (struct type *type)
6429 if (ada_is_aligner_type (type))
6431 struct type *type1 = TYPE_FIELD_TYPE (check_typedef (type), 0);
6432 if (ada_type_name (type1) == NULL)
6433 TYPE_NAME (type1) = ada_type_name (type);
6435 return static_unwrap_type (type1);
6439 struct type *raw_real_type = ada_get_base_type (type);
6440 if (raw_real_type == type)
6443 return to_static_fixed_type (raw_real_type);
6447 /* In some cases, incomplete and private types require
6448 cross-references that are not resolved as records (for example,
6450 type FooP is access Foo;
6452 type Foo is array ...;
6453 ). In these cases, since there is no mechanism for producing
6454 cross-references to such types, we instead substitute for FooP a
6455 stub enumeration type that is nowhere resolved, and whose tag is
6456 the name of the actual type. Call these types "non-record stubs". */
6458 /* A type equivalent to TYPE that is not a non-record stub, if one
6459 exists, otherwise TYPE. */
6461 ada_completed_type (struct type *type)
6463 CHECK_TYPEDEF (type);
6464 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
6465 || (TYPE_FLAGS (type) & TYPE_FLAG_STUB) == 0
6466 || TYPE_TAG_NAME (type) == NULL)
6470 char *name = TYPE_TAG_NAME (type);
6471 struct type *type1 = ada_find_any_type (name);
6472 return (type1 == NULL) ? type : type1;
6476 /* A value representing the data at VALADDR/ADDRESS as described by
6477 type TYPE0, but with a standard (static-sized) type that correctly
6478 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6479 type, then return VAL0 [this feature is simply to avoid redundant
6480 creation of struct values]. */
6483 ada_to_fixed_value (struct type *type0, char *valaddr, CORE_ADDR address,
6486 struct type *type = ada_to_fixed_type (type0, valaddr, address, NULL);
6487 if (type == type0 && val0 != NULL)
6490 return value_from_contents_and_address (type, valaddr, address);
6493 /* A value representing VAL, but with a standard (static-sized) type
6494 chosen to approximate the real type of VAL as well as possible, but
6495 without consulting any runtime values. For Ada dynamic-sized
6496 types, therefore, the type of the result is likely to be inaccurate. */
6499 ada_to_static_fixed_value (struct value *val)
6502 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val)));
6503 if (type == VALUE_TYPE (val))
6506 return coerce_unspec_val_to_type (val, 0, type);
6515 /* Table mapping attribute numbers to names */
6516 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6518 static const char *attribute_names[] = {
6535 ada_attribute_name (int n)
6537 if (n > 0 && n < (int) ATR_END)
6538 return attribute_names[n];
6540 return attribute_names[0];
6543 /* Evaluate the 'POS attribute applied to ARG. */
6545 static struct value *
6546 value_pos_atr (struct value *arg)
6548 struct type *type = VALUE_TYPE (arg);
6550 if (!discrete_type_p (type))
6551 error ("'POS only defined on discrete types");
6553 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
6556 LONGEST v = value_as_long (arg);
6558 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6560 if (v == TYPE_FIELD_BITPOS (type, i))
6561 return value_from_longest (builtin_type_ada_int, i);
6563 error ("enumeration value is invalid: can't find 'POS");
6566 return value_from_longest (builtin_type_ada_int, value_as_long (arg));
6569 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6571 static struct value *
6572 value_val_atr (struct type *type, struct value *arg)
6574 if (!discrete_type_p (type))
6575 error ("'VAL only defined on discrete types");
6576 if (!integer_type_p (VALUE_TYPE (arg)))
6577 error ("'VAL requires integral argument");
6579 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
6581 long pos = value_as_long (arg);
6582 if (pos < 0 || pos >= TYPE_NFIELDS (type))
6583 error ("argument to 'VAL out of range");
6584 return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
6587 return value_from_longest (type, value_as_long (arg));
6593 /* True if TYPE appears to be an Ada character type.
6594 * [At the moment, this is true only for Character and Wide_Character;
6595 * It is a heuristic test that could stand improvement]. */
6598 ada_is_character_type (struct type *type)
6600 const char *name = ada_type_name (type);
6603 && (TYPE_CODE (type) == TYPE_CODE_CHAR
6604 || TYPE_CODE (type) == TYPE_CODE_INT
6605 || TYPE_CODE (type) == TYPE_CODE_RANGE)
6606 && (STREQ (name, "character") || STREQ (name, "wide_character")
6607 || STREQ (name, "unsigned char"));
6610 /* True if TYPE appears to be an Ada string type. */
6613 ada_is_string_type (struct type *type)
6615 CHECK_TYPEDEF (type);
6617 && TYPE_CODE (type) != TYPE_CODE_PTR
6618 && (ada_is_simple_array (type) || ada_is_array_descriptor (type))
6619 && ada_array_arity (type) == 1)
6621 struct type *elttype = ada_array_element_type (type, 1);
6623 return ada_is_character_type (elttype);
6630 /* True if TYPE is a struct type introduced by the compiler to force the
6631 alignment of a value. Such types have a single field with a
6632 distinctive name. */
6635 ada_is_aligner_type (struct type *type)
6637 CHECK_TYPEDEF (type);
6638 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
6639 && TYPE_NFIELDS (type) == 1
6640 && STREQ (TYPE_FIELD_NAME (type, 0), "F"));
6643 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6644 the parallel type. */
6647 ada_get_base_type (struct type *raw_type)
6649 struct type *real_type_namer;
6650 struct type *raw_real_type;
6651 struct type *real_type;
6653 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
6656 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
6657 if (real_type_namer == NULL
6658 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
6659 || TYPE_NFIELDS (real_type_namer) != 1)
6662 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
6663 if (raw_real_type == NULL)
6666 return raw_real_type;
6669 /* The type of value designated by TYPE, with all aligners removed. */
6672 ada_aligned_type (struct type *type)
6674 if (ada_is_aligner_type (type))
6675 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
6677 return ada_get_base_type (type);
6681 /* The address of the aligned value in an object at address VALADDR
6682 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6685 ada_aligned_value_addr (struct type *type, char *valaddr)
6687 if (ada_is_aligner_type (type))
6688 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
6690 TYPE_FIELD_BITPOS (type,
6691 0) / TARGET_CHAR_BIT);
6696 /* The printed representation of an enumeration literal with encoded
6697 name NAME. The value is good to the next call of ada_enum_name. */
6699 ada_enum_name (const char *name)
6705 if ((tmp = strstr (name, "__")) != NULL)
6707 else if ((tmp = strchr (name, '.')) != NULL)
6715 static char result[16];
6717 if (name[1] == 'U' || name[1] == 'W')
6719 if (sscanf (name + 2, "%x", &v) != 1)
6725 if (isascii (v) && isprint (v))
6726 sprintf (result, "'%c'", v);
6727 else if (name[1] == 'U')
6728 sprintf (result, "[\"%02x\"]", v);
6730 sprintf (result, "[\"%04x\"]", v);
6738 static struct value *
6739 evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos,
6742 return (*exp->language_defn->evaluate_exp) (expect_type, exp, pos, noside);
6745 /* Evaluate the subexpression of EXP starting at *POS as for
6746 evaluate_type, updating *POS to point just past the evaluated
6749 static struct value *
6750 evaluate_subexp_type (struct expression *exp, int *pos)
6752 return (*exp->language_defn->evaluate_exp)
6753 (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
6756 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6759 static struct value *
6760 unwrap_value (struct value *val)
6762 struct type *type = check_typedef (VALUE_TYPE (val));
6763 if (ada_is_aligner_type (type))
6765 struct value *v = value_struct_elt (&val, NULL, "F",
6766 NULL, "internal structure");
6767 struct type *val_type = check_typedef (VALUE_TYPE (v));
6768 if (ada_type_name (val_type) == NULL)
6769 TYPE_NAME (val_type) = ada_type_name (type);
6771 return unwrap_value (v);
6775 struct type *raw_real_type =
6776 ada_completed_type (ada_get_base_type (type));
6778 if (type == raw_real_type)
6782 coerce_unspec_val_to_type
6783 (val, 0, ada_to_fixed_type (raw_real_type, 0,
6784 VALUE_ADDRESS (val) + VALUE_OFFSET (val),
6789 static struct value *
6790 cast_to_fixed (struct type *type, struct value *arg)
6794 if (type == VALUE_TYPE (arg))
6796 else if (ada_is_fixed_point_type (VALUE_TYPE (arg)))
6797 val = ada_float_to_fixed (type,
6798 ada_fixed_to_float (VALUE_TYPE (arg),
6799 value_as_long (arg)));
6803 value_as_double (value_cast (builtin_type_double, value_copy (arg)));
6804 val = ada_float_to_fixed (type, argd);
6807 return value_from_longest (type, val);
6810 static struct value *
6811 cast_from_fixed_to_double (struct value *arg)
6813 DOUBLEST val = ada_fixed_to_float (VALUE_TYPE (arg),
6814 value_as_long (arg));
6815 return value_from_double (builtin_type_double, val);
6818 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6819 * return the converted value. */
6820 static struct value *
6821 coerce_for_assign (struct type *type, struct value *val)
6823 struct type *type2 = VALUE_TYPE (val);
6827 CHECK_TYPEDEF (type2);
6828 CHECK_TYPEDEF (type);
6830 if (TYPE_CODE (type2) == TYPE_CODE_PTR
6831 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
6833 val = ada_value_ind (val);
6834 type2 = VALUE_TYPE (val);
6837 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
6838 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
6840 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
6841 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
6842 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
6843 error ("Incompatible types in assignment");
6844 VALUE_TYPE (val) = type;
6850 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
6851 int *pos, enum noside noside)
6854 enum ada_attribute atr;
6855 int tem, tem2, tem3;
6857 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
6860 struct value **argvec;
6864 op = exp->elts[pc].opcode;
6871 unwrap_value (evaluate_subexp_standard
6872 (expect_type, exp, pos, noside));
6876 type = exp->elts[pc + 1].type;
6877 arg1 = evaluate_subexp (type, exp, pos, noside);
6878 if (noside == EVAL_SKIP)
6880 if (type != check_typedef (VALUE_TYPE (arg1)))
6882 if (ada_is_fixed_point_type (type))
6883 arg1 = cast_to_fixed (type, arg1);
6884 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
6885 arg1 = value_cast (type, cast_from_fixed_to_double (arg1));
6886 else if (VALUE_LVAL (arg1) == lval_memory)
6888 /* This is in case of the really obscure (and undocumented,
6889 but apparently expected) case of (Foo) Bar.all, where Bar
6890 is an integer constant and Foo is a dynamic-sized type.
6891 If we don't do this, ARG1 will simply be relabeled with
6893 if (noside == EVAL_AVOID_SIDE_EFFECTS)
6894 return value_zero (to_static_fixed_type (type), not_lval);
6897 (type, 0, VALUE_ADDRESS (arg1) + VALUE_OFFSET (arg1), 0);
6900 arg1 = value_cast (type, arg1);
6904 /* FIXME: UNOP_QUAL should be defined in expression.h */
6907 type = exp->elts[pc + 1].type;
6908 return ada_evaluate_subexp (type, exp, pos, noside);
6911 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
6912 arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
6913 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
6915 if (binop_user_defined_p (op, arg1, arg2))
6916 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
6919 if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
6920 arg2 = cast_to_fixed (VALUE_TYPE (arg1), arg2);
6921 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
6923 ("Fixed-point values must be assigned to fixed-point variables");
6925 arg2 = coerce_for_assign (VALUE_TYPE (arg1), arg2);
6926 return ada_value_assign (arg1, arg2);
6930 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
6931 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
6932 if (noside == EVAL_SKIP)
6934 if (binop_user_defined_p (op, arg1, arg2))
6935 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
6938 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
6939 || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
6940 && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
6942 ("Operands of fixed-point addition must have the same type");
6943 return value_cast (VALUE_TYPE (arg1), value_add (arg1, arg2));
6947 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
6948 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
6949 if (noside == EVAL_SKIP)
6951 if (binop_user_defined_p (op, arg1, arg2))
6952 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
6955 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
6956 || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
6957 && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
6959 ("Operands of fixed-point subtraction must have the same type");
6960 return value_cast (VALUE_TYPE (arg1), value_sub (arg1, arg2));
6965 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
6966 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
6967 if (noside == EVAL_SKIP)
6969 if (binop_user_defined_p (op, arg1, arg2))
6970 return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
6972 if (noside == EVAL_AVOID_SIDE_EFFECTS
6973 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
6974 return value_zero (VALUE_TYPE (arg1), not_lval);
6977 if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
6978 arg1 = cast_from_fixed_to_double (arg1);
6979 if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
6980 arg2 = cast_from_fixed_to_double (arg2);
6981 return value_binop (arg1, arg2, op);
6985 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
6986 if (noside == EVAL_SKIP)
6988 if (unop_user_defined_p (op, arg1))
6989 return value_x_unop (arg1, op, EVAL_NORMAL);
6990 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
6991 return value_cast (VALUE_TYPE (arg1), value_neg (arg1));
6993 return value_neg (arg1);
6995 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
6996 /* case OP_UNRESOLVED_VALUE:
6997 /* Only encountered when an unresolved symbol occurs in a
6998 context other than a function call, in which case, it is
7001 if (noside == EVAL_SKIP)
7004 error ("Unexpected unresolved symbol, %s, during evaluation",
7005 ada_demangle (exp->elts[pc + 2].name));
7009 if (noside == EVAL_SKIP)
7014 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7018 (to_static_fixed_type
7019 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
7025 unwrap_value (evaluate_subexp_standard
7026 (expect_type, exp, pos, noside));
7027 return ada_to_fixed_value (VALUE_TYPE (arg1), 0,
7028 VALUE_ADDRESS (arg1) +
7029 VALUE_OFFSET (arg1), arg1);
7034 tem2 = longest_to_int (exp->elts[pc + 1].longconst);
7035 tem3 = longest_to_int (exp->elts[pc + 2].longconst);
7036 nargs = tem3 - tem2 + 1;
7037 type = expect_type ? check_typedef (expect_type) : NULL_TYPE;
7040 (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
7041 for (tem = 0; tem == 0 || tem < nargs; tem += 1)
7042 /* At least one element gets inserted for the type */
7044 /* Ensure that array expressions are coerced into pointer objects. */
7045 argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside);
7047 if (noside == EVAL_SKIP)
7049 return value_array (tem2, tem3, argvec);
7054 /* Allocate arg vector, including space for the function to be
7055 called in argvec[0] and a terminating NULL */
7056 nargs = longest_to_int (exp->elts[pc + 1].longconst);
7058 (struct value * *) alloca (sizeof (struct value *) * (nargs + 2));
7060 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7061 /* FIXME: name should be defined in expresion.h */
7062 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7063 error ("Unexpected unresolved symbol, %s, during evaluation",
7064 ada_demangle (exp->elts[pc + 5].name));
7068 error ("unexpected code path, FIXME");
7072 for (tem = 0; tem <= nargs; tem += 1)
7073 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7076 if (noside == EVAL_SKIP)
7080 if (TYPE_CODE (VALUE_TYPE (argvec[0])) == TYPE_CODE_REF)
7081 argvec[0] = value_addr (argvec[0]);
7083 if (ada_is_packed_array_type (VALUE_TYPE (argvec[0])))
7084 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
7086 type = check_typedef (VALUE_TYPE (argvec[0]));
7087 if (TYPE_CODE (type) == TYPE_CODE_PTR)
7089 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type))))
7091 case TYPE_CODE_FUNC:
7092 type = check_typedef (TYPE_TARGET_TYPE (type));
7094 case TYPE_CODE_ARRAY:
7096 case TYPE_CODE_STRUCT:
7097 if (noside != EVAL_AVOID_SIDE_EFFECTS)
7098 argvec[0] = ada_value_ind (argvec[0]);
7099 type = check_typedef (TYPE_TARGET_TYPE (type));
7102 error ("cannot subscript or call something of type `%s'",
7103 ada_type_name (VALUE_TYPE (argvec[0])));
7108 switch (TYPE_CODE (type))
7110 case TYPE_CODE_FUNC:
7111 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7112 return allocate_value (TYPE_TARGET_TYPE (type));
7113 return call_function_by_hand (argvec[0], nargs, argvec + 1);
7114 case TYPE_CODE_STRUCT:
7116 int arity = ada_array_arity (type);
7117 type = ada_array_element_type (type, nargs);
7119 error ("cannot subscript or call a record");
7121 error ("wrong number of subscripts; expecting %d", arity);
7122 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7123 return allocate_value (ada_aligned_type (type));
7125 unwrap_value (ada_value_subscript
7126 (argvec[0], nargs, argvec + 1));
7128 case TYPE_CODE_ARRAY:
7129 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7131 type = ada_array_element_type (type, nargs);
7133 error ("element type of array unknown");
7135 return allocate_value (ada_aligned_type (type));
7138 unwrap_value (ada_value_subscript
7139 (ada_coerce_to_simple_array (argvec[0]),
7140 nargs, argvec + 1));
7141 case TYPE_CODE_PTR: /* Pointer to array */
7142 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
7143 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7145 type = ada_array_element_type (type, nargs);
7147 error ("element type of array unknown");
7149 return allocate_value (ada_aligned_type (type));
7152 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
7153 nargs, argvec + 1));
7156 error ("Internal error in evaluate_subexp");
7161 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7163 = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
7165 = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
7166 if (noside == EVAL_SKIP)
7169 /* If this is a reference to an array, then dereference it */
7170 if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_REF
7171 && TYPE_TARGET_TYPE (VALUE_TYPE (array)) != NULL
7172 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array))) ==
7174 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE (array))))
7176 array = ada_coerce_ref (array);
7179 if (noside == EVAL_AVOID_SIDE_EFFECTS &&
7180 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array))))
7182 /* Try to dereference the array, in case it is an access to array */
7183 struct type *arrType = ada_type_of_array (array, 0);
7184 if (arrType != NULL)
7185 array = value_at_lazy (arrType, 0, NULL);
7187 if (ada_is_array_descriptor (VALUE_TYPE (array)))
7188 array = ada_coerce_to_simple_array (array);
7190 /* If at this point we have a pointer to an array, it means that
7191 it is a pointer to a simple (non-ada) array. We just then
7193 if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_PTR
7194 && TYPE_TARGET_TYPE (VALUE_TYPE (array)) != NULL
7195 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array))) ==
7198 array = ada_value_ind (array);
7201 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7202 /* The following will get the bounds wrong, but only in contexts
7203 where the value is not being requested (FIXME?). */
7206 return value_slice (array, lowbound, upper - lowbound + 1);
7209 /* FIXME: UNOP_MBR should be defined in expression.h */
7212 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7213 type = exp->elts[pc + 1].type;
7215 if (noside == EVAL_SKIP)
7218 switch (TYPE_CODE (type))
7221 warning ("Membership test incompletely implemented; always returns true");
7222 return value_from_longest (builtin_type_int, (LONGEST) 1);
7224 case TYPE_CODE_RANGE:
7225 arg2 = value_from_longest (builtin_type_int,
7226 (LONGEST) TYPE_LOW_BOUND (type));
7227 arg3 = value_from_longest (builtin_type_int,
7228 (LONGEST) TYPE_HIGH_BOUND (type));
7230 value_from_longest (builtin_type_int,
7231 (value_less (arg1,arg3)
7232 || value_equal (arg1,arg3))
7233 && (value_less (arg2,arg1)
7234 || value_equal (arg2,arg1)));
7237 /* FIXME: BINOP_MBR should be defined in expression.h */
7240 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7241 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7243 if (noside == EVAL_SKIP)
7246 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7247 return value_zero (builtin_type_int, not_lval);
7249 tem = longest_to_int (exp->elts[pc + 1].longconst);
7251 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7252 error ("invalid dimension number to '%s", "range");
7254 arg3 = ada_array_bound (arg2, tem, 1);
7255 arg2 = ada_array_bound (arg2, tem, 0);
7258 value_from_longest (builtin_type_int,
7259 (value_less (arg1,arg3)
7260 || value_equal (arg1,arg3))
7261 && (value_less (arg2,arg1)
7262 || value_equal (arg2,arg1)));
7264 /* FIXME: TERNOP_MBR should be defined in expression.h */
7266 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7267 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7268 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7270 if (noside == EVAL_SKIP)
7274 value_from_longest (builtin_type_int,
7275 (value_less (arg1,arg3)
7276 || value_equal (arg1,arg3))
7277 && (value_less (arg2,arg1)
7278 || value_equal (arg2,arg1)));
7280 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7281 /* case OP_ATTRIBUTE:
7283 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7287 error ("unexpected attribute encountered");
7293 struct type* type_arg;
7294 if (exp->elts[*pos].opcode == OP_TYPE)
7296 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7298 type_arg = exp->elts[pc + 5].type;
7302 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7306 if (exp->elts[*pos].opcode != OP_LONG)
7307 error ("illegal operand to '%s", ada_attribute_name (atr));
7308 tem = longest_to_int (exp->elts[*pos+2].longconst);
7311 if (noside == EVAL_SKIP)
7314 if (type_arg == NULL)
7316 arg1 = ada_coerce_ref (arg1);
7318 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7319 arg1 = ada_coerce_to_simple_array (arg1);
7321 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7322 error ("invalid dimension number to '%s",
7323 ada_attribute_name (atr));
7325 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7327 type = ada_index_type (VALUE_TYPE (arg1), tem);
7329 error ("attempt to take bound of something that is not an array");
7330 return allocate_value (type);
7336 error ("unexpected attribute encountered");
7338 return ada_array_bound (arg1, tem, 0);
7340 return ada_array_bound (arg1, tem, 1);
7342 return ada_array_length (arg1, tem);
7345 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7346 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7348 struct type* range_type;
7349 char* name = ada_type_name (type_arg);
7352 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7353 range_type = type_arg;
7355 error ("unimplemented type attribute");
7359 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7363 error ("unexpected attribute encountered");
7365 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7366 TYPE_LOW_BOUND (range_type));
7368 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7369 TYPE_HIGH_BOUND (range_type));
7372 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7377 error ("unexpected attribute encountered");
7379 return value_from_longest
7380 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7382 return value_from_longest
7384 TYPE_FIELD_BITPOS (type_arg,
7385 TYPE_NFIELDS (type_arg) - 1));
7388 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7389 error ("unimplemented type attribute");
7394 if (ada_is_packed_array_type (type_arg))
7395 type_arg = decode_packed_array_type (type_arg);
7397 if (tem < 1 || tem > ada_array_arity (type_arg))
7398 error ("invalid dimension number to '%s",
7399 ada_attribute_name (atr));
7401 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7403 type = ada_index_type (type_arg, tem);
7405 error ("attempt to take bound of something that is not an array");
7406 return allocate_value (type);
7412 error ("unexpected attribute encountered");
7414 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7415 return value_from_longest (type, low);
7417 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7418 return value_from_longest (type, high);
7420 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7421 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7422 return value_from_longest (type, high-low+1);
7428 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7429 if (noside == EVAL_SKIP)
7432 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7434 value_zero (ada_tag_type (arg1), not_lval);
7436 return ada_value_tag (arg1);
7440 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7441 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7442 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7443 if (noside == EVAL_SKIP)
7445 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7446 return value_zero (VALUE_TYPE (arg1), not_lval);
7448 return value_binop (arg1, arg2,
7449 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7453 struct type* type_arg = exp->elts[pc + 5].type;
7454 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7457 if (noside == EVAL_SKIP)
7460 if (! ada_is_modular_type (type_arg))
7461 error ("'modulus must be applied to modular type");
7463 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7464 ada_modulus (type_arg));
7469 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7470 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7471 if (noside == EVAL_SKIP)
7473 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7474 return value_zero (builtin_type_ada_int, not_lval);
7476 return value_pos_atr (arg1);
7479 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7480 if (noside == EVAL_SKIP)
7482 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7483 return value_zero (builtin_type_ada_int, not_lval);
7485 return value_from_longest (builtin_type_ada_int,
7487 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7490 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7491 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7492 type = exp->elts[pc + 5].type;
7493 if (noside == EVAL_SKIP)
7495 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7496 return value_zero (type, not_lval);
7498 return value_val_atr (type, arg1);
7501 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7502 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7503 if (noside == EVAL_SKIP)
7505 if (binop_user_defined_p (op, arg1, arg2))
7506 return unwrap_value (value_x_binop (arg1, arg2, op, OP_NULL,
7508 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7509 return value_zero (VALUE_TYPE (arg1), not_lval);
7511 return value_binop (arg1, arg2, op);
7514 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7515 if (noside == EVAL_SKIP)
7517 if (unop_user_defined_p (op, arg1))
7518 return unwrap_value (value_x_unop (arg1, op, EVAL_NORMAL));
7523 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7524 if (noside == EVAL_SKIP)
7526 if (value_less (arg1, value_zero (VALUE_TYPE (arg1), not_lval)))
7527 return value_neg (arg1);
7532 if (expect_type && TYPE_CODE (expect_type) == TYPE_CODE_PTR)
7533 expect_type = TYPE_TARGET_TYPE (check_typedef (expect_type));
7534 arg1 = evaluate_subexp (expect_type, exp, pos, noside);
7535 if (noside == EVAL_SKIP)
7537 type = check_typedef (VALUE_TYPE (arg1));
7538 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7540 if (ada_is_array_descriptor (type))
7541 /* GDB allows dereferencing GNAT array descriptors. */
7543 struct type *arrType = ada_type_of_array (arg1, 0);
7544 if (arrType == NULL)
7545 error ("Attempt to dereference null array pointer.");
7546 return value_at_lazy (arrType, 0, NULL);
7548 else if (TYPE_CODE (type) == TYPE_CODE_PTR
7549 || TYPE_CODE (type) == TYPE_CODE_REF
7550 /* In C you can dereference an array to get the 1st elt. */
7551 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
7554 (to_static_fixed_type
7555 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type)))),
7557 else if (TYPE_CODE (type) == TYPE_CODE_INT)
7558 /* GDB allows dereferencing an int. */
7559 return value_zero (builtin_type_int, lval_memory);
7561 error ("Attempt to take contents of a non-pointer value.");
7563 arg1 = ada_coerce_ref (arg1);
7564 type = check_typedef (VALUE_TYPE (arg1));
7566 if (ada_is_array_descriptor (type))
7567 /* GDB allows dereferencing GNAT array descriptors. */
7568 return ada_coerce_to_simple_array (arg1);
7570 return ada_value_ind (arg1);
7572 case STRUCTOP_STRUCT:
7573 tem = longest_to_int (exp->elts[pc + 1].longconst);
7574 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
7575 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7576 if (noside == EVAL_SKIP)
7578 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7579 return value_zero (ada_aligned_type
7580 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1),
7586 return unwrap_value (ada_value_struct_elt (arg1,
7587 &exp->elts[pc + 2].string,
7590 /* The value is not supposed to be used. This is here to make it
7591 easier to accommodate expressions that contain types. */
7593 if (noside == EVAL_SKIP)
7595 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7596 return allocate_value (builtin_type_void);
7598 error ("Attempt to use a type name as an expression");
7601 tem = longest_to_int (exp->elts[pc + 1].longconst);
7602 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
7603 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7604 if (noside == EVAL_SKIP)
7606 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7607 return value_zero (ada_aligned_type
7608 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1),
7614 return unwrap_value (ada_value_struct_elt (arg1,
7615 &exp->elts[pc + 2].string,
7620 return value_from_longest (builtin_type_long, (LONGEST) 1);
7626 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7627 type name that encodes the 'small and 'delta information.
7628 Otherwise, return NULL. */
7631 fixed_type_info (struct type *type)
7633 const char *name = ada_type_name (type);
7634 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
7636 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
7638 const char *tail = strstr (name, "___XF_");
7644 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
7645 return fixed_type_info (TYPE_TARGET_TYPE (type));
7650 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7653 ada_is_fixed_point_type (struct type *type)
7655 return fixed_type_info (type) != NULL;
7658 /* Assuming that TYPE is the representation of an Ada fixed-point
7659 type, return its delta, or -1 if the type is malformed and the
7660 delta cannot be determined. */
7663 ada_delta (struct type *type)
7665 const char *encoding = fixed_type_info (type);
7668 if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
7671 return (DOUBLEST) num / (DOUBLEST) den;
7674 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7675 factor ('SMALL value) associated with the type. */
7678 scaling_factor (struct type *type)
7680 const char *encoding = fixed_type_info (type);
7681 unsigned long num0, den0, num1, den1;
7684 n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);
7689 return (DOUBLEST) num1 / (DOUBLEST) den1;
7691 return (DOUBLEST) num0 / (DOUBLEST) den0;
7695 /* Assuming that X is the representation of a value of fixed-point
7696 type TYPE, return its floating-point equivalent. */
7699 ada_fixed_to_float (struct type *type, LONGEST x)
7701 return (DOUBLEST) x *scaling_factor (type);
7704 /* The representation of a fixed-point value of type TYPE
7705 corresponding to the value X. */
7708 ada_float_to_fixed (struct type *type, DOUBLEST x)
7710 return (LONGEST) (x / scaling_factor (type) + 0.5);
7714 /* VAX floating formats */
7716 /* Non-zero iff TYPE represents one of the special VAX floating-point
7719 ada_is_vax_floating_type (struct type *type)
7722 (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
7725 && (TYPE_CODE (type) == TYPE_CODE_INT
7726 || TYPE_CODE (type) == TYPE_CODE_RANGE)
7727 && STREQN (ada_type_name (type) + name_len - 6, "___XF", 5);
7730 /* The type of special VAX floating-point type this is, assuming
7731 ada_is_vax_floating_point */
7733 ada_vax_float_type_suffix (struct type *type)
7735 return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
7738 /* A value representing the special debugging function that outputs
7739 VAX floating-point values of the type represented by TYPE. Assumes
7740 ada_is_vax_floating_type (TYPE). */
7742 ada_vax_float_print_function (struct type *type)
7744 switch (ada_vax_float_type_suffix (type))
7747 return get_var_value ("DEBUG_STRING_F", 0);
7749 return get_var_value ("DEBUG_STRING_D", 0);
7751 return get_var_value ("DEBUG_STRING_G", 0);
7753 error ("invalid VAX floating-point type");
7760 /* Scan STR beginning at position K for a discriminant name, and
7761 return the value of that discriminant field of DVAL in *PX. If
7762 PNEW_K is not null, put the position of the character beyond the
7763 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7764 not alter *PX and *PNEW_K if unsuccessful. */
7767 scan_discrim_bound (char *, int k, struct value *dval, LONGEST * px,
7770 static char *bound_buffer = NULL;
7771 static size_t bound_buffer_len = 0;
7774 struct value *bound_val;
7776 if (dval == NULL || str == NULL || str[k] == '\0')
7779 pend = strstr (str + k, "__");
7783 k += strlen (bound);
7787 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
7788 bound = bound_buffer;
7789 strncpy (bound_buffer, str + k, pend - (str + k));
7790 bound[pend - (str + k)] = '\0';
7794 bound_val = ada_search_struct_field (bound, dval, 0, VALUE_TYPE (dval));
7795 if (bound_val == NULL)
7798 *px = value_as_long (bound_val);
7804 /* Value of variable named NAME in the current environment. If
7805 no such variable found, then if ERR_MSG is null, returns 0, and
7806 otherwise causes an error with message ERR_MSG. */
7807 static struct value *
7808 get_var_value (char *name, char *err_msg)
7810 struct symbol **syms;
7811 struct block **blocks;
7815 ada_lookup_symbol_list (name, get_selected_block (NULL), VAR_NAMESPACE,
7820 if (err_msg == NULL)
7823 error ("%s", err_msg);
7826 return value_of_variable (syms[0], blocks[0]);
7829 /* Value of integer variable named NAME in the current environment. If
7830 no such variable found, then if ERR_MSG is null, returns 0, and sets
7831 *FLAG to 0. If successful, sets *FLAG to 1. */
7833 get_int_var_value (char *name, char *err_msg, int *flag)
7835 struct value *var_val = get_var_value (name, err_msg);
7847 return value_as_long (var_val);
7852 /* Return a range type whose base type is that of the range type named
7853 NAME in the current environment, and whose bounds are calculated
7854 from NAME according to the GNAT range encoding conventions.
7855 Extract discriminant values, if needed, from DVAL. If a new type
7856 must be created, allocate in OBJFILE's space. The bounds
7857 information, in general, is encoded in NAME, the base type given in
7858 the named range type. */
7860 static struct type *
7861 to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
7863 struct type *raw_type = ada_find_any_type (name);
7864 struct type *base_type;
7868 if (raw_type == NULL)
7869 base_type = builtin_type_int;
7870 else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
7871 base_type = TYPE_TARGET_TYPE (raw_type);
7873 base_type = raw_type;
7875 subtype_info = strstr (name, "___XD");
7876 if (subtype_info == NULL)
7880 static char *name_buf = NULL;
7881 static size_t name_len = 0;
7882 int prefix_len = subtype_info - name;
7888 GROW_VECT (name_buf, name_len, prefix_len + 5);
7889 strncpy (name_buf, name, prefix_len);
7890 name_buf[prefix_len] = '\0';
7893 bounds_str = strchr (subtype_info, '_');
7896 if (*subtype_info == 'L')
7898 if (!ada_scan_number (bounds_str, n, &L, &n)
7899 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
7901 if (bounds_str[n] == '_')
7903 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
7909 strcpy (name_buf + prefix_len, "___L");
7910 L = get_int_var_value (name_buf, "Index bound unknown.", NULL);
7913 if (*subtype_info == 'U')
7915 if (!ada_scan_number (bounds_str, n, &U, &n)
7916 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
7921 strcpy (name_buf + prefix_len, "___U");
7922 U = get_int_var_value (name_buf, "Index bound unknown.", NULL);
7925 if (objfile == NULL)
7926 objfile = TYPE_OBJFILE (base_type);
7927 type = create_range_type (alloc_type (objfile), base_type, L, U);
7928 TYPE_NAME (type) = name;
7933 /* True iff NAME is the name of a range type. */
7935 ada_is_range_type_name (const char *name)
7937 return (name != NULL && strstr (name, "___XD"));
7943 /* True iff TYPE is an Ada modular type. */
7945 ada_is_modular_type (struct type *type)
7947 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
7949 struct type *subranged_type; /* = base_type (type); */
7951 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
7952 && TYPE_CODE (subranged_type) != TYPE_CODE_ENUM
7953 && TYPE_UNSIGNED (subranged_type));
7956 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
7958 ada_modulus (struct type * type)
7960 return TYPE_HIGH_BOUND (type) + 1;
7967 /* Table mapping opcodes into strings for printing operators
7968 and precedences of the operators. */
7970 static const struct op_print ada_op_print_tab[] = {
7971 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
7972 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
7973 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
7974 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
7975 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
7976 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
7977 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
7978 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
7979 {"<=", BINOP_LEQ, PREC_ORDER, 0},
7980 {">=", BINOP_GEQ, PREC_ORDER, 0},
7981 {">", BINOP_GTR, PREC_ORDER, 0},
7982 {"<", BINOP_LESS, PREC_ORDER, 0},
7983 {">>", BINOP_RSH, PREC_SHIFT, 0},
7984 {"<<", BINOP_LSH, PREC_SHIFT, 0},
7985 {"+", BINOP_ADD, PREC_ADD, 0},
7986 {"-", BINOP_SUB, PREC_ADD, 0},
7987 {"&", BINOP_CONCAT, PREC_ADD, 0},
7988 {"*", BINOP_MUL, PREC_MUL, 0},
7989 {"/", BINOP_DIV, PREC_MUL, 0},
7990 {"rem", BINOP_REM, PREC_MUL, 0},
7991 {"mod", BINOP_MOD, PREC_MUL, 0},
7992 {"**", BINOP_EXP, PREC_REPEAT, 0},
7993 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
7994 {"-", UNOP_NEG, PREC_PREFIX, 0},
7995 {"+", UNOP_PLUS, PREC_PREFIX, 0},
7996 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
7997 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
7998 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
7999 {".all", UNOP_IND, PREC_SUFFIX, 1}, /* FIXME: postfix .ALL */
8000 {"'access", UNOP_ADDR, PREC_SUFFIX, 1}, /* FIXME: postfix 'ACCESS */
8004 /* Assorted Types and Interfaces */
8006 struct type *builtin_type_ada_int;
8007 struct type *builtin_type_ada_short;
8008 struct type *builtin_type_ada_long;
8009 struct type *builtin_type_ada_long_long;
8010 struct type *builtin_type_ada_char;
8011 struct type *builtin_type_ada_float;
8012 struct type *builtin_type_ada_double;
8013 struct type *builtin_type_ada_long_double;
8014 struct type *builtin_type_ada_natural;
8015 struct type *builtin_type_ada_positive;
8016 struct type *builtin_type_ada_system_address;
8018 struct type **const (ada_builtin_types[]) =
8021 &builtin_type_ada_int,
8022 &builtin_type_ada_long,
8023 &builtin_type_ada_short,
8024 &builtin_type_ada_char,
8025 &builtin_type_ada_float,
8026 &builtin_type_ada_double,
8027 &builtin_type_ada_long_long,
8028 &builtin_type_ada_long_double,
8029 &builtin_type_ada_natural, &builtin_type_ada_positive,
8030 /* The following types are carried over from C for convenience. */
8033 &builtin_type_short,
8035 &builtin_type_float,
8036 &builtin_type_double,
8037 &builtin_type_long_long,
8039 &builtin_type_signed_char,
8040 &builtin_type_unsigned_char,
8041 &builtin_type_unsigned_short,
8042 &builtin_type_unsigned_int,
8043 &builtin_type_unsigned_long,
8044 &builtin_type_unsigned_long_long,
8045 &builtin_type_long_double,
8046 &builtin_type_complex, &builtin_type_double_complex, 0};
8048 /* Not really used, but needed in the ada_language_defn. */
8050 emit_char (int c, struct ui_file *stream, int quoter)
8052 ada_emit_char (c, stream, quoter, 1);
8055 const struct language_defn ada_language_defn = {
8056 "ada", /* Language name */
8059 /* FIXME: language_ada should be defined in defs.h */
8063 case_sensitive_on, /* Yes, Ada is case-insensitive, but
8064 * that's not quite what this means. */
8067 ada_evaluate_subexp,
8068 ada_printchar, /* Print a character constant */
8069 ada_printstr, /* Function to print string constant */
8070 emit_char, /* Function to print single char (not used) */
8071 ada_create_fundamental_type, /* Create fundamental type in this language */
8072 ada_print_type, /* Print a type using appropriate syntax */
8073 ada_val_print, /* Print a value using appropriate syntax */
8074 ada_value_print, /* Print a top-level value */
8075 {"", "", "", ""}, /* Binary format info */
8077 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8078 {"%ld", "", "d", ""}, /* Decimal format info */
8079 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8081 /* Copied from c-lang.c. */
8082 {"0%lo", "0", "o", ""}, /* Octal format info */
8083 {"%ld", "", "d", ""}, /* Decimal format info */
8084 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8086 ada_op_print_tab, /* expression operators for printing */
8087 1, /* c-style arrays (FIXME?) */
8088 0, /* String lower bound (FIXME?) */
8089 &builtin_type_ada_char,
8094 _initialize_ada_language (void)
8096 builtin_type_ada_int =
8097 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8098 0, "integer", (struct objfile *) NULL);
8099 builtin_type_ada_long =
8100 init_type (TYPE_CODE_INT, TARGET_LONG_BIT / TARGET_CHAR_BIT,
8101 0, "long_integer", (struct objfile *) NULL);
8102 builtin_type_ada_short =
8103 init_type (TYPE_CODE_INT, TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8104 0, "short_integer", (struct objfile *) NULL);
8105 builtin_type_ada_char =
8106 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8107 0, "character", (struct objfile *) NULL);
8108 builtin_type_ada_float =
8109 init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
8110 0, "float", (struct objfile *) NULL);
8111 builtin_type_ada_double =
8112 init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
8113 0, "long_float", (struct objfile *) NULL);
8114 builtin_type_ada_long_long =
8115 init_type (TYPE_CODE_INT, TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8116 0, "long_long_integer", (struct objfile *) NULL);
8117 builtin_type_ada_long_double =
8118 init_type (TYPE_CODE_FLT, TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
8119 0, "long_long_float", (struct objfile *) NULL);
8120 builtin_type_ada_natural =
8121 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8122 0, "natural", (struct objfile *) NULL);
8123 builtin_type_ada_positive =
8124 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
8125 0, "positive", (struct objfile *) NULL);
8128 builtin_type_ada_system_address =
8129 lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
8130 (struct objfile *) NULL));
8131 TYPE_NAME (builtin_type_ada_system_address) = "system__address";
8133 add_language (&ada_language_defn);
8136 (add_set_cmd ("varsize-limit", class_support, var_uinteger,
8137 (char *) &varsize_limit,
8138 "Set maximum bytes in dynamic-sized object.",
8139 &setlist), &showlist);
8140 varsize_limit = 65536;
8142 add_com ("begin", class_breakpoint, begin_command,
8143 "Start the debugged program, stopping at the beginning of the\n\
8144 main program. You may specify command-line arguments to give it, as for\n\
8145 the \"run\" command (q.v.).");
8149 /* Create a fundamental Ada type using default reasonable for the current
8152 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8153 define fundamental types such as "int" or "double". Others (stabs or
8154 DWARF version 2, etc) do define fundamental types. For the formats which
8155 don't provide fundamental types, gdb can create such types using this
8158 FIXME: Some compilers distinguish explicitly signed integral types
8159 (signed short, signed int, signed long) from "regular" integral types
8160 (short, int, long) in the debugging information. There is some dis-
8161 agreement as to how useful this feature is. In particular, gcc does
8162 not support this. Also, only some debugging formats allow the
8163 distinction to be passed on to a debugger. For now, we always just
8164 use "short", "int", or "long" as the type name, for both the implicit
8165 and explicitly signed types. This also makes life easier for the
8166 gdb test suite since we don't have to account for the differences
8167 in output depending upon what the compiler and debugging format
8168 support. We will probably have to re-examine the issue when gdb
8169 starts taking it's fundamental type information directly from the
8170 debugging information supplied by the compiler. fnf@cygnus.com */
8172 static struct type *
8173 ada_create_fundamental_type (struct objfile *objfile, int typeid)
8175 struct type *type = NULL;
8180 /* FIXME: For now, if we are asked to produce a type not in this
8181 language, create the equivalent of a C integer type with the
8182 name "<?type?>". When all the dust settles from the type
8183 reconstruction work, this should probably become an error. */
8184 type = init_type (TYPE_CODE_INT,
8185 TARGET_INT_BIT / TARGET_CHAR_BIT,
8186 0, "<?type?>", objfile);
8187 warning ("internal error: no Ada fundamental type %d", typeid);
8190 type = init_type (TYPE_CODE_VOID,
8191 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8192 0, "void", objfile);
8195 type = init_type (TYPE_CODE_INT,
8196 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8197 0, "character", objfile);
8199 case FT_SIGNED_CHAR:
8200 type = init_type (TYPE_CODE_INT,
8201 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8202 0, "signed char", objfile);
8204 case FT_UNSIGNED_CHAR:
8205 type = init_type (TYPE_CODE_INT,
8206 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
8207 TYPE_FLAG_UNSIGNED, "unsigned char", objfile);
8210 type = init_type (TYPE_CODE_INT,
8211 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8212 0, "short_integer", objfile);
8214 case FT_SIGNED_SHORT:
8215 type = init_type (TYPE_CODE_INT,
8216 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8217 0, "short_integer", objfile);
8219 case FT_UNSIGNED_SHORT:
8220 type = init_type (TYPE_CODE_INT,
8221 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
8222 TYPE_FLAG_UNSIGNED, "unsigned short", objfile);
8225 type = init_type (TYPE_CODE_INT,
8226 TARGET_INT_BIT / TARGET_CHAR_BIT,
8227 0, "integer", objfile);
8229 case FT_SIGNED_INTEGER:
8230 type = init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT, 0, "integer", objfile); /* FIXME -fnf */
8232 case FT_UNSIGNED_INTEGER:
8233 type = init_type (TYPE_CODE_INT,
8234 TARGET_INT_BIT / TARGET_CHAR_BIT,
8235 TYPE_FLAG_UNSIGNED, "unsigned int", objfile);
8238 type = init_type (TYPE_CODE_INT,
8239 TARGET_LONG_BIT / TARGET_CHAR_BIT,
8240 0, "long_integer", objfile);
8242 case FT_SIGNED_LONG:
8243 type = init_type (TYPE_CODE_INT,
8244 TARGET_LONG_BIT / TARGET_CHAR_BIT,
8245 0, "long_integer", objfile);
8247 case FT_UNSIGNED_LONG:
8248 type = init_type (TYPE_CODE_INT,
8249 TARGET_LONG_BIT / TARGET_CHAR_BIT,
8250 TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
8253 type = init_type (TYPE_CODE_INT,
8254 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8255 0, "long_long_integer", objfile);
8257 case FT_SIGNED_LONG_LONG:
8258 type = init_type (TYPE_CODE_INT,
8259 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8260 0, "long_long_integer", objfile);
8262 case FT_UNSIGNED_LONG_LONG:
8263 type = init_type (TYPE_CODE_INT,
8264 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
8265 TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
8268 type = init_type (TYPE_CODE_FLT,
8269 TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
8270 0, "float", objfile);
8272 case FT_DBL_PREC_FLOAT:
8273 type = init_type (TYPE_CODE_FLT,
8274 TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
8275 0, "long_float", objfile);
8277 case FT_EXT_PREC_FLOAT:
8278 type = init_type (TYPE_CODE_FLT,
8279 TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
8280 0, "long_long_float", objfile);
8287 ada_dump_symtab (struct symtab *s)
8290 fprintf (stderr, "New symtab: [\n");
8291 fprintf (stderr, " Name: %s/%s;\n",
8292 s->dirname ? s->dirname : "?", s->filename ? s->filename : "?");
8293 fprintf (stderr, " Format: %s;\n", s->debugformat);
8294 if (s->linetable != NULL)
8296 fprintf (stderr, " Line table (section %d):\n", s->block_line_section);
8297 for (i = 0; i < s->linetable->nitems; i += 1)
8299 struct linetable_entry *e = s->linetable->item + i;
8300 fprintf (stderr, " %4ld: %8lx\n", (long) e->line, (long) e->pc);
8303 fprintf (stderr, "]\n");