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"
44 struct cleanup
*unresolved_names
;
46 void extract_string (CORE_ADDR addr
, char *buf
);
48 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
50 static void modify_general_field (char *, LONGEST
, int, int);
52 static struct type
*desc_base_type (struct type
*);
54 static struct type
*desc_bounds_type (struct type
*);
56 static struct value
*desc_bounds (struct value
*);
58 static int fat_pntr_bounds_bitpos (struct type
*);
60 static int fat_pntr_bounds_bitsize (struct type
*);
62 static struct type
*desc_data_type (struct type
*);
64 static struct value
*desc_data (struct value
*);
66 static int fat_pntr_data_bitpos (struct type
*);
68 static int fat_pntr_data_bitsize (struct type
*);
70 static struct value
*desc_one_bound (struct value
*, int, int);
72 static int desc_bound_bitpos (struct type
*, int, int);
74 static int desc_bound_bitsize (struct type
*, int, int);
76 static struct type
*desc_index_type (struct type
*, int);
78 static int desc_arity (struct type
*);
80 static int ada_type_match (struct type
*, struct type
*, int);
82 static int ada_args_match (struct symbol
*, struct value
**, int);
84 static struct value
*place_on_stack (struct value
*, CORE_ADDR
*);
86 static struct value
*convert_actual (struct value
*, struct type
*,
89 static struct value
*make_array_descriptor (struct type
*, struct value
*,
92 static void ada_add_block_symbols (struct block
*, const char *,
93 domain_enum
, struct objfile
*, int);
95 static void fill_in_ada_prototype (struct symbol
*);
97 static int is_nonfunction (struct symbol
**, int);
99 static void add_defn_to_vec (struct symbol
*, struct block
*);
101 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
102 *, const char *, int,
105 static struct symtab
*symtab_for_sym (struct symbol
*);
107 static struct value
*ada_resolve_subexp (struct expression
**, int *, int,
110 static void replace_operator_with_call (struct expression
**, int, int, int,
111 struct symbol
*, struct block
*);
113 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
115 static const char *ada_op_name (enum exp_opcode
);
117 static int numeric_type_p (struct type
*);
119 static int integer_type_p (struct type
*);
121 static int scalar_type_p (struct type
*);
123 static int discrete_type_p (struct type
*);
125 static char *extended_canonical_line_spec (struct symtab_and_line
,
128 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
131 static struct value
*evaluate_subexp_type (struct expression
*, int *);
133 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
135 static int is_dynamic_field (struct type
*, int);
137 static struct type
*to_fixed_variant_branch_type (struct type
*, char *,
138 CORE_ADDR
, struct value
*);
140 static struct type
*to_fixed_range_type (char *, struct value
*,
143 static struct type
*to_static_fixed_type (struct type
*);
145 static struct value
*unwrap_value (struct value
*);
147 static struct type
*packed_array_type (struct type
*, long *);
149 static struct type
*decode_packed_array_type (struct type
*);
151 static struct value
*decode_packed_array (struct value
*);
153 static struct value
*value_subscript_packed (struct value
*, int,
156 static struct value
*coerce_unspec_val_to_type (struct value
*, long,
159 static struct value
*get_var_value (char *, char *);
161 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
163 static int equiv_types (struct type
*, struct type
*);
165 static int is_name_suffix (const char *);
167 static int wild_match (const char *, int, const char *);
169 static struct symtabs_and_lines
find_sal_from_funcs_and_line (const char *,
174 static int find_line_in_linetable (struct linetable
*, int, struct symbol
**,
177 static int find_next_line_in_linetable (struct linetable
*, int, int, int);
179 static struct symtabs_and_lines
all_sals_for_line (const char *, int,
182 static void read_all_symtabs (const char *);
184 static int is_plausible_func_for_line (struct symbol
*, int);
186 static struct value
*ada_coerce_ref (struct value
*);
188 static struct value
*value_pos_atr (struct value
*);
190 static struct value
*value_val_atr (struct type
*, struct value
*);
192 static struct symbol
*standard_lookup (const char *, domain_enum
);
194 extern void markTimeStart (int index
);
195 extern void markTimeStop (int index
);
199 /* Maximum-sized dynamic type. */
200 static unsigned int varsize_limit
;
202 static const char *ada_completer_word_break_characters
=
203 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
205 /* The name of the symbol to use to get the name of the main subprogram */
206 #define ADA_MAIN_PROGRAM_SYMBOL_NAME "__gnat_ada_main_program_name"
212 * read the string located at ADDR from the inferior and store the
216 extract_string (CORE_ADDR addr
, char *buf
)
220 /* Loop, reading one byte at a time, until we reach the '\000'
221 end-of-string marker */
224 target_read_memory (addr
+ char_index
* sizeof (char),
225 buf
+ char_index
* sizeof (char), sizeof (char));
228 while (buf
[char_index
- 1] != '\000');
231 /* Assuming *OLD_VECT points to an array of *SIZE objects of size
232 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
233 updating *OLD_VECT and *SIZE as necessary. */
236 grow_vect (void **old_vect
, size_t * size
, size_t min_size
, int element_size
)
238 if (*size
< min_size
)
241 if (*size
< min_size
)
243 *old_vect
= xrealloc (*old_vect
, *size
* element_size
);
247 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
248 suffix of FIELD_NAME beginning "___" */
251 field_name_match (const char *field_name
, const char *target
)
253 int len
= strlen (target
);
255 STREQN (field_name
, target
, len
)
256 && (field_name
[len
] == '\0'
257 || (STREQN (field_name
+ len
, "___", 3)
258 && !STREQ (field_name
+ strlen (field_name
) - 6, "___XVN")));
262 /* The length of the prefix of NAME prior to any "___" suffix. */
265 ada_name_prefix_len (const char *name
)
271 const char *p
= strstr (name
, "___");
273 return strlen (name
);
279 /* SUFFIX is a suffix of STR. False if STR is null. */
281 is_suffix (const char *str
, const char *suffix
)
287 len2
= strlen (suffix
);
288 return (len1
>= len2
&& STREQ (str
+ len1
- len2
, suffix
));
291 /* Create a value of type TYPE whose contents come from VALADDR, if it
292 * is non-null, and whose memory address (in the inferior) is
295 value_from_contents_and_address (struct type
*type
, char *valaddr
,
298 struct value
*v
= allocate_value (type
);
302 memcpy (VALUE_CONTENTS_RAW (v
), valaddr
, TYPE_LENGTH (type
));
303 VALUE_ADDRESS (v
) = address
;
305 VALUE_LVAL (v
) = lval_memory
;
309 /* The contents of value VAL, beginning at offset OFFSET, treated as a
310 value of type TYPE. The result is an lval in memory if VAL is. */
312 static struct value
*
313 coerce_unspec_val_to_type (struct value
*val
, long offset
, struct type
*type
)
315 CHECK_TYPEDEF (type
);
316 if (VALUE_LVAL (val
) == lval_memory
)
317 return value_at_lazy (type
,
318 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
) + offset
,
322 struct value
*result
= allocate_value (type
);
323 VALUE_LVAL (result
) = not_lval
;
324 if (VALUE_ADDRESS (val
) == 0)
325 memcpy (VALUE_CONTENTS_RAW (result
), VALUE_CONTENTS (val
) + offset
,
326 TYPE_LENGTH (type
) > TYPE_LENGTH (VALUE_TYPE (val
))
327 ? TYPE_LENGTH (VALUE_TYPE (val
)) : TYPE_LENGTH (type
));
330 VALUE_ADDRESS (result
) =
331 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
) + offset
;
332 VALUE_LAZY (result
) = 1;
339 cond_offset_host (char *valaddr
, long offset
)
344 return valaddr
+ offset
;
348 cond_offset_target (CORE_ADDR address
, long offset
)
353 return address
+ offset
;
356 /* Perform execute_command on the result of concatenating all
357 arguments up to NULL. */
359 do_command (const char *arg
, ...)
370 for (; s
!= NULL
; s
= va_arg (ap
, const char *))
374 cmd1
= alloca (len
+ 1);
380 execute_command (cmd
, 0);
384 /* Language Selection */
386 /* If the main program is in Ada, return language_ada, otherwise return LANG
387 (the main program is in Ada iif the adainit symbol is found).
389 MAIN_PST is not used. */
392 ada_update_initial_language (enum language lang
,
393 struct partial_symtab
*main_pst
)
395 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
396 (struct objfile
*) NULL
) != NULL
)
397 /* return language_ada; */
398 /* FIXME: language_ada should be defined in defs.h */
399 return language_unknown
;
407 /* Table of Ada operators and their GNAT-mangled names. Last entry is pair
410 const struct ada_opname_map ada_opname_table
[] = {
411 {"Oadd", "\"+\"", BINOP_ADD
},
412 {"Osubtract", "\"-\"", BINOP_SUB
},
413 {"Omultiply", "\"*\"", BINOP_MUL
},
414 {"Odivide", "\"/\"", BINOP_DIV
},
415 {"Omod", "\"mod\"", BINOP_MOD
},
416 {"Orem", "\"rem\"", BINOP_REM
},
417 {"Oexpon", "\"**\"", BINOP_EXP
},
418 {"Olt", "\"<\"", BINOP_LESS
},
419 {"Ole", "\"<=\"", BINOP_LEQ
},
420 {"Ogt", "\">\"", BINOP_GTR
},
421 {"Oge", "\">=\"", BINOP_GEQ
},
422 {"Oeq", "\"=\"", BINOP_EQUAL
},
423 {"One", "\"/=\"", BINOP_NOTEQUAL
},
424 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
425 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
426 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
427 {"Oconcat", "\"&\"", BINOP_CONCAT
},
428 {"Oabs", "\"abs\"", UNOP_ABS
},
429 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
430 {"Oadd", "\"+\"", UNOP_PLUS
},
431 {"Osubtract", "\"-\"", UNOP_NEG
},
435 /* True if STR should be suppressed in info listings. */
437 is_suppressed_name (const char *str
)
439 if (STREQN (str
, "_ada_", 5))
441 if (str
[0] == '_' || str
[0] == '\000')
446 const char *suffix
= strstr (str
, "___");
447 if (suffix
!= NULL
&& suffix
[3] != 'X')
450 suffix
= str
+ strlen (str
);
451 for (p
= suffix
- 1; p
!= str
; p
-= 1)
455 if (p
[0] == 'X' && p
[-1] != '_')
459 for (i
= 0; ada_opname_table
[i
].mangled
!= NULL
; i
+= 1)
460 if (STREQN (ada_opname_table
[i
].mangled
, p
,
461 strlen (ada_opname_table
[i
].mangled
)))
470 /* The "mangled" form of DEMANGLED, according to GNAT conventions.
471 * The result is valid until the next call to ada_mangle. */
473 ada_mangle (const char *demangled
)
475 static char *mangling_buffer
= NULL
;
476 static size_t mangling_buffer_size
= 0;
480 if (demangled
== NULL
)
483 GROW_VECT (mangling_buffer
, mangling_buffer_size
,
484 2 * strlen (demangled
) + 10);
487 for (p
= demangled
; *p
!= '\0'; p
+= 1)
491 mangling_buffer
[k
] = mangling_buffer
[k
+ 1] = '_';
496 const struct ada_opname_map
*mapping
;
498 for (mapping
= ada_opname_table
;
499 mapping
->mangled
!= NULL
&&
500 !STREQN (mapping
->demangled
, p
, strlen (mapping
->demangled
));
503 if (mapping
->mangled
== NULL
)
504 error ("invalid Ada operator name: %s", p
);
505 strcpy (mangling_buffer
+ k
, mapping
->mangled
);
506 k
+= strlen (mapping
->mangled
);
511 mangling_buffer
[k
] = *p
;
516 mangling_buffer
[k
] = '\0';
517 return mangling_buffer
;
520 /* Return NAME folded to lower case, or, if surrounded by single
521 * quotes, unfolded, but with the quotes stripped away. Result good
524 ada_fold_name (const char *name
)
526 static char *fold_buffer
= NULL
;
527 static size_t fold_buffer_size
= 0;
529 int len
= strlen (name
);
530 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
534 strncpy (fold_buffer
, name
+ 1, len
- 2);
535 fold_buffer
[len
- 2] = '\000';
540 for (i
= 0; i
<= len
; i
+= 1)
541 fold_buffer
[i
] = tolower (name
[i
]);
548 1. Discard final __{DIGIT}+ or ${DIGIT}+
549 2. Convert other instances of embedded "__" to `.'.
550 3. Discard leading _ada_.
551 4. Convert operator names to the appropriate quoted symbols.
552 5. Remove everything after first ___ if it is followed by
554 6. Replace TK__ with __, and a trailing B or TKB with nothing.
555 7. Put symbols that should be suppressed in <...> brackets.
556 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
557 The resulting string is valid until the next call of ada_demangle.
561 ada_demangle (const char *mangled
)
568 static char *demangling_buffer
= NULL
;
569 static size_t demangling_buffer_size
= 0;
571 if (STREQN (mangled
, "_ada_", 5))
574 if (mangled
[0] == '_' || mangled
[0] == '<')
577 p
= strstr (mangled
, "___");
579 len0
= strlen (mangled
);
587 if (len0
> 3 && STREQ (mangled
+ len0
- 3, "TKB"))
589 if (len0
> 1 && STREQ (mangled
+ len0
- 1, "B"))
592 /* Make demangled big enough for possible expansion by operator name. */
593 GROW_VECT (demangling_buffer
, demangling_buffer_size
, 2 * len0
+ 1);
594 demangled
= demangling_buffer
;
596 if (isdigit (mangled
[len0
- 1]))
598 for (i
= len0
- 2; i
>= 0 && isdigit (mangled
[i
]); i
-= 1)
600 if (i
> 1 && mangled
[i
] == '_' && mangled
[i
- 1] == '_')
602 else if (mangled
[i
] == '$')
606 for (i
= 0, j
= 0; i
< len0
&& !isalpha (mangled
[i
]); i
+= 1, j
+= 1)
607 demangled
[j
] = mangled
[i
];
612 if (at_start_name
&& mangled
[i
] == 'O')
615 for (k
= 0; ada_opname_table
[k
].mangled
!= NULL
; k
+= 1)
617 int op_len
= strlen (ada_opname_table
[k
].mangled
);
619 (ada_opname_table
[k
].mangled
+ 1, mangled
+ i
+ 1,
620 op_len
- 1) && !isalnum (mangled
[i
+ op_len
]))
622 strcpy (demangled
+ j
, ada_opname_table
[k
].demangled
);
625 j
+= strlen (ada_opname_table
[k
].demangled
);
629 if (ada_opname_table
[k
].mangled
!= NULL
)
634 if (i
< len0
- 4 && STREQN (mangled
+ i
, "TK__", 4))
636 if (mangled
[i
] == 'X' && i
!= 0 && isalnum (mangled
[i
- 1]))
640 while (i
< len0
&& (mangled
[i
] == 'b' || mangled
[i
] == 'n'));
644 else if (i
< len0
- 2 && mangled
[i
] == '_' && mangled
[i
+ 1] == '_')
653 demangled
[j
] = mangled
[i
];
658 demangled
[j
] = '\000';
660 for (i
= 0; demangled
[i
] != '\0'; i
+= 1)
661 if (isupper (demangled
[i
]) || demangled
[i
] == ' ')
667 GROW_VECT (demangling_buffer
, demangling_buffer_size
, strlen (mangled
) + 3);
668 demangled
= demangling_buffer
;
669 if (mangled
[0] == '<')
670 strcpy (demangled
, mangled
);
672 sprintf (demangled
, "<%s>", mangled
);
677 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
678 * suffixes that encode debugging information or leading _ada_ on
679 * SYM_NAME (see is_name_suffix commentary for the debugging
680 * information that is ignored). If WILD, then NAME need only match a
681 * suffix of SYM_NAME minus the same suffixes. Also returns 0 if
682 * either argument is NULL. */
685 ada_match_name (const char *sym_name
, const char *name
, int wild
)
687 if (sym_name
== NULL
|| name
== NULL
)
690 return wild_match (name
, strlen (name
), sym_name
);
693 int len_name
= strlen (name
);
694 return (STREQN (sym_name
, name
, len_name
)
695 && is_name_suffix (sym_name
+ len_name
))
696 || (STREQN (sym_name
, "_ada_", 5)
697 && STREQN (sym_name
+ 5, name
, len_name
)
698 && is_name_suffix (sym_name
+ len_name
+ 5));
702 /* True (non-zero) iff in Ada mode, the symbol SYM should be
703 suppressed in info listings. */
706 ada_suppress_symbol_printing (struct symbol
*sym
)
708 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
711 return is_suppressed_name (DEPRECATED_SYMBOL_NAME (sym
));
717 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of
718 array descriptors. */
720 static char *bound_name
[] = {
721 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
722 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
725 /* Maximum number of array dimensions we are prepared to handle. */
727 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char*)))
729 /* Like modify_field, but allows bitpos > wordlength. */
732 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
734 modify_field (addr
+ sizeof (LONGEST
) * bitpos
/ (8 * sizeof (LONGEST
)),
735 fieldval
, bitpos
% (8 * sizeof (LONGEST
)), bitsize
);
739 /* The desc_* routines return primitive portions of array descriptors
742 /* The descriptor or array type, if any, indicated by TYPE; removes
743 level of indirection, if needed. */
745 desc_base_type (struct type
*type
)
749 CHECK_TYPEDEF (type
);
750 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_PTR
)
751 return check_typedef (TYPE_TARGET_TYPE (type
));
756 /* True iff TYPE indicates a "thin" array pointer type. */
758 is_thin_pntr (struct type
*type
)
761 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
762 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
765 /* The descriptor type for thin pointer type TYPE. */
767 thin_descriptor_type (struct type
*type
)
769 struct type
*base_type
= desc_base_type (type
);
770 if (base_type
== NULL
)
772 if (is_suffix (ada_type_name (base_type
), "___XVE"))
776 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
777 if (alt_type
== NULL
)
784 /* A pointer to the array data for thin-pointer value VAL. */
785 static struct value
*
786 thin_data_pntr (struct value
*val
)
788 struct type
*type
= VALUE_TYPE (val
);
789 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
790 return value_cast (desc_data_type (thin_descriptor_type (type
)),
793 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
794 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
));
797 /* True iff TYPE indicates a "thick" array pointer type. */
799 is_thick_pntr (struct type
*type
)
801 type
= desc_base_type (type
);
802 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
803 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
806 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
807 pointer to one, the type of its bounds data; otherwise, NULL. */
809 desc_bounds_type (struct type
*type
)
813 type
= desc_base_type (type
);
817 else if (is_thin_pntr (type
))
819 type
= thin_descriptor_type (type
);
822 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
824 return check_typedef (r
);
826 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
828 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
830 return check_typedef (TYPE_TARGET_TYPE (check_typedef (r
)));
835 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
836 one, a pointer to its bounds data. Otherwise NULL. */
837 static struct value
*
838 desc_bounds (struct value
*arr
)
840 struct type
*type
= check_typedef (VALUE_TYPE (arr
));
841 if (is_thin_pntr (type
))
843 struct type
*bounds_type
=
844 desc_bounds_type (thin_descriptor_type (type
));
847 if (desc_bounds_type
== NULL
)
848 error ("Bad GNAT array descriptor");
850 /* NOTE: The following calculation is not really kosher, but
851 since desc_type is an XVE-encoded type (and shouldn't be),
852 the correct calculation is a real pain. FIXME (and fix GCC). */
853 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
854 addr
= value_as_long (arr
);
856 addr
= VALUE_ADDRESS (arr
) + VALUE_OFFSET (arr
);
859 value_from_longest (lookup_pointer_type (bounds_type
),
860 addr
- TYPE_LENGTH (bounds_type
));
863 else if (is_thick_pntr (type
))
864 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
865 "Bad GNAT array descriptor");
870 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
871 position of the field containing the address of the bounds data. */
873 fat_pntr_bounds_bitpos (struct type
*type
)
875 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
878 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
879 size of the field containing the address of the bounds data. */
881 fat_pntr_bounds_bitsize (struct type
*type
)
883 type
= desc_base_type (type
);
885 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
886 return TYPE_FIELD_BITSIZE (type
, 1);
888 return 8 * TYPE_LENGTH (check_typedef (TYPE_FIELD_TYPE (type
, 1)));
891 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
892 pointer to one, the type of its array data (a
893 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
894 ada_type_of_array to get an array type with bounds data. */
896 desc_data_type (struct type
*type
)
898 type
= desc_base_type (type
);
900 /* NOTE: The following is bogus; see comment in desc_bounds. */
901 if (is_thin_pntr (type
))
902 return lookup_pointer_type
903 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
904 else if (is_thick_pntr (type
))
905 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
910 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
912 static struct value
*
913 desc_data (struct value
*arr
)
915 struct type
*type
= VALUE_TYPE (arr
);
916 if (is_thin_pntr (type
))
917 return thin_data_pntr (arr
);
918 else if (is_thick_pntr (type
))
919 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
920 "Bad GNAT array descriptor");
926 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
927 position of the field containing the address of the data. */
929 fat_pntr_data_bitpos (struct type
*type
)
931 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
934 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
935 size of the field containing the address of the data. */
937 fat_pntr_data_bitsize (struct type
*type
)
939 type
= desc_base_type (type
);
941 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
942 return TYPE_FIELD_BITSIZE (type
, 0);
944 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
947 /* If BOUNDS is an array-bounds structure (or pointer to one), return
948 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
949 bound, if WHICH is 1. The first bound is I=1. */
950 static struct value
*
951 desc_one_bound (struct value
*bounds
, int i
, int which
)
953 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
954 "Bad GNAT array descriptor bounds");
957 /* If BOUNDS is an array-bounds structure type, return the bit position
958 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
959 bound, if WHICH is 1. The first bound is I=1. */
961 desc_bound_bitpos (struct type
*type
, int i
, int which
)
963 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
966 /* If BOUNDS is an array-bounds structure type, return the bit field size
967 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
968 bound, if WHICH is 1. The first bound is I=1. */
970 desc_bound_bitsize (struct type
*type
, int i
, int which
)
972 type
= desc_base_type (type
);
974 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
975 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
977 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
980 /* If TYPE is the type of an array-bounds structure, the type of its
981 Ith bound (numbering from 1). Otherwise, NULL. */
983 desc_index_type (struct type
*type
, int i
)
985 type
= desc_base_type (type
);
987 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
988 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
993 /* The number of index positions in the array-bounds type TYPE. 0
996 desc_arity (struct type
*type
)
998 type
= desc_base_type (type
);
1001 return TYPE_NFIELDS (type
) / 2;
1006 /* Non-zero iff type is a simple array type (or pointer to one). */
1008 ada_is_simple_array (struct type
*type
)
1012 CHECK_TYPEDEF (type
);
1013 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1014 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1015 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1018 /* Non-zero iff type belongs to a GNAT array descriptor. */
1020 ada_is_array_descriptor (struct type
*type
)
1022 struct type
*data_type
= desc_data_type (type
);
1026 CHECK_TYPEDEF (type
);
1029 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1030 && TYPE_TARGET_TYPE (data_type
) != NULL
1031 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1033 TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1034 && desc_arity (desc_bounds_type (type
)) > 0;
1037 /* Non-zero iff type is a partially mal-formed GNAT array
1038 descriptor. (FIXME: This is to compensate for some problems with
1039 debugging output from GNAT. Re-examine periodically to see if it
1042 ada_is_bogus_array_descriptor (struct type
*type
)
1046 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1047 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1048 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1049 && !ada_is_array_descriptor (type
);
1053 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1054 (fat pointer) returns the type of the array data described---specifically,
1055 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1056 in from the descriptor; otherwise, they are left unspecified. If
1057 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1058 returns NULL. The result is simply the type of ARR if ARR is not
1061 ada_type_of_array (struct value
*arr
, int bounds
)
1063 if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1064 return decode_packed_array_type (VALUE_TYPE (arr
));
1066 if (!ada_is_array_descriptor (VALUE_TYPE (arr
)))
1067 return VALUE_TYPE (arr
);
1071 check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr
))));
1074 struct type
*elt_type
;
1076 struct value
*descriptor
;
1077 struct objfile
*objf
= TYPE_OBJFILE (VALUE_TYPE (arr
));
1079 elt_type
= ada_array_element_type (VALUE_TYPE (arr
), -1);
1080 arity
= ada_array_arity (VALUE_TYPE (arr
));
1082 if (elt_type
== NULL
|| arity
== 0)
1083 return check_typedef (VALUE_TYPE (arr
));
1085 descriptor
= desc_bounds (arr
);
1086 if (value_as_long (descriptor
) == 0)
1090 struct type
*range_type
= alloc_type (objf
);
1091 struct type
*array_type
= alloc_type (objf
);
1092 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1093 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1096 create_range_type (range_type
, VALUE_TYPE (low
),
1097 (int) value_as_long (low
),
1098 (int) value_as_long (high
));
1099 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1102 return lookup_pointer_type (elt_type
);
1106 /* If ARR does not represent an array, returns ARR unchanged.
1107 Otherwise, returns either a standard GDB array with bounds set
1108 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1109 GDB array. Returns NULL if ARR is a null fat pointer. */
1111 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1113 if (ada_is_array_descriptor (VALUE_TYPE (arr
)))
1115 struct type
*arrType
= ada_type_of_array (arr
, 1);
1116 if (arrType
== NULL
)
1118 return value_cast (arrType
, value_copy (desc_data (arr
)));
1120 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1121 return decode_packed_array (arr
);
1126 /* If ARR does not represent an array, returns ARR unchanged.
1127 Otherwise, returns a standard GDB array describing ARR (which may
1128 be ARR itself if it already is in the proper form). */
1130 ada_coerce_to_simple_array (struct value
*arr
)
1132 if (ada_is_array_descriptor (VALUE_TYPE (arr
)))
1134 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1136 error ("Bounds unavailable for null array pointer.");
1137 return value_ind (arrVal
);
1139 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1140 return decode_packed_array (arr
);
1145 /* If TYPE represents a GNAT array type, return it translated to an
1146 ordinary GDB array type (possibly with BITSIZE fields indicating
1147 packing). For other types, is the identity. */
1149 ada_coerce_to_simple_array_type (struct type
*type
)
1151 struct value
*mark
= value_mark ();
1152 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1153 struct type
*result
;
1154 VALUE_TYPE (dummy
) = type
;
1155 result
= ada_type_of_array (dummy
, 0);
1156 value_free_to_mark (dummy
);
1160 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1162 ada_is_packed_array_type (struct type
*type
)
1166 CHECK_TYPEDEF (type
);
1168 ada_type_name (type
) != NULL
1169 && strstr (ada_type_name (type
), "___XP") != NULL
;
1172 /* Given that TYPE is a standard GDB array type with all bounds filled
1173 in, and that the element size of its ultimate scalar constituents
1174 (that is, either its elements, or, if it is an array of arrays, its
1175 elements' elements, etc.) is *ELT_BITS, return an identical type,
1176 but with the bit sizes of its elements (and those of any
1177 constituent arrays) recorded in the BITSIZE components of its
1178 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1180 static struct type
*
1181 packed_array_type (struct type
*type
, long *elt_bits
)
1183 struct type
*new_elt_type
;
1184 struct type
*new_type
;
1185 LONGEST low_bound
, high_bound
;
1187 CHECK_TYPEDEF (type
);
1188 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1191 new_type
= alloc_type (TYPE_OBJFILE (type
));
1192 new_elt_type
= packed_array_type (check_typedef (TYPE_TARGET_TYPE (type
)),
1194 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1195 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1196 TYPE_NAME (new_type
) = ada_type_name (type
);
1198 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1199 &low_bound
, &high_bound
) < 0)
1200 low_bound
= high_bound
= 0;
1201 if (high_bound
< low_bound
)
1202 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1205 *elt_bits
*= (high_bound
- low_bound
+ 1);
1206 TYPE_LENGTH (new_type
) =
1207 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1210 /* TYPE_FLAGS (new_type) |= TYPE_FLAG_FIXED_INSTANCE; */
1211 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
1215 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE).
1217 static struct type
*
1218 decode_packed_array_type (struct type
*type
)
1220 struct symbol
**syms
;
1221 struct block
**blocks
;
1222 const char *raw_name
= ada_type_name (check_typedef (type
));
1223 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1224 char *tail
= strstr (raw_name
, "___XP");
1225 struct type
*shadow_type
;
1229 memcpy (name
, raw_name
, tail
- raw_name
);
1230 name
[tail
- raw_name
] = '\000';
1232 /* NOTE: Use ada_lookup_symbol_list because of bug in some versions
1233 * of gcc (Solaris, e.g.). FIXME when compiler is fixed. */
1234 n
= ada_lookup_symbol_list (name
, get_selected_block (NULL
),
1235 VAR_DOMAIN
, &syms
, &blocks
);
1236 for (i
= 0; i
< n
; i
+= 1)
1237 if (syms
[i
] != NULL
&& SYMBOL_CLASS (syms
[i
]) == LOC_TYPEDEF
1238 && STREQ (name
, ada_type_name (SYMBOL_TYPE (syms
[i
]))))
1242 warning ("could not find bounds information on packed array");
1245 shadow_type
= SYMBOL_TYPE (syms
[i
]);
1247 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1249 warning ("could not understand bounds information on packed array");
1253 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1255 warning ("could not understand bit size information on packed array");
1259 return packed_array_type (shadow_type
, &bits
);
1262 /* Given that ARR is a struct value* indicating a GNAT packed array,
1263 returns a simple array that denotes that array. Its type is a
1264 standard GDB array type except that the BITSIZEs of the array
1265 target types are set to the number of bits in each element, and the
1266 type length is set appropriately. */
1268 static struct value
*
1269 decode_packed_array (struct value
*arr
)
1271 struct type
*type
= decode_packed_array_type (VALUE_TYPE (arr
));
1275 error ("can't unpack array");
1279 return coerce_unspec_val_to_type (arr
, 0, type
);
1283 /* The value of the element of packed array ARR at the ARITY indices
1284 given in IND. ARR must be a simple array. */
1286 static struct value
*
1287 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1290 int bits
, elt_off
, bit_off
;
1291 long elt_total_bit_offset
;
1292 struct type
*elt_type
;
1296 elt_total_bit_offset
= 0;
1297 elt_type
= check_typedef (VALUE_TYPE (arr
));
1298 for (i
= 0; i
< arity
; i
+= 1)
1300 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1301 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1303 ("attempt to do packed indexing of something other than a packed array");
1306 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1307 LONGEST lowerbound
, upperbound
;
1310 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1312 warning ("don't know bounds of array");
1313 lowerbound
= upperbound
= 0;
1316 idx
= value_as_long (value_pos_atr (ind
[i
]));
1317 if (idx
< lowerbound
|| idx
> upperbound
)
1318 warning ("packed array index %ld out of bounds", (long) idx
);
1319 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1320 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1321 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
1324 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1325 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1327 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1329 if (VALUE_LVAL (arr
) == lval_internalvar
)
1330 VALUE_LVAL (v
) = lval_internalvar_component
;
1332 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1336 /* Non-zero iff TYPE includes negative integer values. */
1339 has_negatives (struct type
*type
)
1341 switch (TYPE_CODE (type
))
1346 return !TYPE_UNSIGNED (type
);
1347 case TYPE_CODE_RANGE
:
1348 return TYPE_LOW_BOUND (type
) < 0;
1353 /* Create a new value of type TYPE from the contents of OBJ starting
1354 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1355 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1356 assigning through the result will set the field fetched from. OBJ
1357 may also be NULL, in which case, VALADDR+OFFSET must address the
1358 start of storage containing the packed value. The value returned
1359 in this case is never an lval.
1360 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1363 ada_value_primitive_packed_val (struct value
*obj
, char *valaddr
, long offset
,
1364 int bit_offset
, int bit_size
,
1368 int src
, /* Index into the source area. */
1369 targ
, /* Index into the target area. */
1370 i
, srcBitsLeft
, /* Number of source bits left to move. */
1371 nsrc
, ntarg
, /* Number of source and target bytes. */
1372 unusedLS
, /* Number of bits in next significant
1373 * byte of source that are unused. */
1374 accumSize
; /* Number of meaningful bits in accum */
1375 unsigned char *bytes
; /* First byte containing data to unpack. */
1376 unsigned char *unpacked
;
1377 unsigned long accum
; /* Staging area for bits being transferred */
1379 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1380 /* Transmit bytes from least to most significant; delta is the
1381 * direction the indices move. */
1382 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1384 CHECK_TYPEDEF (type
);
1388 v
= allocate_value (type
);
1389 bytes
= (unsigned char *) (valaddr
+ offset
);
1391 else if (VALUE_LAZY (obj
))
1394 VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
, NULL
);
1395 bytes
= (unsigned char *) alloca (len
);
1396 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1400 v
= allocate_value (type
);
1401 bytes
= (unsigned char *) VALUE_CONTENTS (obj
) + offset
;
1406 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1407 if (VALUE_LVAL (obj
) == lval_internalvar
)
1408 VALUE_LVAL (v
) = lval_internalvar_component
;
1409 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
;
1410 VALUE_BITPOS (v
) = bit_offset
+ VALUE_BITPOS (obj
);
1411 VALUE_BITSIZE (v
) = bit_size
;
1412 if (VALUE_BITPOS (v
) >= HOST_CHAR_BIT
)
1414 VALUE_ADDRESS (v
) += 1;
1415 VALUE_BITPOS (v
) -= HOST_CHAR_BIT
;
1419 VALUE_BITSIZE (v
) = bit_size
;
1420 unpacked
= (unsigned char *) VALUE_CONTENTS (v
);
1422 srcBitsLeft
= bit_size
;
1424 ntarg
= TYPE_LENGTH (type
);
1428 memset (unpacked
, 0, TYPE_LENGTH (type
));
1431 else if (BITS_BIG_ENDIAN
)
1434 if (has_negatives (type
) &&
1435 ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1439 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1442 switch (TYPE_CODE (type
))
1444 case TYPE_CODE_ARRAY
:
1445 case TYPE_CODE_UNION
:
1446 case TYPE_CODE_STRUCT
:
1447 /* Non-scalar values must be aligned at a byte boundary. */
1449 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1450 /* And are placed at the beginning (most-significant) bytes
1456 targ
= TYPE_LENGTH (type
) - 1;
1462 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1465 unusedLS
= bit_offset
;
1468 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1475 /* Mask for removing bits of the next source byte that are not
1476 * part of the value. */
1477 unsigned int unusedMSMask
=
1478 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1480 /* Sign-extend bits for this byte. */
1481 unsigned int signMask
= sign
& ~unusedMSMask
;
1483 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1484 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1485 if (accumSize
>= HOST_CHAR_BIT
)
1487 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1488 accumSize
-= HOST_CHAR_BIT
;
1489 accum
>>= HOST_CHAR_BIT
;
1493 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1500 accum
|= sign
<< accumSize
;
1501 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1502 accumSize
-= HOST_CHAR_BIT
;
1503 accum
>>= HOST_CHAR_BIT
;
1511 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1512 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1515 move_bits (char *target
, int targ_offset
, char *source
, int src_offset
, int n
)
1517 unsigned int accum
, mask
;
1518 int accum_bits
, chunk_size
;
1520 target
+= targ_offset
/ HOST_CHAR_BIT
;
1521 targ_offset
%= HOST_CHAR_BIT
;
1522 source
+= src_offset
/ HOST_CHAR_BIT
;
1523 src_offset
%= HOST_CHAR_BIT
;
1524 if (BITS_BIG_ENDIAN
)
1526 accum
= (unsigned char) *source
;
1528 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1533 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
1534 accum_bits
+= HOST_CHAR_BIT
;
1536 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1539 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
1540 mask
= ((1 << chunk_size
) - 1) << unused_right
;
1543 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
1545 accum_bits
-= chunk_size
;
1552 accum
= (unsigned char) *source
>> src_offset
;
1554 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1558 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
1559 accum_bits
+= HOST_CHAR_BIT
;
1561 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1564 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
1565 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
1567 accum_bits
-= chunk_size
;
1568 accum
>>= chunk_size
;
1576 /* Store the contents of FROMVAL into the location of TOVAL.
1577 Return a new value with the location of TOVAL and contents of
1578 FROMVAL. Handles assignment into packed fields that have
1579 floating-point or non-scalar types. */
1581 static struct value
*
1582 ada_value_assign (struct value
*toval
, struct value
*fromval
)
1584 struct type
*type
= VALUE_TYPE (toval
);
1585 int bits
= VALUE_BITSIZE (toval
);
1587 if (!toval
->modifiable
)
1588 error ("Left operand of assignment is not a modifiable lvalue.");
1592 if (VALUE_LVAL (toval
) == lval_memory
1594 && (TYPE_CODE (type
) == TYPE_CODE_FLT
1595 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
1598 (VALUE_BITPOS (toval
) + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1599 char *buffer
= (char *) alloca (len
);
1602 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
1603 fromval
= value_cast (type
, fromval
);
1605 read_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
, len
);
1606 if (BITS_BIG_ENDIAN
)
1607 move_bits (buffer
, VALUE_BITPOS (toval
),
1608 VALUE_CONTENTS (fromval
),
1609 TYPE_LENGTH (VALUE_TYPE (fromval
)) * TARGET_CHAR_BIT
-
1612 move_bits (buffer
, VALUE_BITPOS (toval
), VALUE_CONTENTS (fromval
),
1614 write_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
,
1617 val
= value_copy (toval
);
1618 memcpy (VALUE_CONTENTS_RAW (val
), VALUE_CONTENTS (fromval
),
1619 TYPE_LENGTH (type
));
1620 VALUE_TYPE (val
) = type
;
1625 return value_assign (toval
, fromval
);
1629 /* The value of the element of array ARR at the ARITY indices given in IND.
1630 ARR may be either a simple array, GNAT array descriptor, or pointer
1634 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
1638 struct type
*elt_type
;
1640 elt
= ada_coerce_to_simple_array (arr
);
1642 elt_type
= check_typedef (VALUE_TYPE (elt
));
1643 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
1644 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
1645 return value_subscript_packed (elt
, arity
, ind
);
1647 for (k
= 0; k
< arity
; k
+= 1)
1649 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
1650 error ("too many subscripts (%d expected)", k
);
1651 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
1656 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
1657 value of the element of *ARR at the ARITY indices given in
1658 IND. Does not read the entire array into memory. */
1661 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
1666 for (k
= 0; k
< arity
; k
+= 1)
1671 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1672 error ("too many subscripts (%d expected)", k
);
1673 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
1675 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
1679 idx
= value_sub (ind
[k
], value_from_longest (builtin_type_int
, lwb
));
1680 arr
= value_add (arr
, idx
);
1681 type
= TYPE_TARGET_TYPE (type
);
1684 return value_ind (arr
);
1687 /* If type is a record type in the form of a standard GNAT array
1688 descriptor, returns the number of dimensions for type. If arr is a
1689 simple array, returns the number of "array of"s that prefix its
1690 type designation. Otherwise, returns 0. */
1693 ada_array_arity (struct type
*type
)
1700 type
= desc_base_type (type
);
1703 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1704 return desc_arity (desc_bounds_type (type
));
1706 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1709 type
= check_typedef (TYPE_TARGET_TYPE (type
));
1715 /* If TYPE is a record type in the form of a standard GNAT array
1716 descriptor or a simple array type, returns the element type for
1717 TYPE after indexing by NINDICES indices, or by all indices if
1718 NINDICES is -1. Otherwise, returns NULL. */
1721 ada_array_element_type (struct type
*type
, int nindices
)
1723 type
= desc_base_type (type
);
1725 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1728 struct type
*p_array_type
;
1730 p_array_type
= desc_data_type (type
);
1732 k
= ada_array_arity (type
);
1736 /* Initially p_array_type = elt_type(*)[]...(k times)...[] */
1737 if (nindices
>= 0 && k
> nindices
)
1739 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
1740 while (k
> 0 && p_array_type
!= NULL
)
1742 p_array_type
= check_typedef (TYPE_TARGET_TYPE (p_array_type
));
1745 return p_array_type
;
1747 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1749 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1751 type
= TYPE_TARGET_TYPE (type
);
1760 /* The type of nth index in arrays of given type (n numbering from 1). Does
1761 not examine memory. */
1764 ada_index_type (struct type
*type
, int n
)
1766 type
= desc_base_type (type
);
1768 if (n
> ada_array_arity (type
))
1771 if (ada_is_simple_array (type
))
1775 for (i
= 1; i
< n
; i
+= 1)
1776 type
= TYPE_TARGET_TYPE (type
);
1778 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
1781 return desc_index_type (desc_bounds_type (type
), n
);
1784 /* Given that arr is an array type, returns the lower bound of the
1785 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
1786 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1787 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
1788 bounds type. It works for other arrays with bounds supplied by
1789 run-time quantities other than discriminants. */
1792 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
1793 struct type
** typep
)
1796 struct type
*index_type_desc
;
1798 if (ada_is_packed_array_type (arr_type
))
1799 arr_type
= decode_packed_array_type (arr_type
);
1801 if (arr_type
== NULL
|| !ada_is_simple_array (arr_type
))
1804 *typep
= builtin_type_int
;
1805 return (LONGEST
) - which
;
1808 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
1809 type
= TYPE_TARGET_TYPE (arr_type
);
1813 index_type_desc
= ada_find_parallel_type (type
, "___XA");
1814 if (index_type_desc
== NULL
)
1816 struct type
*range_type
;
1817 struct type
*index_type
;
1821 type
= TYPE_TARGET_TYPE (type
);
1825 range_type
= TYPE_INDEX_TYPE (type
);
1826 index_type
= TYPE_TARGET_TYPE (range_type
);
1827 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
1828 index_type
= builtin_type_long
;
1830 *typep
= index_type
;
1832 (LONGEST
) (which
== 0
1833 ? TYPE_LOW_BOUND (range_type
)
1834 : TYPE_HIGH_BOUND (range_type
));
1838 struct type
*index_type
=
1839 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
1840 NULL
, TYPE_OBJFILE (arr_type
));
1842 *typep
= TYPE_TARGET_TYPE (index_type
);
1844 (LONGEST
) (which
== 0
1845 ? TYPE_LOW_BOUND (index_type
)
1846 : TYPE_HIGH_BOUND (index_type
));
1850 /* Given that arr is an array value, returns the lower bound of the
1851 nth index (numbering from 1) if which is 0, and the upper bound if
1852 which is 1. This routine will also work for arrays with bounds
1853 supplied by run-time quantities other than discriminants. */
1856 ada_array_bound (struct value
*arr
, int n
, int which
)
1858 struct type
*arr_type
= VALUE_TYPE (arr
);
1860 if (ada_is_packed_array_type (arr_type
))
1861 return ada_array_bound (decode_packed_array (arr
), n
, which
);
1862 else if (ada_is_simple_array (arr_type
))
1865 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
1866 return value_from_longest (type
, v
);
1869 return desc_one_bound (desc_bounds (arr
), n
, which
);
1872 /* Given that arr is an array value, returns the length of the
1873 nth index. This routine will also work for arrays with bounds
1874 supplied by run-time quantities other than discriminants. Does not
1875 work for arrays indexed by enumeration types with representation
1876 clauses at the moment. */
1879 ada_array_length (struct value
*arr
, int n
)
1881 struct type
*arr_type
= check_typedef (VALUE_TYPE (arr
));
1882 struct type
*index_type_desc
;
1884 if (ada_is_packed_array_type (arr_type
))
1885 return ada_array_length (decode_packed_array (arr
), n
);
1887 if (ada_is_simple_array (arr_type
))
1891 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
1892 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
1893 return value_from_longest (type
, v
);
1897 value_from_longest (builtin_type_ada_int
,
1898 value_as_long (desc_one_bound (desc_bounds (arr
),
1900 - value_as_long (desc_one_bound (desc_bounds (arr
),
1905 /* Name resolution */
1907 /* The "demangled" name for the user-definable Ada operator corresponding
1911 ada_op_name (enum exp_opcode op
)
1915 for (i
= 0; ada_opname_table
[i
].mangled
!= NULL
; i
+= 1)
1917 if (ada_opname_table
[i
].op
== op
)
1918 return ada_opname_table
[i
].demangled
;
1920 error ("Could not find operator name for opcode");
1924 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
1925 references (OP_UNRESOLVED_VALUES) and converts operators that are
1926 user-defined into appropriate function calls. If CONTEXT_TYPE is
1927 non-null, it provides a preferred result type [at the moment, only
1928 type void has any effect---causing procedures to be preferred over
1929 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
1930 return type is preferred. The variable unresolved_names contains a list
1931 of character strings referenced by expout that should be freed.
1932 May change (expand) *EXP. */
1935 ada_resolve (struct expression
**expp
, struct type
*context_type
)
1939 ada_resolve_subexp (expp
, &pc
, 1, context_type
);
1942 /* Resolve the operator of the subexpression beginning at
1943 position *POS of *EXPP. "Resolving" consists of replacing
1944 OP_UNRESOLVED_VALUE with an appropriate OP_VAR_VALUE, replacing
1945 built-in operators with function calls to user-defined operators,
1946 where appropriate, and (when DEPROCEDURE_P is non-zero), converting
1947 function-valued variables into parameterless calls. May expand
1948 EXP. The CONTEXT_TYPE functions as in ada_resolve, above. */
1950 static struct value
*
1951 ada_resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
1952 struct type
*context_type
)
1956 struct expression
*exp
; /* Convenience: == *expp */
1957 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
1958 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
1959 int nargs
; /* Number of operands */
1965 /* Pass one: resolve operands, saving their types and updating *pos. */
1969 /* case OP_UNRESOLVED_VALUE: */
1970 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1975 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
1976 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1977 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
1981 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
1982 for (i = 0; i < nargs-1; i += 1)
1983 argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
1989 ada_resolve_subexp (expp, pos, 0, NULL);
1990 for (i = 1; i < nargs; i += 1)
1991 ada_resolve_subexp (expp, pos, 1, NULL);
1997 /* FIXME: UNOP_QUAL should be defined in expression.h */
2001 ada_resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2005 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
2006 /* case OP_ATTRIBUTE:
2007 nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
2009 for (i = 0; i < nargs; i += 1)
2010 ada_resolve_subexp (expp, pos, 1, NULL);
2017 ada_resolve_subexp (expp
, pos
, 0, NULL
);
2026 arg1
= ada_resolve_subexp (expp
, pos
, 0, NULL
);
2028 ada_resolve_subexp (expp
, pos
, 1, NULL
);
2030 ada_resolve_subexp (expp
, pos
, 1, VALUE_TYPE (arg1
));
2038 error ("Unexpected operator during name resolution");
2053 case BINOP_LOGICAL_AND
:
2054 case BINOP_LOGICAL_OR
:
2055 case BINOP_BITWISE_AND
:
2056 case BINOP_BITWISE_IOR
:
2057 case BINOP_BITWISE_XOR
:
2060 case BINOP_NOTEQUAL
:
2067 case BINOP_SUBSCRIPT
:
2075 case UNOP_LOGICAL_NOT
:
2092 case OP_INTERNALVAR
:
2101 case STRUCTOP_STRUCT
:
2104 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2109 nargs
= longest_to_int (exp
->elts
[pc
+ 2].longconst
) + 1;
2110 nargs
-= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2111 /* A null array contains one dummy element to give the type. */
2117 /* FIXME: TERNOP_MBR should be defined in expression.h */
2123 /* FIXME: BINOP_MBR should be defined in expression.h */
2131 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2132 for (i
= 0; i
< nargs
; i
+= 1)
2133 argvec
[i
] = ada_resolve_subexp (expp
, pos
, 1, NULL
);
2139 /* Pass two: perform any resolution on principal operator. */
2145 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2146 /* case OP_UNRESOLVED_VALUE:
2148 struct symbol** candidate_syms;
2149 struct block** candidate_blocks;
2152 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 2].name,
2153 exp->elts[pc + 1].block,
2158 if (n_candidates > 1)
2160 /* Types tend to get re-introduced locally, so if there
2161 are any local symbols that are not types, first filter
2164 for (j = 0; j < n_candidates; j += 1)
2165 switch (SYMBOL_CLASS (candidate_syms[j]))
2171 case LOC_REGPARM_ADDR:
2175 case LOC_BASEREG_ARG:
2177 case LOC_COMPUTED_ARG:
2183 if (j < n_candidates)
2186 while (j < n_candidates)
2188 if (SYMBOL_CLASS (candidate_syms[j]) == LOC_TYPEDEF)
2190 candidate_syms[j] = candidate_syms[n_candidates-1];
2191 candidate_blocks[j] = candidate_blocks[n_candidates-1];
2200 if (n_candidates == 0)
2201 error ("No definition found for %s",
2202 ada_demangle (exp->elts[pc + 2].name));
2203 else if (n_candidates == 1)
2205 else if (deprocedure_p
2206 && ! is_nonfunction (candidate_syms, n_candidates))
2208 i = ada_resolve_function (candidate_syms, candidate_blocks,
2209 n_candidates, NULL, 0,
2210 exp->elts[pc + 2].name, context_type);
2212 error ("Could not find a match for %s",
2213 ada_demangle (exp->elts[pc + 2].name));
2217 printf_filtered ("Multiple matches for %s\n",
2218 ada_demangle (exp->elts[pc+2].name));
2219 user_select_syms (candidate_syms, candidate_blocks,
2224 exp->elts[pc].opcode = exp->elts[pc + 3].opcode = OP_VAR_VALUE;
2225 exp->elts[pc + 1].block = candidate_blocks[i];
2226 exp->elts[pc + 2].symbol = candidate_syms[i];
2227 if (innermost_block == NULL ||
2228 contained_in (candidate_blocks[i], innermost_block))
2229 innermost_block = candidate_blocks[i];
2234 if (deprocedure_p
&&
2235 TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)) ==
2238 replace_operator_with_call (expp
, pc
, 0, 0,
2239 exp
->elts
[pc
+ 2].symbol
,
2240 exp
->elts
[pc
+ 1].block
);
2247 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2248 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
2250 struct symbol** candidate_syms;
2251 struct block** candidate_blocks;
2254 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 5].name,
2255 exp->elts[pc + 4].block,
2259 if (n_candidates == 1)
2263 i = ada_resolve_function (candidate_syms, candidate_blocks,
2264 n_candidates, argvec, nargs-1,
2265 exp->elts[pc + 5].name, context_type);
2267 error ("Could not find a match for %s",
2268 ada_demangle (exp->elts[pc + 5].name));
2271 exp->elts[pc + 3].opcode = exp->elts[pc + 6].opcode = OP_VAR_VALUE;
2272 exp->elts[pc + 4].block = candidate_blocks[i];
2273 exp->elts[pc + 5].symbol = candidate_syms[i];
2274 if (innermost_block == NULL ||
2275 contained_in (candidate_blocks[i], innermost_block))
2276 innermost_block = candidate_blocks[i];
2288 case BINOP_BITWISE_AND
:
2289 case BINOP_BITWISE_IOR
:
2290 case BINOP_BITWISE_XOR
:
2292 case BINOP_NOTEQUAL
:
2300 case UNOP_LOGICAL_NOT
:
2302 if (possible_user_operator_p (op
, argvec
))
2304 struct symbol
**candidate_syms
;
2305 struct block
**candidate_blocks
;
2309 ada_lookup_symbol_list (ada_mangle (ada_op_name (op
)),
2310 (struct block
*) NULL
, VAR_DOMAIN
,
2311 &candidate_syms
, &candidate_blocks
);
2313 ada_resolve_function (candidate_syms
, candidate_blocks
,
2314 n_candidates
, argvec
, nargs
,
2315 ada_op_name (op
), NULL
);
2319 replace_operator_with_call (expp
, pc
, nargs
, 1,
2320 candidate_syms
[i
], candidate_blocks
[i
]);
2327 return evaluate_subexp_type (exp
, pos
);
2330 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2331 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2333 /* The term "match" here is rather loose. The match is heuristic and
2334 liberal. FIXME: TOO liberal, in fact. */
2337 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2339 CHECK_TYPEDEF (ftype
);
2340 CHECK_TYPEDEF (atype
);
2342 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2343 ftype
= TYPE_TARGET_TYPE (ftype
);
2344 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2345 atype
= TYPE_TARGET_TYPE (atype
);
2347 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2348 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2351 switch (TYPE_CODE (ftype
))
2356 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2357 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2358 TYPE_TARGET_TYPE (atype
), 0);
2360 return (may_deref
&&
2361 ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2363 case TYPE_CODE_ENUM
:
2364 case TYPE_CODE_RANGE
:
2365 switch (TYPE_CODE (atype
))
2368 case TYPE_CODE_ENUM
:
2369 case TYPE_CODE_RANGE
:
2375 case TYPE_CODE_ARRAY
:
2376 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2377 || ada_is_array_descriptor (atype
));
2379 case TYPE_CODE_STRUCT
:
2380 if (ada_is_array_descriptor (ftype
))
2381 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2382 || ada_is_array_descriptor (atype
));
2384 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2385 && !ada_is_array_descriptor (atype
));
2387 case TYPE_CODE_UNION
:
2389 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2393 /* Return non-zero if the formals of FUNC "sufficiently match" the
2394 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2395 may also be an enumeral, in which case it is treated as a 0-
2396 argument function. */
2399 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2402 struct type
*func_type
= SYMBOL_TYPE (func
);
2404 if (SYMBOL_CLASS (func
) == LOC_CONST
&&
2405 TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2406 return (n_actuals
== 0);
2407 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2410 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2413 for (i
= 0; i
< n_actuals
; i
+= 1)
2415 struct type
*ftype
= check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2416 struct type
*atype
= check_typedef (VALUE_TYPE (actuals
[i
]));
2418 if (!ada_type_match (TYPE_FIELD_TYPE (func_type
, i
),
2419 VALUE_TYPE (actuals
[i
]), 1))
2425 /* False iff function type FUNC_TYPE definitely does not produce a value
2426 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2427 FUNC_TYPE is not a valid function type with a non-null return type
2428 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2431 return_match (struct type
*func_type
, struct type
*context_type
)
2433 struct type
*return_type
;
2435 if (func_type
== NULL
)
2438 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2439 /* if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
2440 return_type = base_type (TYPE_TARGET_TYPE (func_type));
2442 return_type = base_type (func_type); */
2443 if (return_type
== NULL
)
2446 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2447 /* context_type = base_type (context_type); */
2449 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2450 return context_type
== NULL
|| return_type
== context_type
;
2451 else if (context_type
== NULL
)
2452 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2454 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2458 /* Return the index in SYMS[0..NSYMS-1] of symbol for the
2459 function (if any) that matches the types of the NARGS arguments in
2460 ARGS. If CONTEXT_TYPE is non-null, and there is at least one match
2461 that returns type CONTEXT_TYPE, then eliminate other matches. If
2462 CONTEXT_TYPE is null, prefer a non-void-returning function.
2463 Asks the user if there is more than one match remaining. Returns -1
2464 if there is no such symbol or none is selected. NAME is used
2465 solely for messages. May re-arrange and modify SYMS in
2466 the process; the index returned is for the modified vector. BLOCKS
2467 is modified in parallel to SYMS. */
2470 ada_resolve_function (struct symbol
*syms
[], struct block
*blocks
[],
2471 int nsyms
, struct value
**args
, int nargs
,
2472 const char *name
, struct type
*context_type
)
2475 int m
; /* Number of hits */
2476 struct type
*fallback
;
2477 struct type
*return_type
;
2479 return_type
= context_type
;
2480 if (context_type
== NULL
)
2481 fallback
= builtin_type_void
;
2488 for (k
= 0; k
< nsyms
; k
+= 1)
2490 struct type
*type
= check_typedef (SYMBOL_TYPE (syms
[k
]));
2492 if (ada_args_match (syms
[k
], args
, nargs
)
2493 && return_match (SYMBOL_TYPE (syms
[k
]), return_type
))
2497 blocks
[m
] = blocks
[k
];
2501 if (m
> 0 || return_type
== fallback
)
2504 return_type
= fallback
;
2511 printf_filtered ("Multiple matches for %s\n", name
);
2512 user_select_syms (syms
, blocks
, m
, 1);
2518 /* Returns true (non-zero) iff demangled name N0 should appear before N1 */
2519 /* in a listing of choices during disambiguation (see sort_choices, below). */
2520 /* The idea is that overloadings of a subprogram name from the */
2521 /* same package should sort in their source order. We settle for ordering */
2522 /* such symbols by their trailing number (__N or $N). */
2524 mangled_ordered_before (char *N0
, char *N1
)
2528 else if (N0
== NULL
)
2533 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
2535 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
2537 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
2538 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
2542 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
2545 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
2547 if (n0
== n1
&& STREQN (N0
, N1
, n0
))
2548 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
2550 return (strcmp (N0
, N1
) < 0);
2554 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by their */
2555 /* mangled names, rearranging BLOCKS[0..NSYMS-1] according to the same */
2558 sort_choices (struct symbol
*syms
[], struct block
*blocks
[], int nsyms
)
2561 for (i
= 1; i
< nsyms
; i
+= 1)
2563 struct symbol
*sym
= syms
[i
];
2564 struct block
*block
= blocks
[i
];
2567 for (j
= i
- 1; j
>= 0; j
-= 1)
2569 if (mangled_ordered_before (DEPRECATED_SYMBOL_NAME (syms
[j
]),
2570 DEPRECATED_SYMBOL_NAME (sym
)))
2572 syms
[j
+ 1] = syms
[j
];
2573 blocks
[j
+ 1] = blocks
[j
];
2576 blocks
[j
+ 1] = block
;
2580 /* Given a list of NSYMS symbols in SYMS and corresponding blocks in */
2581 /* BLOCKS, select up to MAX_RESULTS>0 by asking the user (if */
2582 /* necessary), returning the number selected, and setting the first */
2583 /* elements of SYMS and BLOCKS to the selected symbols and */
2584 /* corresponding blocks. Error if no symbols selected. BLOCKS may */
2585 /* be NULL, in which case it is ignored. */
2587 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
2588 to be re-integrated one of these days. */
2591 user_select_syms (struct symbol
*syms
[], struct block
*blocks
[], int nsyms
,
2595 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
2597 int first_choice
= (max_results
== 1) ? 1 : 2;
2599 if (max_results
< 1)
2600 error ("Request to select 0 symbols!");
2604 printf_unfiltered ("[0] cancel\n");
2605 if (max_results
> 1)
2606 printf_unfiltered ("[1] all\n");
2608 sort_choices (syms
, blocks
, nsyms
);
2610 for (i
= 0; i
< nsyms
; i
+= 1)
2612 if (syms
[i
] == NULL
)
2615 if (SYMBOL_CLASS (syms
[i
]) == LOC_BLOCK
)
2617 struct symtab_and_line sal
= find_function_start_sal (syms
[i
], 1);
2618 printf_unfiltered ("[%d] %s at %s:%d\n",
2620 SYMBOL_PRINT_NAME (syms
[i
]),
2622 ? "<no source file available>"
2623 : sal
.symtab
->filename
, sal
.line
);
2629 (SYMBOL_CLASS (syms
[i
]) == LOC_CONST
2630 && SYMBOL_TYPE (syms
[i
]) != NULL
2631 && TYPE_CODE (SYMBOL_TYPE (syms
[i
])) == TYPE_CODE_ENUM
);
2632 struct symtab
*symtab
= symtab_for_sym (syms
[i
]);
2634 if (SYMBOL_LINE (syms
[i
]) != 0 && symtab
!= NULL
)
2635 printf_unfiltered ("[%d] %s at %s:%d\n",
2637 SYMBOL_PRINT_NAME (syms
[i
]),
2638 symtab
->filename
, SYMBOL_LINE (syms
[i
]));
2639 else if (is_enumeral
&& TYPE_NAME (SYMBOL_TYPE (syms
[i
])) != NULL
)
2641 printf_unfiltered ("[%d] ", i
+ first_choice
);
2642 ada_print_type (SYMBOL_TYPE (syms
[i
]), NULL
, gdb_stdout
, -1, 0);
2643 printf_unfiltered ("'(%s) (enumeral)\n",
2644 SYMBOL_PRINT_NAME (syms
[i
]));
2646 else if (symtab
!= NULL
)
2647 printf_unfiltered (is_enumeral
2648 ? "[%d] %s in %s (enumeral)\n"
2649 : "[%d] %s at %s:?\n",
2651 SYMBOL_PRINT_NAME (syms
[i
]),
2654 printf_unfiltered (is_enumeral
2655 ? "[%d] %s (enumeral)\n"
2658 SYMBOL_PRINT_NAME (syms
[i
]));
2662 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
2665 for (i
= 0; i
< n_chosen
; i
+= 1)
2667 syms
[i
] = syms
[chosen
[i
]];
2669 blocks
[i
] = blocks
[chosen
[i
]];
2675 /* Read and validate a set of numeric choices from the user in the
2676 range 0 .. N_CHOICES-1. Place the results in increasing
2677 order in CHOICES[0 .. N-1], and return N.
2679 The user types choices as a sequence of numbers on one line
2680 separated by blanks, encoding them as follows:
2682 + A choice of 0 means to cancel the selection, throwing an error.
2683 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
2684 + The user chooses k by typing k+IS_ALL_CHOICE+1.
2686 The user is not allowed to choose more than MAX_RESULTS values.
2688 ANNOTATION_SUFFIX, if present, is used to annotate the input
2689 prompts (for use with the -f switch). */
2692 get_selections (int *choices
, int n_choices
, int max_results
,
2693 int is_all_choice
, char *annotation_suffix
)
2699 int first_choice
= is_all_choice
? 2 : 1;
2701 prompt
= getenv ("PS2");
2705 printf_unfiltered ("%s ", prompt
);
2706 gdb_flush (gdb_stdout
);
2708 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
2711 error_no_arg ("one or more choice numbers");
2715 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
2716 order, as given in args. Choices are validated. */
2722 while (isspace (*args
))
2724 if (*args
== '\0' && n_chosen
== 0)
2725 error_no_arg ("one or more choice numbers");
2726 else if (*args
== '\0')
2729 choice
= strtol (args
, &args2
, 10);
2730 if (args
== args2
|| choice
< 0
2731 || choice
> n_choices
+ first_choice
- 1)
2732 error ("Argument must be choice number");
2736 error ("cancelled");
2738 if (choice
< first_choice
)
2740 n_chosen
= n_choices
;
2741 for (j
= 0; j
< n_choices
; j
+= 1)
2745 choice
-= first_choice
;
2747 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
2751 if (j
< 0 || choice
!= choices
[j
])
2754 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
2755 choices
[k
+ 1] = choices
[k
];
2756 choices
[j
+ 1] = choice
;
2761 if (n_chosen
> max_results
)
2762 error ("Select no more than %d of the above", max_results
);
2767 /* Replace the operator of length OPLEN at position PC in *EXPP with a call */
2768 /* on the function identified by SYM and BLOCK, and taking NARGS */
2769 /* arguments. Update *EXPP as needed to hold more space. */
2772 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
2773 int oplen
, struct symbol
*sym
,
2774 struct block
*block
)
2776 /* A new expression, with 6 more elements (3 for funcall, 4 for function
2777 symbol, -oplen for operator being replaced). */
2778 struct expression
*newexp
= (struct expression
*)
2779 xmalloc (sizeof (struct expression
)
2780 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
2781 struct expression
*exp
= *expp
;
2783 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
2784 newexp
->language_defn
= exp
->language_defn
;
2785 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
2786 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
2787 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
2789 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
2790 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
2792 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
2793 newexp
->elts
[pc
+ 4].block
= block
;
2794 newexp
->elts
[pc
+ 5].symbol
= sym
;
2800 /* Type-class predicates */
2802 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), or */
2806 numeric_type_p (struct type
*type
)
2812 switch (TYPE_CODE (type
))
2817 case TYPE_CODE_RANGE
:
2818 return (type
== TYPE_TARGET_TYPE (type
)
2819 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
2826 /* True iff TYPE is integral (an INT or RANGE of INTs). */
2829 integer_type_p (struct type
*type
)
2835 switch (TYPE_CODE (type
))
2839 case TYPE_CODE_RANGE
:
2840 return (type
== TYPE_TARGET_TYPE (type
)
2841 || integer_type_p (TYPE_TARGET_TYPE (type
)));
2848 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
2851 scalar_type_p (struct type
*type
)
2857 switch (TYPE_CODE (type
))
2860 case TYPE_CODE_RANGE
:
2861 case TYPE_CODE_ENUM
:
2870 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
2873 discrete_type_p (struct type
*type
)
2879 switch (TYPE_CODE (type
))
2882 case TYPE_CODE_RANGE
:
2883 case TYPE_CODE_ENUM
:
2891 /* Returns non-zero if OP with operatands in the vector ARGS could be
2892 a user-defined function. Errs on the side of pre-defined operators
2893 (i.e., result 0). */
2896 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
2898 struct type
*type0
= check_typedef (VALUE_TYPE (args
[0]));
2899 struct type
*type1
=
2900 (args
[1] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[1]));
2911 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
2915 case BINOP_BITWISE_AND
:
2916 case BINOP_BITWISE_IOR
:
2917 case BINOP_BITWISE_XOR
:
2918 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
2921 case BINOP_NOTEQUAL
:
2926 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
2929 return ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
&&
2930 (TYPE_CODE (type0
) != TYPE_CODE_PTR
||
2931 TYPE_CODE (TYPE_TARGET_TYPE (type0
))
2932 != TYPE_CODE_ARRAY
))
2933 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
&&
2934 (TYPE_CODE (type1
) != TYPE_CODE_PTR
||
2935 TYPE_CODE (TYPE_TARGET_TYPE (type1
)) != TYPE_CODE_ARRAY
)));
2938 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
2942 case UNOP_LOGICAL_NOT
:
2944 return (!numeric_type_p (type0
));
2951 /** NOTE: In the following, we assume that a renaming type's name may
2952 * have an ___XD suffix. It would be nice if this went away at some
2955 /* If TYPE encodes a renaming, returns the renaming suffix, which
2956 * is XR for an object renaming, XRP for a procedure renaming, XRE for
2957 * an exception renaming, and XRS for a subprogram renaming. Returns
2958 * NULL if NAME encodes none of these. */
2960 ada_renaming_type (struct type
*type
)
2962 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
2964 const char *name
= type_name_no_tag (type
);
2965 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
2967 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
2976 /* Return non-zero iff SYM encodes an object renaming. */
2978 ada_is_object_renaming (struct symbol
*sym
)
2980 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
2981 return renaming_type
!= NULL
2982 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
2985 /* Assuming that SYM encodes a non-object renaming, returns the original
2986 * name of the renamed entity. The name is good until the end of
2989 ada_simple_renamed_entity (struct symbol
*sym
)
2992 const char *raw_name
;
2996 type
= SYMBOL_TYPE (sym
);
2997 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
2998 error ("Improperly encoded renaming.");
3000 raw_name
= TYPE_FIELD_NAME (type
, 0);
3001 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3003 error ("Improperly encoded renaming.");
3005 result
= xmalloc (len
+ 1);
3006 /* FIXME: add_name_string_cleanup should be defined in parse.c */
3007 /* add_name_string_cleanup (result); */
3008 strncpy (result
, raw_name
, len
);
3009 result
[len
] = '\000';
3014 /* Evaluation: Function Calls */
3016 /* Copy VAL onto the stack, using and updating *SP as the stack
3017 pointer. Return VAL as an lvalue. */
3019 static struct value
*
3020 place_on_stack (struct value
*val
, CORE_ADDR
*sp
)
3022 CORE_ADDR old_sp
= *sp
;
3025 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3026 STACK_ALIGN (TYPE_LENGTH
3027 (check_typedef (VALUE_TYPE (val
)))));
3029 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3030 TYPE_LENGTH (check_typedef (VALUE_TYPE (val
))));
3033 VALUE_LVAL (val
) = lval_memory
;
3034 if (INNER_THAN (1, 2))
3035 VALUE_ADDRESS (val
) = *sp
;
3037 VALUE_ADDRESS (val
) = old_sp
;
3042 /* Return the value ACTUAL, converted to be an appropriate value for a
3043 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3044 allocating any necessary descriptors (fat pointers), or copies of
3045 values not residing in memory, updating it as needed. */
3047 static struct value
*
3048 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3051 struct type
*actual_type
= check_typedef (VALUE_TYPE (actual
));
3052 struct type
*formal_type
= check_typedef (formal_type0
);
3053 struct type
*formal_target
=
3054 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3055 ? check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3056 struct type
*actual_target
=
3057 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3058 ? check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3060 if (ada_is_array_descriptor (formal_target
)
3061 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3062 return make_array_descriptor (formal_type
, actual
, sp
);
3063 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3065 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3066 && ada_is_array_descriptor (actual_target
))
3067 return desc_data (actual
);
3068 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3070 if (VALUE_LVAL (actual
) != lval_memory
)
3073 actual_type
= check_typedef (VALUE_TYPE (actual
));
3074 val
= allocate_value (actual_type
);
3075 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3076 (char *) VALUE_CONTENTS (actual
),
3077 TYPE_LENGTH (actual_type
));
3078 actual
= place_on_stack (val
, sp
);
3080 return value_addr (actual
);
3083 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3084 return ada_value_ind (actual
);
3090 /* Push a descriptor of type TYPE for array value ARR on the stack at
3091 *SP, updating *SP to reflect the new descriptor. Return either
3092 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3093 to-descriptor type rather than a descriptor type), a struct value*
3094 representing a pointer to this descriptor. */
3096 static struct value
*
3097 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3099 struct type
*bounds_type
= desc_bounds_type (type
);
3100 struct type
*desc_type
= desc_base_type (type
);
3101 struct value
*descriptor
= allocate_value (desc_type
);
3102 struct value
*bounds
= allocate_value (bounds_type
);
3103 CORE_ADDR bounds_addr
;
3106 for (i
= ada_array_arity (check_typedef (VALUE_TYPE (arr
))); i
> 0; i
-= 1)
3108 modify_general_field (VALUE_CONTENTS (bounds
),
3109 value_as_long (ada_array_bound (arr
, i
, 0)),
3110 desc_bound_bitpos (bounds_type
, i
, 0),
3111 desc_bound_bitsize (bounds_type
, i
, 0));
3112 modify_general_field (VALUE_CONTENTS (bounds
),
3113 value_as_long (ada_array_bound (arr
, i
, 1)),
3114 desc_bound_bitpos (bounds_type
, i
, 1),
3115 desc_bound_bitsize (bounds_type
, i
, 1));
3118 bounds
= place_on_stack (bounds
, sp
);
3120 modify_general_field (VALUE_CONTENTS (descriptor
),
3122 fat_pntr_data_bitpos (desc_type
),
3123 fat_pntr_data_bitsize (desc_type
));
3124 modify_general_field (VALUE_CONTENTS (descriptor
),
3125 VALUE_ADDRESS (bounds
),
3126 fat_pntr_bounds_bitpos (desc_type
),
3127 fat_pntr_bounds_bitsize (desc_type
));
3129 descriptor
= place_on_stack (descriptor
, sp
);
3131 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3132 return value_addr (descriptor
);
3138 /* Assuming a dummy frame has been established on the target, perform any
3139 conversions needed for calling function FUNC on the NARGS actual
3140 parameters in ARGS, other than standard C conversions. Does
3141 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3142 does not match the number of arguments expected. Use *SP as a
3143 stack pointer for additional data that must be pushed, updating its
3147 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3152 if (TYPE_NFIELDS (VALUE_TYPE (func
)) == 0
3153 || nargs
!= TYPE_NFIELDS (VALUE_TYPE (func
)))
3156 for (i
= 0; i
< nargs
; i
+= 1)
3158 convert_actual (args
[i
], TYPE_FIELD_TYPE (VALUE_TYPE (func
), i
), sp
);
3165 /* The vectors of symbols and blocks ultimately returned from */
3166 /* ada_lookup_symbol_list. */
3168 /* Current size of defn_symbols and defn_blocks */
3169 static size_t defn_vector_size
= 0;
3171 /* Current number of symbols found. */
3172 static int ndefns
= 0;
3174 static struct symbol
**defn_symbols
= NULL
;
3175 static struct block
**defn_blocks
= NULL
;
3177 /* Return the result of a standard (literal, C-like) lookup of NAME in
3180 static struct symbol
*
3181 standard_lookup (const char *name
, domain_enum domain
)
3184 sym
= lookup_symbol (name
, (struct block
*) NULL
, domain
, 0, NULL
);
3189 /* Non-zero iff there is at least one non-function/non-enumeral symbol */
3190 /* in SYMS[0..N-1]. We treat enumerals as functions, since they */
3191 /* contend in overloading in the same way. */
3193 is_nonfunction (struct symbol
*syms
[], int n
)
3197 for (i
= 0; i
< n
; i
+= 1)
3198 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_FUNC
3199 && TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_ENUM
)
3205 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3206 struct types. Otherwise, they may not. */
3209 equiv_types (struct type
*type0
, struct type
*type1
)
3213 if (type0
== NULL
|| type1
== NULL
3214 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3216 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3217 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3218 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3219 && STREQ (ada_type_name (type0
), ada_type_name (type1
)))
3225 /* True iff SYM0 represents the same entity as SYM1, or one that is
3226 no more defined than that of SYM1. */
3229 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3233 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3234 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3237 switch (SYMBOL_CLASS (sym0
))
3243 struct type
*type0
= SYMBOL_TYPE (sym0
);
3244 struct type
*type1
= SYMBOL_TYPE (sym1
);
3245 char *name0
= DEPRECATED_SYMBOL_NAME (sym0
);
3246 char *name1
= DEPRECATED_SYMBOL_NAME (sym1
);
3247 int len0
= strlen (name0
);
3249 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3250 && (equiv_types (type0
, type1
)
3251 || (len0
< strlen (name1
) && STREQN (name0
, name1
, len0
)
3252 && STREQN (name1
+ len0
, "___XV", 5)));
3255 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3256 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3262 /* Append SYM to the end of defn_symbols, and BLOCK to the end of
3263 defn_blocks, updating ndefns, and expanding defn_symbols and
3264 defn_blocks as needed. Do not include SYM if it is a duplicate. */
3267 add_defn_to_vec (struct symbol
*sym
, struct block
*block
)
3272 if (SYMBOL_TYPE (sym
) != NULL
)
3273 CHECK_TYPEDEF (SYMBOL_TYPE (sym
));
3274 for (i
= 0; i
< ndefns
; i
+= 1)
3276 if (lesseq_defined_than (sym
, defn_symbols
[i
]))
3278 else if (lesseq_defined_than (defn_symbols
[i
], sym
))
3280 defn_symbols
[i
] = sym
;
3281 defn_blocks
[i
] = block
;
3286 tmp
= defn_vector_size
;
3287 GROW_VECT (defn_symbols
, tmp
, ndefns
+ 2);
3288 GROW_VECT (defn_blocks
, defn_vector_size
, ndefns
+ 2);
3290 defn_symbols
[ndefns
] = sym
;
3291 defn_blocks
[ndefns
] = block
;
3295 /* Look, in partial_symtab PST, for symbol NAME in given domain.
3296 Check the global symbols if GLOBAL, the static symbols if not. Do
3297 wild-card match if WILD. */
3299 static struct partial_symbol
*
3300 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3301 int global
, domain_enum domain
, int wild
)
3303 struct partial_symbol
**start
;
3304 int name_len
= strlen (name
);
3305 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3314 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3315 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3319 for (i
= 0; i
< length
; i
+= 1)
3321 struct partial_symbol
*psym
= start
[i
];
3323 if (SYMBOL_DOMAIN (psym
) == domain
&&
3324 wild_match (name
, name_len
, DEPRECATED_SYMBOL_NAME (psym
)))
3338 int M
= (U
+ i
) >> 1;
3339 struct partial_symbol
*psym
= start
[M
];
3340 if (DEPRECATED_SYMBOL_NAME (psym
)[0] < name
[0])
3342 else if (DEPRECATED_SYMBOL_NAME (psym
)[0] > name
[0])
3344 else if (strcmp (DEPRECATED_SYMBOL_NAME (psym
), name
) < 0)
3355 struct partial_symbol
*psym
= start
[i
];
3357 if (SYMBOL_DOMAIN (psym
) == domain
)
3359 int cmp
= strncmp (name
, DEPRECATED_SYMBOL_NAME (psym
), name_len
);
3367 && is_name_suffix (DEPRECATED_SYMBOL_NAME (psym
) + name_len
))
3380 int M
= (U
+ i
) >> 1;
3381 struct partial_symbol
*psym
= start
[M
];
3382 if (DEPRECATED_SYMBOL_NAME (psym
)[0] < '_')
3384 else if (DEPRECATED_SYMBOL_NAME (psym
)[0] > '_')
3386 else if (strcmp (DEPRECATED_SYMBOL_NAME (psym
), "_ada_") < 0)
3397 struct partial_symbol
*psym
= start
[i
];
3399 if (SYMBOL_DOMAIN (psym
) == domain
)
3403 cmp
= (int) '_' - (int) DEPRECATED_SYMBOL_NAME (psym
)[0];
3406 cmp
= strncmp ("_ada_", DEPRECATED_SYMBOL_NAME (psym
), 5);
3408 cmp
= strncmp (name
, DEPRECATED_SYMBOL_NAME (psym
) + 5, name_len
);
3417 && is_name_suffix (DEPRECATED_SYMBOL_NAME (psym
) + name_len
+ 5))
3428 /* Find a symbol table containing symbol SYM or NULL if none. */
3429 static struct symtab
*
3430 symtab_for_sym (struct symbol
*sym
)
3433 struct objfile
*objfile
;
3435 struct symbol
*tmp_sym
;
3438 ALL_SYMTABS (objfile
, s
)
3440 switch (SYMBOL_CLASS (sym
))
3448 case LOC_CONST_BYTES
:
3449 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3450 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3452 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3453 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3459 switch (SYMBOL_CLASS (sym
))
3465 case LOC_REGPARM_ADDR
:
3470 case LOC_BASEREG_ARG
:
3472 case LOC_COMPUTED_ARG
:
3473 for (j
= FIRST_LOCAL_BLOCK
;
3474 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3476 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3477 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3488 /* Return a minimal symbol matching NAME according to Ada demangling
3489 rules. Returns NULL if there is no such minimal symbol. */
3491 struct minimal_symbol
*
3492 ada_lookup_minimal_symbol (const char *name
)
3494 struct objfile
*objfile
;
3495 struct minimal_symbol
*msymbol
;
3496 int wild_match
= (strstr (name
, "__") == NULL
);
3498 ALL_MSYMBOLS (objfile
, msymbol
)
3500 if (ada_match_name (DEPRECATED_SYMBOL_NAME (msymbol
), name
, wild_match
)
3501 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
3508 /* For all subprograms that statically enclose the subprogram of the
3509 * selected frame, add symbols matching identifier NAME in DOMAIN
3510 * and their blocks to vectors *defn_symbols and *defn_blocks, as for
3511 * ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
3512 * wildcard prefix. At the moment, this function uses a heuristic to
3513 * find the frames of enclosing subprograms: it treats the
3514 * pointer-sized value at location 0 from the local-variable base of a
3515 * frame as a static link, and then searches up the call stack for a
3516 * frame with that same local-variable base. */
3518 add_symbols_from_enclosing_procs (const char *name
, domain_enum domain
,
3522 static struct symbol static_link_sym
;
3523 static struct symbol
*static_link
;
3525 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
3526 struct frame_info
*frame
;
3527 struct frame_info
*target_frame
;
3529 if (static_link
== NULL
)
3531 /* Initialize the local variable symbol that stands for the
3532 * static link (when it exists). */
3533 static_link
= &static_link_sym
;
3534 DEPRECATED_SYMBOL_NAME (static_link
) = "";
3535 SYMBOL_LANGUAGE (static_link
) = language_unknown
;
3536 SYMBOL_CLASS (static_link
) = LOC_LOCAL
;
3537 SYMBOL_DOMAIN (static_link
) = VAR_DOMAIN
;
3538 SYMBOL_TYPE (static_link
) = lookup_pointer_type (builtin_type_void
);
3539 SYMBOL_VALUE (static_link
) =
3540 -(long) TYPE_LENGTH (SYMBOL_TYPE (static_link
));
3543 frame
= deprecated_selected_frame
;
3544 while (frame
!= NULL
&& ndefns
== 0)
3546 struct block
*block
;
3547 struct value
*target_link_val
= read_var_value (static_link
, frame
);
3548 CORE_ADDR target_link
;
3550 if (target_link_val
== NULL
)
3554 target_link
= target_link_val
;
3558 frame
= get_prev_frame (frame
);
3560 while (frame
!= NULL
&& FRAME_LOCALS_ADDRESS (frame
) != target_link
);
3565 block
= get_frame_block (frame
, 0);
3566 while (block
!= NULL
&& block_function (block
) != NULL
&& ndefns
== 0)
3568 ada_add_block_symbols (block
, name
, domain
, NULL
, wild_match
);
3570 block
= BLOCK_SUPERBLOCK (block
);
3574 do_cleanups (old_chain
);
3578 /* True if TYPE is definitely an artificial type supplied to a symbol
3579 * for which no debugging information was given in the symbol file. */
3581 is_nondebugging_type (struct type
*type
)
3583 char *name
= ada_type_name (type
);
3584 return (name
!= NULL
&& STREQ (name
, "<variable, no debug info>"));
3587 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
3588 * duplicate other symbols in the list. (The only case I know of where
3589 * this happens is when object files containing stabs-in-ecoff are
3590 * linked with files containing ordinary ecoff debugging symbols (or no
3591 * debugging symbols)). Modifies SYMS to squeeze out deleted symbols,
3592 * and applies the same modification to BLOCKS to maintain the
3593 * correspondence between SYMS[i] and BLOCKS[i]. Returns the number
3594 * of symbols in the modified list. */
3596 remove_extra_symbols (struct symbol
**syms
, struct block
**blocks
, int nsyms
)
3603 if (DEPRECATED_SYMBOL_NAME (syms
[i
]) != NULL
3604 && SYMBOL_CLASS (syms
[i
]) == LOC_STATIC
3605 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
])))
3607 for (j
= 0; j
< nsyms
; j
+= 1)
3610 && DEPRECATED_SYMBOL_NAME (syms
[j
]) != NULL
3611 && STREQ (DEPRECATED_SYMBOL_NAME (syms
[i
]), DEPRECATED_SYMBOL_NAME (syms
[j
]))
3612 && SYMBOL_CLASS (syms
[i
]) == SYMBOL_CLASS (syms
[j
])
3613 && SYMBOL_VALUE_ADDRESS (syms
[i
])
3614 == SYMBOL_VALUE_ADDRESS (syms
[j
]))
3617 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
3619 syms
[k
- 1] = syms
[k
];
3620 blocks
[k
- 1] = blocks
[k
];
3634 /* Find symbols in DOMAIN matching NAME, in BLOCK0 and enclosing
3635 scope and in global scopes, returning the number of matches. Sets
3636 *SYMS to point to a vector of matching symbols, with *BLOCKS
3637 pointing to the vector of corresponding blocks in which those
3638 symbols reside. These two vectors are transient---good only to the
3639 next call of ada_lookup_symbol_list. Any non-function/non-enumeral symbol
3640 match within the nest of blocks whose innermost member is BLOCK0,
3641 is the outermost match returned (no other matches in that or
3642 enclosing blocks is returned). If there are any matches in or
3643 surrounding BLOCK0, then these alone are returned. */
3646 ada_lookup_symbol_list (const char *name
, struct block
*block0
,
3647 domain_enum domain
, struct symbol
***syms
,
3648 struct block
***blocks
)
3652 struct partial_symtab
*ps
;
3653 struct blockvector
*bv
;
3654 struct objfile
*objfile
;
3656 struct block
*block
;
3657 struct minimal_symbol
*msymbol
;
3658 int wild_match
= (strstr (name
, "__") == NULL
);
3668 /* Search specified block and its superiors. */
3671 while (block
!= NULL
)
3673 ada_add_block_symbols (block
, name
, domain
, NULL
, wild_match
);
3675 /* If we found a non-function match, assume that's the one. */
3676 if (is_nonfunction (defn_symbols
, ndefns
))
3679 block
= BLOCK_SUPERBLOCK (block
);
3682 /* If we found ANY matches in the specified BLOCK, we're done. */
3689 /* Now add symbols from all global blocks: symbol tables, minimal symbol
3690 tables, and psymtab's */
3692 ALL_SYMTABS (objfile
, s
)
3697 bv
= BLOCKVECTOR (s
);
3698 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3699 ada_add_block_symbols (block
, name
, domain
, objfile
, wild_match
);
3702 if (domain
== VAR_DOMAIN
)
3704 ALL_MSYMBOLS (objfile
, msymbol
)
3706 if (ada_match_name (DEPRECATED_SYMBOL_NAME (msymbol
), name
, wild_match
))
3708 switch (MSYMBOL_TYPE (msymbol
))
3710 case mst_solib_trampoline
:
3713 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
3716 int old_ndefns
= ndefns
;
3718 bv
= BLOCKVECTOR (s
);
3719 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3720 ada_add_block_symbols (block
,
3721 DEPRECATED_SYMBOL_NAME (msymbol
),
3722 domain
, objfile
, wild_match
);
3723 if (ndefns
== old_ndefns
)
3725 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3726 ada_add_block_symbols (block
,
3727 DEPRECATED_SYMBOL_NAME (msymbol
),
3737 ALL_PSYMTABS (objfile
, ps
)
3741 && ada_lookup_partial_symbol (ps
, name
, 1, domain
, wild_match
))
3743 s
= PSYMTAB_TO_SYMTAB (ps
);
3746 bv
= BLOCKVECTOR (s
);
3747 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3748 ada_add_block_symbols (block
, name
, domain
, objfile
, wild_match
);
3752 /* Now add symbols from all per-file blocks if we've gotten no hits.
3753 (Not strictly correct, but perhaps better than an error).
3754 Do the symtabs first, then check the psymtabs */
3759 ALL_SYMTABS (objfile
, s
)
3764 bv
= BLOCKVECTOR (s
);
3765 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3766 ada_add_block_symbols (block
, name
, domain
, objfile
, wild_match
);
3769 ALL_PSYMTABS (objfile
, ps
)
3773 && ada_lookup_partial_symbol (ps
, name
, 0, domain
, wild_match
))
3775 s
= PSYMTAB_TO_SYMTAB (ps
);
3776 bv
= BLOCKVECTOR (s
);
3779 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3780 ada_add_block_symbols (block
, name
, domain
,
3781 objfile
, wild_match
);
3786 /* Finally, we try to find NAME as a local symbol in some lexically
3787 enclosing block. We do this last, expecting this case to be
3791 add_symbols_from_enclosing_procs (name
, domain
, wild_match
);
3797 ndefns
= remove_extra_symbols (defn_symbols
, defn_blocks
, ndefns
);
3800 *syms
= defn_symbols
;
3801 *blocks
= defn_blocks
;
3808 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
3809 * scope and in global scopes, or NULL if none. NAME is folded to
3810 * lower case first, unless it is surrounded in single quotes.
3811 * Otherwise, the result is as for ada_lookup_symbol_list, but is
3812 * disambiguated by user query if needed. */
3815 ada_lookup_symbol (const char *name
, struct block
*block0
,
3818 struct symbol
**candidate_syms
;
3819 struct block
**candidate_blocks
;
3822 n_candidates
= ada_lookup_symbol_list (name
,
3824 &candidate_syms
, &candidate_blocks
);
3826 if (n_candidates
== 0)
3828 else if (n_candidates
!= 1)
3829 user_select_syms (candidate_syms
, candidate_blocks
, n_candidates
, 1);
3831 return candidate_syms
[0];
3835 /* True iff STR is a possible encoded suffix of a normal Ada name
3836 * that is to be ignored for matching purposes. Suffixes of parallel
3837 * names (e.g., XVE) are not included here. Currently, the possible suffixes
3838 * are given by the regular expression:
3839 * (X[nb]*)?(__[0-9]+|\$[0-9]+|___(LJM|X([FDBUP].*|R[^T]?)))?$
3843 is_name_suffix (const char *str
)
3849 while (str
[0] != '_' && str
[0] != '\0')
3851 if (str
[0] != 'n' && str
[0] != 'b')
3856 if (str
[0] == '\000')
3860 if (str
[1] != '_' || str
[2] == '\000')
3864 if (STREQ (str
+ 3, "LJM"))
3868 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B' ||
3869 str
[4] == 'U' || str
[4] == 'P')
3871 if (str
[4] == 'R' && str
[5] != 'T')
3875 for (k
= 2; str
[k
] != '\0'; k
+= 1)
3876 if (!isdigit (str
[k
]))
3880 if (str
[0] == '$' && str
[1] != '\000')
3882 for (k
= 1; str
[k
] != '\0'; k
+= 1)
3883 if (!isdigit (str
[k
]))
3890 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
3891 * PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
3892 * informational suffixes of NAME (i.e., for which is_name_suffix is
3895 wild_match (const char *patn
, int patn_len
, const char *name
)
3900 name_len
= strlen (name
);
3901 if (name_len
>= patn_len
+ 5 && STREQN (name
, "_ada_", 5)
3902 && STREQN (patn
, name
+ 5, patn_len
)
3903 && is_name_suffix (name
+ patn_len
+ 5))
3906 while (name_len
>= patn_len
)
3908 if (STREQN (patn
, name
, patn_len
) && is_name_suffix (name
+ patn_len
))
3916 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
3921 if (!islower (name
[2]))
3928 if (!islower (name
[1]))
3939 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
3940 vector *defn_symbols, updating *defn_symbols (if necessary), *SZ (the size of
3941 the vector *defn_symbols), and *ndefns (the number of symbols
3942 currently stored in *defn_symbols). If WILD, treat as NAME with a
3943 wildcard prefix. OBJFILE is the section containing BLOCK. */
3946 ada_add_block_symbols (struct block
*block
, const char *name
,
3947 domain_enum domain
, struct objfile
*objfile
,
3951 int name_len
= strlen (name
);
3952 /* A matching argument symbol, if any. */
3953 struct symbol
*arg_sym
;
3954 /* Set true when we find a matching non-argument symbol */
3956 int is_sorted
= BLOCK_SHOULD_SORT (block
);
3964 ALL_BLOCK_SYMBOLS (block
, i
, sym
)
3966 if (SYMBOL_DOMAIN (sym
) == domain
&&
3967 wild_match (name
, name_len
, DEPRECATED_SYMBOL_NAME (sym
)))
3969 switch (SYMBOL_CLASS (sym
))
3975 case LOC_REGPARM_ADDR
:
3976 case LOC_BASEREG_ARG
:
3977 case LOC_COMPUTED_ARG
:
3980 case LOC_UNRESOLVED
:
3984 fill_in_ada_prototype (sym
);
3985 add_defn_to_vec (fixup_symbol_section (sym
, objfile
), block
);
3997 U
= BLOCK_NSYMS (block
) - 1;
4000 int M
= (U
+ i
) >> 1;
4001 struct symbol
*sym
= BLOCK_SYM (block
, M
);
4002 if (DEPRECATED_SYMBOL_NAME (sym
)[0] < name
[0])
4004 else if (DEPRECATED_SYMBOL_NAME (sym
)[0] > name
[0])
4006 else if (strcmp (DEPRECATED_SYMBOL_NAME (sym
), name
) < 0)
4015 for (; i
< BLOCK_BUCKETS (block
); i
+= 1)
4016 for (sym
= BLOCK_BUCKET (block
, i
); sym
!= NULL
; sym
= sym
->hash_next
)
4018 if (SYMBOL_DOMAIN (sym
) == domain
)
4020 int cmp
= strncmp (name
, DEPRECATED_SYMBOL_NAME (sym
), name_len
);
4026 i
= BLOCK_BUCKETS (block
);
4031 && is_name_suffix (DEPRECATED_SYMBOL_NAME (sym
) + name_len
))
4033 switch (SYMBOL_CLASS (sym
))
4039 case LOC_REGPARM_ADDR
:
4040 case LOC_BASEREG_ARG
:
4041 case LOC_COMPUTED_ARG
:
4044 case LOC_UNRESOLVED
:
4048 fill_in_ada_prototype (sym
);
4049 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4058 if (!found_sym
&& arg_sym
!= NULL
)
4060 fill_in_ada_prototype (arg_sym
);
4061 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4072 U
= BLOCK_NSYMS (block
) - 1;
4075 int M
= (U
+ i
) >> 1;
4076 struct symbol
*sym
= BLOCK_SYM (block
, M
);
4077 if (DEPRECATED_SYMBOL_NAME (sym
)[0] < '_')
4079 else if (DEPRECATED_SYMBOL_NAME (sym
)[0] > '_')
4081 else if (strcmp (DEPRECATED_SYMBOL_NAME (sym
), "_ada_") < 0)
4090 for (; i
< BLOCK_BUCKETS (block
); i
+= 1)
4091 for (sym
= BLOCK_BUCKET (block
, i
); sym
!= NULL
; sym
= sym
->hash_next
)
4093 struct symbol
*sym
= BLOCK_SYM (block
, i
);
4095 if (SYMBOL_DOMAIN (sym
) == domain
)
4099 cmp
= (int) '_' - (int) DEPRECATED_SYMBOL_NAME (sym
)[0];
4102 cmp
= strncmp ("_ada_", DEPRECATED_SYMBOL_NAME (sym
), 5);
4104 cmp
= strncmp (name
, DEPRECATED_SYMBOL_NAME (sym
) + 5, name_len
);
4111 i
= BLOCK_BUCKETS (block
);
4116 && is_name_suffix (DEPRECATED_SYMBOL_NAME (sym
) + name_len
+ 5))
4118 switch (SYMBOL_CLASS (sym
))
4124 case LOC_REGPARM_ADDR
:
4125 case LOC_BASEREG_ARG
:
4126 case LOC_COMPUTED_ARG
:
4129 case LOC_UNRESOLVED
:
4133 fill_in_ada_prototype (sym
);
4134 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4142 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4143 They aren't parameters, right? */
4144 if (!found_sym
&& arg_sym
!= NULL
)
4146 fill_in_ada_prototype (arg_sym
);
4147 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4153 /* Function Types */
4155 /* Assuming that SYM is the symbol for a function, fill in its type
4156 with prototype information, if it is not already there. */
4159 fill_in_ada_prototype (struct symbol
*func
)
4170 || TYPE_CODE (SYMBOL_TYPE (func
)) != TYPE_CODE_FUNC
4171 || TYPE_FIELDS (SYMBOL_TYPE (func
)) != NULL
)
4174 /* We make each function type unique, so that each may have its own */
4175 /* parameter types. This particular way of doing so wastes space: */
4176 /* it would be nicer to build the argument types while the original */
4177 /* function type is being built (FIXME). */
4178 rtype
= check_typedef (TYPE_TARGET_TYPE (SYMBOL_TYPE (func
)));
4179 ftype
= alloc_type (TYPE_OBJFILE (SYMBOL_TYPE (func
)));
4180 make_function_type (rtype
, &ftype
);
4181 SYMBOL_TYPE (func
) = ftype
;
4183 b
= SYMBOL_BLOCK_VALUE (func
);
4187 TYPE_FIELDS (ftype
) =
4188 (struct field
*) xmalloc (sizeof (struct field
) * max_fields
);
4189 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4191 GROW_VECT (TYPE_FIELDS (ftype
), max_fields
, nargs
+ 1);
4193 switch (SYMBOL_CLASS (sym
))
4196 case LOC_REGPARM_ADDR
:
4197 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4198 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4199 TYPE_FIELD_STATIC_KIND (ftype
, nargs
) = 0;
4200 TYPE_FIELD_TYPE (ftype
, nargs
) =
4201 lookup_pointer_type (check_typedef (SYMBOL_TYPE (sym
)));
4202 TYPE_FIELD_NAME (ftype
, nargs
) = DEPRECATED_SYMBOL_NAME (sym
);
4210 case LOC_BASEREG_ARG
:
4211 case LOC_COMPUTED_ARG
:
4212 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4213 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4214 TYPE_FIELD_STATIC_KIND (ftype
, nargs
) = 0;
4215 TYPE_FIELD_TYPE (ftype
, nargs
) = check_typedef (SYMBOL_TYPE (sym
));
4216 TYPE_FIELD_NAME (ftype
, nargs
) = DEPRECATED_SYMBOL_NAME (sym
);
4226 /* Re-allocate fields vector; if there are no fields, make the */
4227 /* fields pointer non-null anyway, to mark that this function type */
4228 /* has been filled in. */
4230 TYPE_NFIELDS (ftype
) = nargs
;
4233 static struct field dummy_field
= { 0, 0, 0, 0 };
4234 xfree (TYPE_FIELDS (ftype
));
4235 TYPE_FIELDS (ftype
) = &dummy_field
;
4239 struct field
*fields
=
4240 (struct field
*) TYPE_ALLOC (ftype
, nargs
* sizeof (struct field
));
4241 memcpy ((char *) fields
,
4242 (char *) TYPE_FIELDS (ftype
), nargs
* sizeof (struct field
));
4243 xfree (TYPE_FIELDS (ftype
));
4244 TYPE_FIELDS (ftype
) = fields
;
4249 /* Breakpoint-related */
4251 char no_symtab_msg
[] =
4252 "No symbol table is loaded. Use the \"file\" command.";
4254 /* Assuming that LINE is pointing at the beginning of an argument to
4255 'break', return a pointer to the delimiter for the initial segment
4256 of that name. This is the first ':', ' ', or end of LINE.
4259 ada_start_decode_line_1 (char *line
)
4261 /* [NOTE: strpbrk would be more elegant, but I am reluctant to be
4262 the first to use such a library function in GDB code.] */
4264 for (p
= line
; *p
!= '\000' && *p
!= ' ' && *p
!= ':'; p
+= 1)
4269 /* *SPEC points to a function and line number spec (as in a break
4270 command), following any initial file name specification.
4272 Return all symbol table/line specfications (sals) consistent with the
4273 information in *SPEC and FILE_TABLE in the
4275 + FILE_TABLE is null, or the sal refers to a line in the file
4276 named by FILE_TABLE.
4277 + If *SPEC points to an argument with a trailing ':LINENUM',
4278 then the sal refers to that line (or one following it as closely as
4280 + If *SPEC does not start with '*', the sal is in a function with
4283 Returns with 0 elements if no matching non-minimal symbols found.
4285 If *SPEC begins with a function name of the form <NAME>, then NAME
4286 is taken as a literal name; otherwise the function name is subject
4287 to the usual mangling.
4289 *SPEC is updated to point after the function/line number specification.
4291 FUNFIRSTLINE is non-zero if we desire the first line of real code
4292 in each function (this is ignored in the presence of a LINENUM spec.).
4294 If CANONICAL is non-NULL, and if any of the sals require a
4295 'canonical line spec', then *CANONICAL is set to point to an array
4296 of strings, corresponding to and equal in length to the returned
4297 list of sals, such that (*CANONICAL)[i] is non-null and contains a
4298 canonical line spec for the ith returned sal, if needed. If no
4299 canonical line specs are required and CANONICAL is non-null,
4300 *CANONICAL is set to NULL.
4302 A 'canonical line spec' is simply a name (in the format of the
4303 breakpoint command) that uniquely identifies a breakpoint position,
4304 with no further contextual information or user selection. It is
4305 needed whenever the file name, function name, and line number
4306 information supplied is insufficient for this unique
4307 identification. Currently overloaded functions, the name '*',
4308 or static functions without a filename yield a canonical line spec.
4309 The array and the line spec strings are allocated on the heap; it
4310 is the caller's responsibility to free them. */
4312 struct symtabs_and_lines
4313 ada_finish_decode_line_1 (char **spec
, struct symtab
*file_table
,
4314 int funfirstline
, char ***canonical
)
4316 struct symbol
**symbols
;
4317 struct block
**blocks
;
4318 struct block
*block
;
4319 int n_matches
, i
, line_num
;
4320 struct symtabs_and_lines selected
;
4321 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4326 char *unquoted_name
;
4328 if (file_table
== NULL
)
4329 block
= get_selected_block (NULL
);
4331 block
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table
), STATIC_BLOCK
);
4333 if (canonical
!= NULL
)
4334 *canonical
= (char **) NULL
;
4341 while (**spec
!= '\000' &&
4342 !strchr (ada_completer_word_break_characters
, **spec
))
4348 if (file_table
!= NULL
&& (*spec
)[0] == ':' && isdigit ((*spec
)[1]))
4350 line_num
= strtol (*spec
+ 1, spec
, 10);
4351 while (**spec
== ' ' || **spec
== '\t')
4358 error ("Wild-card function with no line number or file name.");
4360 return all_sals_for_line (file_table
->filename
, line_num
, canonical
);
4363 if (name
[0] == '\'')
4371 unquoted_name
= (char *) alloca (len
- 1);
4372 memcpy (unquoted_name
, name
+ 1, len
- 2);
4373 unquoted_name
[len
- 2] = '\000';
4378 unquoted_name
= (char *) alloca (len
+ 1);
4379 memcpy (unquoted_name
, name
, len
);
4380 unquoted_name
[len
] = '\000';
4381 lower_name
= (char *) alloca (len
+ 1);
4382 for (i
= 0; i
< len
; i
+= 1)
4383 lower_name
[i
] = tolower (name
[i
]);
4384 lower_name
[len
] = '\000';
4388 if (lower_name
!= NULL
)
4389 n_matches
= ada_lookup_symbol_list (ada_mangle (lower_name
), block
,
4390 VAR_DOMAIN
, &symbols
, &blocks
);
4392 n_matches
= ada_lookup_symbol_list (unquoted_name
, block
,
4393 VAR_DOMAIN
, &symbols
, &blocks
);
4394 if (n_matches
== 0 && line_num
>= 0)
4395 error ("No line number information found for %s.", unquoted_name
);
4396 else if (n_matches
== 0)
4398 #ifdef HPPA_COMPILER_BUG
4399 /* FIXME: See comment in symtab.c::decode_line_1 */
4401 volatile struct symtab_and_line val
;
4402 #define volatile /*nothing */
4404 struct symtab_and_line val
;
4406 struct minimal_symbol
*msymbol
;
4411 if (lower_name
!= NULL
)
4412 msymbol
= ada_lookup_minimal_symbol (ada_mangle (lower_name
));
4413 if (msymbol
== NULL
)
4414 msymbol
= ada_lookup_minimal_symbol (unquoted_name
);
4415 if (msymbol
!= NULL
)
4417 val
.pc
= SYMBOL_VALUE_ADDRESS (msymbol
);
4418 val
.section
= SYMBOL_BFD_SECTION (msymbol
);
4421 val
.pc
+= FUNCTION_START_OFFSET
;
4422 SKIP_PROLOGUE (val
.pc
);
4424 selected
.sals
= (struct symtab_and_line
*)
4425 xmalloc (sizeof (struct symtab_and_line
));
4426 selected
.sals
[0] = val
;
4431 if (!have_full_symbols () &&
4432 !have_partial_symbols () && !have_minimal_symbols ())
4433 error (no_symtab_msg
);
4435 error ("Function \"%s\" not defined.", unquoted_name
);
4436 return selected
; /* for lint */
4442 find_sal_from_funcs_and_line (file_table
->filename
, line_num
,
4443 symbols
, n_matches
);
4448 user_select_syms (symbols
, blocks
, n_matches
, n_matches
);
4451 selected
.sals
= (struct symtab_and_line
*)
4452 xmalloc (sizeof (struct symtab_and_line
) * selected
.nelts
);
4453 memset (selected
.sals
, 0, selected
.nelts
* sizeof (selected
.sals
[i
]));
4454 make_cleanup (xfree
, selected
.sals
);
4457 while (i
< selected
.nelts
)
4459 if (SYMBOL_CLASS (symbols
[i
]) == LOC_BLOCK
)
4460 selected
.sals
[i
] = find_function_start_sal (symbols
[i
], funfirstline
);
4461 else if (SYMBOL_LINE (symbols
[i
]) != 0)
4463 selected
.sals
[i
].symtab
= symtab_for_sym (symbols
[i
]);
4464 selected
.sals
[i
].line
= SYMBOL_LINE (symbols
[i
]);
4466 else if (line_num
>= 0)
4468 /* Ignore this choice */
4469 symbols
[i
] = symbols
[selected
.nelts
- 1];
4470 blocks
[i
] = blocks
[selected
.nelts
- 1];
4471 selected
.nelts
-= 1;
4475 error ("Line number not known for symbol \"%s\"", unquoted_name
);
4479 if (canonical
!= NULL
&& (line_num
>= 0 || n_matches
> 1))
4481 *canonical
= (char **) xmalloc (sizeof (char *) * selected
.nelts
);
4482 for (i
= 0; i
< selected
.nelts
; i
+= 1)
4484 extended_canonical_line_spec (selected
.sals
[i
],
4485 SYMBOL_PRINT_NAME (symbols
[i
]));
4488 discard_cleanups (old_chain
);
4492 /* The (single) sal corresponding to line LINE_NUM in a symbol table
4493 with file name FILENAME that occurs in one of the functions listed
4494 in SYMBOLS[0 .. NSYMS-1]. */
4495 static struct symtabs_and_lines
4496 find_sal_from_funcs_and_line (const char *filename
, int line_num
,
4497 struct symbol
**symbols
, int nsyms
)
4499 struct symtabs_and_lines sals
;
4500 int best_index
, best
;
4501 struct linetable
*best_linetable
;
4502 struct objfile
*objfile
;
4504 struct symtab
*best_symtab
;
4506 read_all_symtabs (filename
);
4509 best_linetable
= NULL
;
4512 ALL_SYMTABS (objfile
, s
)
4514 struct linetable
*l
;
4519 if (!STREQ (filename
, s
->filename
))
4522 ind
= find_line_in_linetable (l
, line_num
, symbols
, nsyms
, &exact
);
4532 if (best
== 0 || l
->item
[ind
].line
< best
)
4534 best
= l
->item
[ind
].line
;
4543 error ("Line number not found in designated function.");
4548 sals
.sals
= (struct symtab_and_line
*) xmalloc (sizeof (sals
.sals
[0]));
4550 init_sal (&sals
.sals
[0]);
4552 sals
.sals
[0].line
= best_linetable
->item
[best_index
].line
;
4553 sals
.sals
[0].pc
= best_linetable
->item
[best_index
].pc
;
4554 sals
.sals
[0].symtab
= best_symtab
;
4559 /* Return the index in LINETABLE of the best match for LINE_NUM whose
4560 pc falls within one of the functions denoted by SYMBOLS[0..NSYMS-1].
4561 Set *EXACTP to the 1 if the match is exact, and 0 otherwise. */
4563 find_line_in_linetable (struct linetable
*linetable
, int line_num
,
4564 struct symbol
**symbols
, int nsyms
, int *exactp
)
4566 int i
, len
, best_index
, best
;
4568 if (line_num
<= 0 || linetable
== NULL
)
4571 len
= linetable
->nitems
;
4572 for (i
= 0, best_index
= -1, best
= 0; i
< len
; i
+= 1)
4575 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4577 for (k
= 0; k
< nsyms
; k
+= 1)
4579 if (symbols
[k
] != NULL
&& SYMBOL_CLASS (symbols
[k
]) == LOC_BLOCK
4580 && item
->pc
>= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols
[k
]))
4581 && item
->pc
< BLOCK_END (SYMBOL_BLOCK_VALUE (symbols
[k
])))
4588 if (item
->line
== line_num
)
4594 if (item
->line
> line_num
&& (best
== 0 || item
->line
< best
))
4605 /* Find the smallest k >= LINE_NUM such that k is a line number in
4606 LINETABLE, and k falls strictly within a named function that begins at
4607 or before LINE_NUM. Return -1 if there is no such k. */
4609 nearest_line_number_in_linetable (struct linetable
*linetable
, int line_num
)
4613 if (line_num
<= 0 || linetable
== NULL
|| linetable
->nitems
== 0)
4615 len
= linetable
->nitems
;
4622 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4624 if (item
->line
>= line_num
&& item
->line
< best
)
4627 CORE_ADDR start
, end
;
4630 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4632 if (func_name
!= NULL
&& item
->pc
< end
)
4634 if (item
->line
== line_num
)
4638 struct symbol
*sym
=
4639 standard_lookup (func_name
, VAR_DOMAIN
);
4640 if (is_plausible_func_for_line (sym
, line_num
))
4646 while (i
< len
&& linetable
->item
[i
].pc
< end
);
4656 return (best
== INT_MAX
) ? -1 : best
;
4660 /* Return the next higher index, k, into LINETABLE such that k > IND,
4661 entry k in LINETABLE has a line number equal to LINE_NUM, k
4662 corresponds to a PC that is in a function different from that
4663 corresponding to IND, and falls strictly within a named function
4664 that begins at a line at or preceding STARTING_LINE.
4665 Return -1 if there is no such k.
4666 IND == -1 corresponds to no function. */
4669 find_next_line_in_linetable (struct linetable
*linetable
, int line_num
,
4670 int starting_line
, int ind
)
4674 if (line_num
<= 0 || linetable
== NULL
|| ind
>= linetable
->nitems
)
4676 len
= linetable
->nitems
;
4680 CORE_ADDR start
, end
;
4682 if (find_pc_partial_function (linetable
->item
[ind
].pc
,
4683 (char **) NULL
, &start
, &end
))
4685 while (ind
< len
&& linetable
->item
[ind
].pc
< end
)
4698 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4700 if (item
->line
>= line_num
)
4703 CORE_ADDR start
, end
;
4706 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4708 if (func_name
!= NULL
&& item
->pc
< end
)
4710 if (item
->line
== line_num
)
4712 struct symbol
*sym
=
4713 standard_lookup (func_name
, VAR_DOMAIN
);
4714 if (is_plausible_func_for_line (sym
, starting_line
))
4718 while ((i
+ 1) < len
&& linetable
->item
[i
+ 1].pc
< end
)
4730 /* True iff function symbol SYM starts somewhere at or before line #
4733 is_plausible_func_for_line (struct symbol
*sym
, int line_num
)
4735 struct symtab_and_line start_sal
;
4740 start_sal
= find_function_start_sal (sym
, 0);
4742 return (start_sal
.line
!= 0 && line_num
>= start_sal
.line
);
4746 debug_print_lines (struct linetable
*lt
)
4753 fprintf (stderr
, "\t");
4754 for (i
= 0; i
< lt
->nitems
; i
+= 1)
4755 fprintf (stderr
, "(%d->%p) ", lt
->item
[i
].line
, (void *) lt
->item
[i
].pc
);
4756 fprintf (stderr
, "\n");
4760 debug_print_block (struct block
*b
)
4765 fprintf (stderr
, "Block: %p; [0x%lx, 0x%lx]",
4766 b
, BLOCK_START (b
), BLOCK_END (b
));
4767 if (BLOCK_FUNCTION (b
) != NULL
)
4768 fprintf (stderr
, " Function: %s", DEPRECATED_SYMBOL_NAME (BLOCK_FUNCTION (b
)));
4769 fprintf (stderr
, "\n");
4770 fprintf (stderr
, "\t Superblock: %p\n", BLOCK_SUPERBLOCK (b
));
4771 fprintf (stderr
, "\t Symbols:");
4772 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4774 if (i
> 0 && i
% 4 == 0)
4775 fprintf (stderr
, "\n\t\t ");
4776 fprintf (stderr
, " %s", DEPRECATED_SYMBOL_NAME (sym
));
4778 fprintf (stderr
, "\n");
4782 debug_print_blocks (struct blockvector
*bv
)
4788 for (i
= 0; i
< BLOCKVECTOR_NBLOCKS (bv
); i
+= 1)
4790 fprintf (stderr
, "%6d. ", i
);
4791 debug_print_block (BLOCKVECTOR_BLOCK (bv
, i
));
4796 debug_print_symtab (struct symtab
*s
)
4798 fprintf (stderr
, "Symtab %p\n File: %s; Dir: %s\n", s
,
4799 s
->filename
, s
->dirname
);
4800 fprintf (stderr
, " Blockvector: %p, Primary: %d\n",
4801 BLOCKVECTOR (s
), s
->primary
);
4802 debug_print_blocks (BLOCKVECTOR (s
));
4803 fprintf (stderr
, " Line table: %p\n", LINETABLE (s
));
4804 debug_print_lines (LINETABLE (s
));
4807 /* Read in all symbol tables corresponding to partial symbol tables
4808 with file name FILENAME. */
4810 read_all_symtabs (const char *filename
)
4812 struct partial_symtab
*ps
;
4813 struct objfile
*objfile
;
4815 ALL_PSYMTABS (objfile
, ps
)
4819 if (STREQ (filename
, ps
->filename
))
4820 PSYMTAB_TO_SYMTAB (ps
);
4824 /* All sals corresponding to line LINE_NUM in a symbol table from file
4825 FILENAME, as filtered by the user. If CANONICAL is not null, set
4826 it to a corresponding array of canonical line specs. */
4827 static struct symtabs_and_lines
4828 all_sals_for_line (const char *filename
, int line_num
, char ***canonical
)
4830 struct symtabs_and_lines result
;
4831 struct objfile
*objfile
;
4833 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4836 read_all_symtabs (filename
);
4839 (struct symtab_and_line
*) xmalloc (4 * sizeof (result
.sals
[0]));
4842 make_cleanup (free_current_contents
, &result
.sals
);
4844 ALL_SYMTABS (objfile
, s
)
4846 int ind
, target_line_num
;
4850 if (!STREQ (s
->filename
, filename
))
4854 nearest_line_number_in_linetable (LINETABLE (s
), line_num
);
4855 if (target_line_num
== -1)
4862 find_next_line_in_linetable (LINETABLE (s
),
4863 target_line_num
, line_num
, ind
);
4868 GROW_VECT (result
.sals
, len
, result
.nelts
+ 1);
4869 init_sal (&result
.sals
[result
.nelts
]);
4870 result
.sals
[result
.nelts
].line
= LINETABLE (s
)->item
[ind
].line
;
4871 result
.sals
[result
.nelts
].pc
= LINETABLE (s
)->item
[ind
].pc
;
4872 result
.sals
[result
.nelts
].symtab
= s
;
4877 if (canonical
!= NULL
|| result
.nelts
> 1)
4880 char **func_names
= (char **) alloca (result
.nelts
* sizeof (char *));
4881 int first_choice
= (result
.nelts
> 1) ? 2 : 1;
4883 int *choices
= (int *) alloca (result
.nelts
* sizeof (int));
4885 for (k
= 0; k
< result
.nelts
; k
+= 1)
4887 find_pc_partial_function (result
.sals
[k
].pc
, &func_names
[k
],
4888 (CORE_ADDR
*) NULL
, (CORE_ADDR
*) NULL
);
4889 if (func_names
[k
] == NULL
)
4890 error ("Could not find function for one or more breakpoints.");
4893 if (result
.nelts
> 1)
4895 printf_unfiltered ("[0] cancel\n");
4896 if (result
.nelts
> 1)
4897 printf_unfiltered ("[1] all\n");
4898 for (k
= 0; k
< result
.nelts
; k
+= 1)
4899 printf_unfiltered ("[%d] %s\n", k
+ first_choice
,
4900 ada_demangle (func_names
[k
]));
4902 n
= get_selections (choices
, result
.nelts
, result
.nelts
,
4903 result
.nelts
> 1, "instance-choice");
4905 for (k
= 0; k
< n
; k
+= 1)
4907 result
.sals
[k
] = result
.sals
[choices
[k
]];
4908 func_names
[k
] = func_names
[choices
[k
]];
4913 if (canonical
!= NULL
)
4915 *canonical
= (char **) xmalloc (result
.nelts
* sizeof (char **));
4916 make_cleanup (xfree
, *canonical
);
4917 for (k
= 0; k
< result
.nelts
; k
+= 1)
4920 extended_canonical_line_spec (result
.sals
[k
], func_names
[k
]);
4921 if ((*canonical
)[k
] == NULL
)
4922 error ("Could not locate one or more breakpoints.");
4923 make_cleanup (xfree
, (*canonical
)[k
]);
4928 discard_cleanups (old_chain
);
4933 /* A canonical line specification of the form FILE:NAME:LINENUM for
4934 symbol table and line data SAL. NULL if insufficient
4935 information. The caller is responsible for releasing any space
4939 extended_canonical_line_spec (struct symtab_and_line sal
, const char *name
)
4943 if (sal
.symtab
== NULL
|| sal
.symtab
->filename
== NULL
|| sal
.line
<= 0)
4946 r
= (char *) xmalloc (strlen (name
) + strlen (sal
.symtab
->filename
)
4947 + sizeof (sal
.line
) * 3 + 3);
4948 sprintf (r
, "%s:'%s':%d", sal
.symtab
->filename
, name
, sal
.line
);
4953 int begin_bnum
= -1;
4955 int begin_annotate_level
= 0;
4958 begin_cleanup (void *dummy
)
4960 begin_annotate_level
= 0;
4964 begin_command (char *args
, int from_tty
)
4966 struct minimal_symbol
*msym
;
4967 CORE_ADDR main_program_name_addr
;
4968 char main_program_name
[1024];
4969 struct cleanup
*old_chain
= make_cleanup (begin_cleanup
, NULL
);
4970 begin_annotate_level
= 2;
4972 /* Check that there is a program to debug */
4973 if (!have_full_symbols () && !have_partial_symbols ())
4974 error ("No symbol table is loaded. Use the \"file\" command.");
4976 /* Check that we are debugging an Ada program */
4977 /* if (ada_update_initial_language (language_unknown, NULL) != language_ada)
4978 error ("Cannot find the Ada initialization procedure. Is this an Ada main program?");
4980 /* FIXME: language_ada should be defined in defs.h */
4982 /* Get the address of the name of the main procedure */
4983 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
4987 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
4988 if (main_program_name_addr
== 0)
4989 error ("Invalid address for Ada main program name.");
4991 /* Read the name of the main procedure */
4992 extract_string (main_program_name_addr
, main_program_name
);
4994 /* Put a temporary breakpoint in the Ada main program and run */
4995 do_command ("tbreak ", main_program_name
, 0);
4996 do_command ("run ", args
, 0);
5000 /* If we could not find the symbol containing the name of the
5001 main program, that means that the compiler that was used to build
5002 was not recent enough. In that case, we fallback to the previous
5003 mechanism, which is a little bit less reliable, but has proved to work
5004 in most cases. The only cases where it will fail is when the user
5005 has set some breakpoints which will be hit before the end of the
5006 begin command processing (eg in the initialization code).
5008 The begining of the main Ada subprogram is located by breaking
5009 on the adainit procedure. Since we know that the binder generates
5010 the call to this procedure exactly 2 calls before the call to the
5011 Ada main subprogram, it is then easy to put a breakpoint on this
5012 Ada main subprogram once we hit adainit.
5014 do_command ("tbreak adainit", 0);
5015 do_command ("run ", args
, 0);
5016 do_command ("up", 0);
5017 do_command ("tbreak +2", 0);
5018 do_command ("continue", 0);
5019 do_command ("step", 0);
5022 do_cleanups (old_chain
);
5026 is_ada_runtime_file (char *filename
)
5028 return (STREQN (filename
, "s-", 2) ||
5029 STREQN (filename
, "a-", 2) ||
5030 STREQN (filename
, "g-", 2) || STREQN (filename
, "i-", 2));
5033 /* find the first frame that contains debugging information and that is not
5034 part of the Ada run-time, starting from fi and moving upward. */
5037 find_printable_frame (struct frame_info
*fi
, int level
)
5039 struct symtab_and_line sal
;
5041 for (; fi
!= NULL
; level
+= 1, fi
= get_prev_frame (fi
))
5043 find_frame_sal (fi
, &sal
);
5044 if (sal
.symtab
&& !is_ada_runtime_file (sal
.symtab
->filename
))
5046 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
5047 /* libpthread.so contains some debugging information that prevents us
5048 from finding the right frame */
5050 if (sal
.symtab
->objfile
&&
5051 STREQ (sal
.symtab
->objfile
->name
, "/usr/shlib/libpthread.so"))
5054 deprecated_selected_frame
= fi
;
5063 ada_report_exception_break (struct breakpoint
*b
)
5065 /* FIXME: break_on_exception should be defined in breakpoint.h */
5066 /* if (b->break_on_exception == 1)
5068 /* Assume that cond has 16 elements, the 15th
5069 being the exception *//*
5070 if (b->cond && b->cond->nelts == 16)
5072 ui_out_text (uiout, "on ");
5073 ui_out_field_string (uiout, "exception",
5074 SYMBOL_NAME (b->cond->elts[14].symbol));
5077 ui_out_text (uiout, "on all exceptions");
5079 else if (b->break_on_exception == 2)
5080 ui_out_text (uiout, "on unhandled exception");
5081 else if (b->break_on_exception == 3)
5082 ui_out_text (uiout, "on assert failure");
5084 if (b->break_on_exception == 1)
5086 /* Assume that cond has 16 elements, the 15th
5087 being the exception *//*
5088 if (b->cond && b->cond->nelts == 16)
5090 fputs_filtered ("on ", gdb_stdout);
5091 fputs_filtered (SYMBOL_NAME
5092 (b->cond->elts[14].symbol), gdb_stdout);
5095 fputs_filtered ("on all exceptions", gdb_stdout);
5097 else if (b->break_on_exception == 2)
5098 fputs_filtered ("on unhandled exception", gdb_stdout);
5099 else if (b->break_on_exception == 3)
5100 fputs_filtered ("on assert failure", gdb_stdout);
5105 ada_is_exception_sym (struct symbol
*sym
)
5107 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
5109 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5110 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5111 && SYMBOL_CLASS (sym
) != LOC_CONST
5112 && type_name
!= NULL
&& STREQ (type_name
, "exception"));
5116 ada_maybe_exception_partial_symbol (struct partial_symbol
*sym
)
5118 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5119 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5120 && SYMBOL_CLASS (sym
) != LOC_CONST
);
5123 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5124 into equivalent form. Return resulting argument string. Set
5125 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5126 break on unhandled, 3 for assert, 0 otherwise. */
5128 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
5132 *break_on_exceptionp
= 0;
5133 /* FIXME: language_ada should be defined in defs.h */
5134 /* if (current_language->la_language == language_ada
5135 && STREQN (arg, "exception", 9) &&
5136 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5138 char *tok, *end_tok;
5141 *break_on_exceptionp = 1;
5144 while (*tok == ' ' || *tok == '\t')
5149 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5152 toklen = end_tok - tok;
5154 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5155 "long_integer(e) = long_integer(&)")
5157 make_cleanup (xfree, arg);
5159 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5160 else if (STREQN (tok, "unhandled", toklen))
5162 *break_on_exceptionp = 2;
5163 strcpy (arg, "__gnat_unhandled_exception");
5167 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5168 "long_integer(e) = long_integer(&%.*s)",
5172 else if (current_language->la_language == language_ada
5173 && STREQN (arg, "assert", 6) &&
5174 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5176 char *tok = arg + 6;
5178 *break_on_exceptionp = 3;
5181 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5182 + strlen (tok) + 1);
5183 make_cleanup (xfree, arg);
5184 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5193 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5194 to be invisible to users. */
5197 ada_is_ignored_field (struct type
*type
, int field_num
)
5199 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5203 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5204 return (name
== NULL
5205 || (name
[0] == '_' && !STREQN (name
, "_parent", 7)));
5209 /* True iff structure type TYPE has a tag field. */
5212 ada_is_tagged_type (struct type
*type
)
5214 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5217 return (ada_lookup_struct_elt_type (type
, "_tag", 1, NULL
) != NULL
);
5220 /* The type of the tag on VAL. */
5223 ada_tag_type (struct value
*val
)
5225 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 0, NULL
);
5228 /* The value of the tag on VAL. */
5231 ada_value_tag (struct value
*val
)
5233 return ada_value_struct_elt (val
, "_tag", "record");
5236 /* The parent type of TYPE, or NULL if none. */
5239 ada_parent_type (struct type
*type
)
5243 CHECK_TYPEDEF (type
);
5245 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5248 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5249 if (ada_is_parent_field (type
, i
))
5250 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5255 /* True iff field number FIELD_NUM of structure type TYPE contains the
5256 parent-type (inherited) fields of a derived type. Assumes TYPE is
5257 a structure type with at least FIELD_NUM+1 fields. */
5260 ada_is_parent_field (struct type
*type
, int field_num
)
5262 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
5263 return (name
!= NULL
&&
5264 (STREQN (name
, "PARENT", 6) || STREQN (name
, "_parent", 7)));
5267 /* True iff field number FIELD_NUM of structure type TYPE is a
5268 transparent wrapper field (which should be silently traversed when doing
5269 field selection and flattened when printing). Assumes TYPE is a
5270 structure type with at least FIELD_NUM+1 fields. Such fields are always
5274 ada_is_wrapper_field (struct type
*type
, int field_num
)
5276 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5277 return (name
!= NULL
5278 && (STREQN (name
, "PARENT", 6) || STREQ (name
, "REP")
5279 || STREQN (name
, "_parent", 7)
5280 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5283 /* True iff field number FIELD_NUM of structure or union type TYPE
5284 is a variant wrapper. Assumes TYPE is a structure type with at least
5285 FIELD_NUM+1 fields. */
5288 ada_is_variant_part (struct type
*type
, int field_num
)
5290 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5291 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5292 || (is_dynamic_field (type
, field_num
)
5293 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) ==
5297 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5298 whose discriminants are contained in the record type OUTER_TYPE,
5299 returns the type of the controlling discriminant for the variant. */
5302 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5304 char *name
= ada_variant_discrim_name (var_type
);
5305 struct type
*type
= ada_lookup_struct_elt_type (outer_type
, name
, 1, NULL
);
5307 return builtin_type_int
;
5312 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5313 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5314 represents a 'when others' clause; otherwise 0. */
5317 ada_is_others_clause (struct type
*type
, int field_num
)
5319 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5320 return (name
!= NULL
&& name
[0] == 'O');
5323 /* Assuming that TYPE0 is the type of the variant part of a record,
5324 returns the name of the discriminant controlling the variant. The
5325 value is valid until the next call to ada_variant_discrim_name. */
5328 ada_variant_discrim_name (struct type
*type0
)
5330 static char *result
= NULL
;
5331 static size_t result_len
= 0;
5334 const char *discrim_end
;
5335 const char *discrim_start
;
5337 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5338 type
= TYPE_TARGET_TYPE (type0
);
5342 name
= ada_type_name (type
);
5344 if (name
== NULL
|| name
[0] == '\000')
5347 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5350 if (STREQN (discrim_end
, "___XVN", 6))
5353 if (discrim_end
== name
)
5356 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5359 if (discrim_start
== name
+ 1)
5361 if ((discrim_start
> name
+ 3 && STREQN (discrim_start
- 3, "___", 3))
5362 || discrim_start
[-1] == '.')
5366 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5367 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5368 result
[discrim_end
- discrim_start
] = '\0';
5372 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5373 position of the character just past the number scanned in *NEW_K,
5374 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5375 if there was a valid number at the given position, and 0 otherwise. A
5376 "subtype-encoded" number consists of the absolute value in decimal,
5377 followed by the letter 'm' to indicate a negative number. Assumes 0m
5381 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5385 if (!isdigit (str
[k
]))
5388 /* Do it the hard way so as not to make any assumption about
5389 the relationship of unsigned long (%lu scan format code) and
5392 while (isdigit (str
[k
]))
5394 RU
= RU
* 10 + (str
[k
] - '0');
5401 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5407 /* NOTE on the above: Technically, C does not say what the results of
5408 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5409 number representable as a LONGEST (although either would probably work
5410 in most implementations). When RU>0, the locution in the then branch
5411 above is always equivalent to the negative of RU. */
5418 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5419 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5420 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5423 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5425 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5438 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5447 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5448 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5450 if (val
>= L
&& val
<= U
)
5462 /* Given a value ARG1 (offset by OFFSET bytes)
5463 of a struct or union type ARG_TYPE,
5464 extract and return the value of one of its (non-static) fields.
5465 FIELDNO says which field. Differs from value_primitive_field only
5466 in that it can handle packed values of arbitrary type. */
5469 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5470 struct type
*arg_type
)
5475 CHECK_TYPEDEF (arg_type
);
5476 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5478 /* Handle packed fields */
5480 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5482 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5483 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5485 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5486 offset
+ bit_pos
/ 8,
5487 bit_pos
% 8, bit_size
, type
);
5490 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5494 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5495 and search in it assuming it has (class) type TYPE.
5496 If found, return value, else return NULL.
5498 Searches recursively through wrapper fields (e.g., '_parent'). */
5501 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5505 CHECK_TYPEDEF (type
);
5507 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5509 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5511 if (t_field_name
== NULL
)
5514 else if (field_name_match (t_field_name
, name
))
5515 return ada_value_primitive_field (arg
, offset
, i
, type
);
5517 else if (ada_is_wrapper_field (type
, i
))
5519 struct value
*v
= ada_search_struct_field (name
, arg
,
5521 TYPE_FIELD_BITPOS (type
,
5524 TYPE_FIELD_TYPE (type
,
5530 else if (ada_is_variant_part (type
, i
))
5533 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5534 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5536 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5538 struct value
*v
= ada_search_struct_field (name
, arg
,
5542 (field_type
, j
) / 8,
5553 /* Given ARG, a value of type (pointer to a)* structure/union,
5554 extract the component named NAME from the ultimate target structure/union
5555 and return it as a value with its appropriate type.
5557 The routine searches for NAME among all members of the structure itself
5558 and (recursively) among all members of any wrapper members
5561 ERR is a name (for use in error messages) that identifies the class
5562 of entity that ARG is supposed to be. */
5565 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5570 arg
= ada_coerce_ref (arg
);
5571 t
= check_typedef (VALUE_TYPE (arg
));
5573 /* Follow pointers until we get to a non-pointer. */
5575 while (TYPE_CODE (t
) == TYPE_CODE_PTR
|| TYPE_CODE (t
) == TYPE_CODE_REF
)
5577 arg
= ada_value_ind (arg
);
5578 t
= check_typedef (VALUE_TYPE (arg
));
5581 if (TYPE_CODE (t
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t
) != TYPE_CODE_UNION
)
5582 error ("Attempt to extract a component of a value that is not a %s.",
5585 v
= ada_search_struct_field (name
, arg
, 0, t
);
5587 error ("There is no member named %s.", name
);
5592 /* Given a type TYPE, look up the type of the component of type named NAME.
5593 If DISPP is non-null, add its byte displacement from the beginning of a
5594 structure (pointed to by a value) of type TYPE to *DISPP (does not
5595 work for packed fields).
5597 Matches any field whose name has NAME as a prefix, possibly
5600 TYPE can be either a struct or union, or a pointer or reference to
5601 a struct or union. If it is a pointer or reference, its target
5602 type is automatically used.
5604 Looks recursively into variant clauses and parent types.
5606 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5609 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int noerr
,
5619 CHECK_TYPEDEF (type
);
5620 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5621 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5623 type
= TYPE_TARGET_TYPE (type
);
5626 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
&&
5627 TYPE_CODE (type
) != TYPE_CODE_UNION
)
5629 target_terminal_ours ();
5630 gdb_flush (gdb_stdout
);
5631 fprintf_unfiltered (gdb_stderr
, "Type ");
5632 type_print (type
, "", gdb_stderr
, -1);
5633 error (" is not a structure or union type");
5636 type
= to_static_fixed_type (type
);
5638 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5640 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5644 if (t_field_name
== NULL
)
5647 else if (field_name_match (t_field_name
, name
))
5650 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5651 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5654 else if (ada_is_wrapper_field (type
, i
))
5657 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5662 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5667 else if (ada_is_variant_part (type
, i
))
5670 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5672 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5675 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5680 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5691 target_terminal_ours ();
5692 gdb_flush (gdb_stdout
);
5693 fprintf_unfiltered (gdb_stderr
, "Type ");
5694 type_print (type
, "", gdb_stderr
, -1);
5695 fprintf_unfiltered (gdb_stderr
, " has no component named ");
5696 error ("%s", name
== NULL
? "<null>" : name
);
5702 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5703 within a value of type OUTER_TYPE that is stored in GDB at
5704 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5705 numbering from 0) is applicable. Returns -1 if none are. */
5708 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5709 char *outer_valaddr
)
5714 struct type
*discrim_type
;
5715 char *discrim_name
= ada_variant_discrim_name (var_type
);
5716 LONGEST discrim_val
;
5720 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, &disp
);
5721 if (discrim_type
== NULL
)
5723 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5726 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5728 if (ada_is_others_clause (var_type
, i
))
5730 else if (ada_in_variant (discrim_val
, var_type
, i
))
5734 return others_clause
;
5739 /* Dynamic-Sized Records */
5741 /* Strategy: The type ostensibly attached to a value with dynamic size
5742 (i.e., a size that is not statically recorded in the debugging
5743 data) does not accurately reflect the size or layout of the value.
5744 Our strategy is to convert these values to values with accurate,
5745 conventional types that are constructed on the fly. */
5747 /* There is a subtle and tricky problem here. In general, we cannot
5748 determine the size of dynamic records without its data. However,
5749 the 'struct value' data structure, which GDB uses to represent
5750 quantities in the inferior process (the target), requires the size
5751 of the type at the time of its allocation in order to reserve space
5752 for GDB's internal copy of the data. That's why the
5753 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5754 rather than struct value*s.
5756 However, GDB's internal history variables ($1, $2, etc.) are
5757 struct value*s containing internal copies of the data that are not, in
5758 general, the same as the data at their corresponding addresses in
5759 the target. Fortunately, the types we give to these values are all
5760 conventional, fixed-size types (as per the strategy described
5761 above), so that we don't usually have to perform the
5762 'to_fixed_xxx_type' conversions to look at their values.
5763 Unfortunately, there is one exception: if one of the internal
5764 history variables is an array whose elements are unconstrained
5765 records, then we will need to create distinct fixed types for each
5766 element selected. */
5768 /* The upshot of all of this is that many routines take a (type, host
5769 address, target address) triple as arguments to represent a value.
5770 The host address, if non-null, is supposed to contain an internal
5771 copy of the relevant data; otherwise, the program is to consult the
5772 target at the target address. */
5774 /* Assuming that VAL0 represents a pointer value, the result of
5775 dereferencing it. Differs from value_ind in its treatment of
5776 dynamic-sized types. */
5779 ada_value_ind (struct value
*val0
)
5781 struct value
*val
= unwrap_value (value_ind (val0
));
5782 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5783 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
), val
);
5786 /* The value resulting from dereferencing any "reference to"
5787 * qualifiers on VAL0. */
5788 static struct value
*
5789 ada_coerce_ref (struct value
*val0
)
5791 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
5793 struct value
*val
= val0
;
5795 val
= unwrap_value (val
);
5796 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5797 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
5804 /* Return OFF rounded upward if necessary to a multiple of
5805 ALIGNMENT (a power of 2). */
5808 align_value (unsigned int off
, unsigned int alignment
)
5810 return (off
+ alignment
- 1) & ~(alignment
- 1);
5813 /* Return the additional bit offset required by field F of template
5817 field_offset (struct type
*type
, int f
)
5819 int n
= TYPE_FIELD_BITPOS (type
, f
);
5820 /* Kludge (temporary?) to fix problem with dwarf output. */
5822 return (unsigned int) n
& 0xffff;
5828 /* Return the bit alignment required for field #F of template type TYPE. */
5831 field_alignment (struct type
*type
, int f
)
5833 const char *name
= TYPE_FIELD_NAME (type
, f
);
5834 int len
= (name
== NULL
) ? 0 : strlen (name
);
5837 if (len
< 8 || !isdigit (name
[len
- 1]))
5838 return TARGET_CHAR_BIT
;
5840 if (isdigit (name
[len
- 2]))
5841 align_offset
= len
- 2;
5843 align_offset
= len
- 1;
5845 if (align_offset
< 7 || !STREQN ("___XV", name
+ align_offset
- 6, 5))
5846 return TARGET_CHAR_BIT
;
5848 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5851 /* Find a type named NAME. Ignores ambiguity. */
5853 ada_find_any_type (const char *name
)
5857 sym
= standard_lookup (name
, VAR_DOMAIN
);
5858 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5859 return SYMBOL_TYPE (sym
);
5861 sym
= standard_lookup (name
, STRUCT_DOMAIN
);
5863 return SYMBOL_TYPE (sym
);
5868 /* Because of GNAT encoding conventions, several GDB symbols may match a
5869 given type name. If the type denoted by TYPE0 is to be preferred to
5870 that of TYPE1 for purposes of type printing, return non-zero;
5871 otherwise return 0. */
5873 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5877 else if (type0
== NULL
)
5879 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5881 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5883 else if (ada_is_packed_array_type (type0
))
5885 else if (ada_is_array_descriptor (type0
)
5886 && !ada_is_array_descriptor (type1
))
5888 else if (ada_renaming_type (type0
) != NULL
5889 && ada_renaming_type (type1
) == NULL
)
5894 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5895 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5897 ada_type_name (struct type
*type
)
5901 else if (TYPE_NAME (type
) != NULL
)
5902 return TYPE_NAME (type
);
5904 return TYPE_TAG_NAME (type
);
5907 /* Find a parallel type to TYPE whose name is formed by appending
5908 SUFFIX to the name of TYPE. */
5911 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5914 static size_t name_len
= 0;
5915 struct symbol
**syms
;
5916 struct block
**blocks
;
5919 char *typename
= ada_type_name (type
);
5921 if (typename
== NULL
)
5924 len
= strlen (typename
);
5926 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5928 strcpy (name
, typename
);
5929 strcpy (name
+ len
, suffix
);
5931 return ada_find_any_type (name
);
5935 /* If TYPE is a variable-size record type, return the corresponding template
5936 type describing its fields. Otherwise, return NULL. */
5938 static struct type
*
5939 dynamic_template_type (struct type
*type
)
5941 CHECK_TYPEDEF (type
);
5943 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5944 || ada_type_name (type
) == NULL
)
5948 int len
= strlen (ada_type_name (type
));
5949 if (len
> 6 && STREQ (ada_type_name (type
) + len
- 6, "___XVE"))
5952 return ada_find_parallel_type (type
, "___XVE");
5956 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5957 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5960 is_dynamic_field (struct type
*templ_type
, int field_num
)
5962 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5964 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5965 && strstr (name
, "___XVL") != NULL
;
5968 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
5969 contains a variant part. */
5972 contains_variant_part (struct type
*type
)
5976 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5977 || TYPE_NFIELDS (type
) <= 0)
5979 return ada_is_variant_part (type
, TYPE_NFIELDS (type
) - 1);
5982 /* A record type with no fields, . */
5983 static struct type
*
5984 empty_record (struct objfile
*objfile
)
5986 struct type
*type
= alloc_type (objfile
);
5987 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
5988 TYPE_NFIELDS (type
) = 0;
5989 TYPE_FIELDS (type
) = NULL
;
5990 TYPE_NAME (type
) = "<empty>";
5991 TYPE_TAG_NAME (type
) = NULL
;
5992 TYPE_FLAGS (type
) = 0;
5993 TYPE_LENGTH (type
) = 0;
5997 /* An ordinary record type (with fixed-length fields) that describes
5998 the value of type TYPE at VALADDR or ADDRESS (see comments at
5999 the beginning of this section) VAL according to GNAT conventions.
6000 DVAL0 should describe the (portion of a) record that contains any
6001 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
6002 an outer-level type (i.e., as opposed to a branch of a variant.) A
6003 variant field (unless unchecked) is replaced by a particular branch
6005 /* NOTE: Limitations: For now, we assume that dynamic fields and
6006 * variants occupy whole numbers of bytes. However, they need not be
6009 static struct type
*
6010 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
6011 CORE_ADDR address
, struct value
*dval0
)
6013 struct value
*mark
= value_mark ();
6016 int nfields
, bit_len
;
6020 nfields
= TYPE_NFIELDS (type
);
6021 rtype
= alloc_type (TYPE_OBJFILE (type
));
6022 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6023 INIT_CPLUS_SPECIFIC (rtype
);
6024 TYPE_NFIELDS (rtype
) = nfields
;
6025 TYPE_FIELDS (rtype
) = (struct field
*)
6026 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6027 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6028 TYPE_NAME (rtype
) = ada_type_name (type
);
6029 TYPE_TAG_NAME (rtype
) = NULL
;
6030 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
6032 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6036 for (f
= 0; f
< nfields
; f
+= 1)
6038 int fld_bit_len
, bit_incr
;
6041 field_alignment (type
, f
)) + TYPE_FIELD_BITPOS (type
, f
);
6042 /* NOTE: used to use field_offset above, but that causes
6043 * problems with really negative bit positions. So, let's
6044 * rediscover why we needed field_offset and fix it properly. */
6045 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6046 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6047 TYPE_FIELD_STATIC_KIND (rtype
, f
) = 0;
6049 if (ada_is_variant_part (type
, f
))
6051 struct type
*branch_type
;
6054 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6059 to_fixed_variant_branch_type
6060 (TYPE_FIELD_TYPE (type
, f
),
6061 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6062 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6063 if (branch_type
== NULL
)
6064 TYPE_NFIELDS (rtype
) -= 1;
6067 TYPE_FIELD_TYPE (rtype
, f
) = branch_type
;
6068 TYPE_FIELD_NAME (rtype
, f
) = "S";
6072 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6074 else if (is_dynamic_field (type
, f
))
6077 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6081 TYPE_FIELD_TYPE (rtype
, f
) =
6084 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6085 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6086 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6087 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6088 bit_incr
= fld_bit_len
=
6089 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6093 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6094 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6095 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6096 bit_incr
= fld_bit_len
=
6097 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6099 bit_incr
= fld_bit_len
=
6100 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6102 if (off
+ fld_bit_len
> bit_len
)
6103 bit_len
= off
+ fld_bit_len
;
6105 TYPE_LENGTH (rtype
) = bit_len
/ TARGET_CHAR_BIT
;
6107 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
6109 value_free_to_mark (mark
);
6110 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6111 error ("record type with dynamic size is larger than varsize-limit");
6115 /* As for template_to_fixed_record_type, but uses no run-time values.
6116 As a result, this type can only be approximate, but that's OK,
6117 since it is used only for type determinations. Works on both
6119 Representation note: to save space, we memoize the result of this
6120 function in the TYPE_TARGET_TYPE of the template type. */
6122 static struct type
*
6123 template_to_static_fixed_type (struct type
*templ_type
)
6129 if (TYPE_TARGET_TYPE (templ_type
) != NULL
)
6130 return TYPE_TARGET_TYPE (templ_type
);
6132 nfields
= TYPE_NFIELDS (templ_type
);
6133 TYPE_TARGET_TYPE (templ_type
) = type
=
6134 alloc_type (TYPE_OBJFILE (templ_type
));
6135 TYPE_CODE (type
) = TYPE_CODE (templ_type
);
6136 INIT_CPLUS_SPECIFIC (type
);
6137 TYPE_NFIELDS (type
) = nfields
;
6138 TYPE_FIELDS (type
) = (struct field
*)
6139 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6140 memset (TYPE_FIELDS (type
), 0, sizeof (struct field
) * nfields
);
6141 TYPE_NAME (type
) = ada_type_name (templ_type
);
6142 TYPE_TAG_NAME (type
) = NULL
;
6143 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6144 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6145 TYPE_LENGTH (type
) = 0;
6147 for (f
= 0; f
< nfields
; f
+= 1)
6149 TYPE_FIELD_BITPOS (type
, f
) = 0;
6150 TYPE_FIELD_BITSIZE (type
, f
) = 0;
6151 TYPE_FIELD_STATIC_KIND (type
, f
) = 0;
6153 if (is_dynamic_field (templ_type
, f
))
6155 TYPE_FIELD_TYPE (type
, f
) =
6156 to_static_fixed_type (TYPE_TARGET_TYPE
6157 (TYPE_FIELD_TYPE (templ_type
, f
)));
6158 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6162 TYPE_FIELD_TYPE (type
, f
) =
6163 check_typedef (TYPE_FIELD_TYPE (templ_type
, f
));
6164 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6171 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6172 part -- in which the variant part is replaced with the appropriate
6174 static struct type
*
6175 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6176 CORE_ADDR address
, struct value
*dval
)
6178 struct value
*mark
= value_mark ();
6180 struct type
*branch_type
;
6181 int nfields
= TYPE_NFIELDS (type
);
6186 rtype
= alloc_type (TYPE_OBJFILE (type
));
6187 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6188 INIT_CPLUS_SPECIFIC (type
);
6189 TYPE_NFIELDS (rtype
) = TYPE_NFIELDS (type
);
6190 TYPE_FIELDS (rtype
) =
6191 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6192 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6193 sizeof (struct field
) * nfields
);
6194 TYPE_NAME (rtype
) = ada_type_name (type
);
6195 TYPE_TAG_NAME (rtype
) = NULL
;
6196 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6197 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6198 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6201 to_fixed_variant_branch_type
6202 (TYPE_FIELD_TYPE (type
, nfields
- 1),
6203 cond_offset_host (valaddr
,
6204 TYPE_FIELD_BITPOS (type
,
6205 nfields
- 1) / TARGET_CHAR_BIT
),
6206 cond_offset_target (address
,
6207 TYPE_FIELD_BITPOS (type
,
6208 nfields
- 1) / TARGET_CHAR_BIT
),
6210 if (branch_type
== NULL
)
6212 TYPE_NFIELDS (rtype
) -= 1;
6213 TYPE_LENGTH (rtype
) -=
6214 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6218 TYPE_FIELD_TYPE (rtype
, nfields
- 1) = branch_type
;
6219 TYPE_FIELD_NAME (rtype
, nfields
- 1) = "S";
6220 TYPE_FIELD_BITSIZE (rtype
, nfields
- 1) = 0;
6221 TYPE_FIELD_STATIC_KIND (rtype
, nfields
- 1) = 0;
6222 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6223 -TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6229 /* An ordinary record type (with fixed-length fields) that describes
6230 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6231 beginning of this section]. Any necessary discriminants' values
6232 should be in DVAL, a record value; it should be NULL if the object
6233 at ADDR itself contains any necessary discriminant values. A
6234 variant field (unless unchecked) is replaced by a particular branch
6237 static struct type
*
6238 to_fixed_record_type (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6241 struct type
*templ_type
;
6243 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6244 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6247 templ_type
= dynamic_template_type (type0
);
6249 if (templ_type
!= NULL
)
6250 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6251 else if (contains_variant_part (type0
))
6252 return to_record_with_fixed_variant_part (type0
, valaddr
, address
, dval
);
6255 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6256 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6262 /* An ordinary record type (with fixed-length fields) that describes
6263 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6264 union type. Any necessary discriminants' values should be in DVAL,
6265 a record value. That is, this routine selects the appropriate
6266 branch of the union at ADDR according to the discriminant value
6267 indicated in the union's type name. */
6269 static struct type
*
6270 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6271 CORE_ADDR address
, struct value
*dval
)
6274 struct type
*templ_type
;
6275 struct type
*var_type
;
6277 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6278 var_type
= TYPE_TARGET_TYPE (var_type0
);
6280 var_type
= var_type0
;
6282 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6284 if (templ_type
!= NULL
)
6285 var_type
= templ_type
;
6288 ada_which_variant_applies (var_type
,
6289 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
6292 return empty_record (TYPE_OBJFILE (var_type
));
6293 else if (is_dynamic_field (var_type
, which
))
6295 to_fixed_record_type
6296 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6297 valaddr
, address
, dval
);
6298 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type
, which
)))
6300 to_fixed_record_type
6301 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6303 return TYPE_FIELD_TYPE (var_type
, which
);
6306 /* Assuming that TYPE0 is an array type describing the type of a value
6307 at ADDR, and that DVAL describes a record containing any
6308 discriminants used in TYPE0, returns a type for the value that
6309 contains no dynamic components (that is, no components whose sizes
6310 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6311 true, gives an error message if the resulting type's size is over
6315 static struct type
*
6316 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6319 struct type
*index_type_desc
;
6320 struct type
*result
;
6322 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6323 /* if (ada_is_packed_array_type (type0) /* revisit? *//*
6324 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6327 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6328 if (index_type_desc
== NULL
)
6330 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
6331 /* NOTE: elt_type---the fixed version of elt_type0---should never
6332 * depend on the contents of the array in properly constructed
6333 * debugging data. */
6334 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6336 if (elt_type0
== elt_type
)
6339 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6340 elt_type
, TYPE_INDEX_TYPE (type0
));
6345 struct type
*elt_type0
;
6348 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6349 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6351 /* NOTE: result---the fixed version of elt_type0---should never
6352 * depend on the contents of the array in properly constructed
6353 * debugging data. */
6354 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
6355 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6357 struct type
*range_type
=
6358 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6359 dval
, TYPE_OBJFILE (type0
));
6360 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6361 result
, range_type
);
6363 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6364 error ("array type with dynamic size is larger than varsize-limit");
6367 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6368 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6373 /* A standard type (containing no dynamically sized components)
6374 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6375 DVAL describes a record containing any discriminants used in TYPE0,
6376 and may be NULL if there are none. */
6379 ada_to_fixed_type (struct type
*type
, char *valaddr
, CORE_ADDR address
,
6382 CHECK_TYPEDEF (type
);
6383 switch (TYPE_CODE (type
))
6387 case TYPE_CODE_STRUCT
:
6388 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6389 case TYPE_CODE_ARRAY
:
6390 return to_fixed_array_type (type
, dval
, 0);
6391 case TYPE_CODE_UNION
:
6395 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6399 /* A standard (static-sized) type corresponding as well as possible to
6400 TYPE0, but based on no runtime data. */
6402 static struct type
*
6403 to_static_fixed_type (struct type
*type0
)
6410 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6411 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6414 CHECK_TYPEDEF (type0
);
6416 switch (TYPE_CODE (type0
))
6420 case TYPE_CODE_STRUCT
:
6421 type
= dynamic_template_type (type0
);
6423 return template_to_static_fixed_type (type
);
6425 case TYPE_CODE_UNION
:
6426 type
= ada_find_parallel_type (type0
, "___XVU");
6428 return template_to_static_fixed_type (type
);
6433 /* A static approximation of TYPE with all type wrappers removed. */
6434 static struct type
*
6435 static_unwrap_type (struct type
*type
)
6437 if (ada_is_aligner_type (type
))
6439 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
6440 if (ada_type_name (type1
) == NULL
)
6441 TYPE_NAME (type1
) = ada_type_name (type
);
6443 return static_unwrap_type (type1
);
6447 struct type
*raw_real_type
= ada_get_base_type (type
);
6448 if (raw_real_type
== type
)
6451 return to_static_fixed_type (raw_real_type
);
6455 /* In some cases, incomplete and private types require
6456 cross-references that are not resolved as records (for example,
6458 type FooP is access Foo;
6460 type Foo is array ...;
6461 ). In these cases, since there is no mechanism for producing
6462 cross-references to such types, we instead substitute for FooP a
6463 stub enumeration type that is nowhere resolved, and whose tag is
6464 the name of the actual type. Call these types "non-record stubs". */
6466 /* A type equivalent to TYPE that is not a non-record stub, if one
6467 exists, otherwise TYPE. */
6469 ada_completed_type (struct type
*type
)
6471 CHECK_TYPEDEF (type
);
6472 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6473 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6474 || TYPE_TAG_NAME (type
) == NULL
)
6478 char *name
= TYPE_TAG_NAME (type
);
6479 struct type
*type1
= ada_find_any_type (name
);
6480 return (type1
== NULL
) ? type
: type1
;
6484 /* A value representing the data at VALADDR/ADDRESS as described by
6485 type TYPE0, but with a standard (static-sized) type that correctly
6486 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6487 type, then return VAL0 [this feature is simply to avoid redundant
6488 creation of struct values]. */
6491 ada_to_fixed_value (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6494 struct type
*type
= ada_to_fixed_type (type0
, valaddr
, address
, NULL
);
6495 if (type
== type0
&& val0
!= NULL
)
6498 return value_from_contents_and_address (type
, valaddr
, address
);
6501 /* A value representing VAL, but with a standard (static-sized) type
6502 chosen to approximate the real type of VAL as well as possible, but
6503 without consulting any runtime values. For Ada dynamic-sized
6504 types, therefore, the type of the result is likely to be inaccurate. */
6507 ada_to_static_fixed_value (struct value
*val
)
6510 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
6511 if (type
== VALUE_TYPE (val
))
6514 return coerce_unspec_val_to_type (val
, 0, type
);
6523 /* Table mapping attribute numbers to names */
6524 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6526 static const char *attribute_names
[] = {
6543 ada_attribute_name (int n
)
6545 if (n
> 0 && n
< (int) ATR_END
)
6546 return attribute_names
[n
];
6548 return attribute_names
[0];
6551 /* Evaluate the 'POS attribute applied to ARG. */
6553 static struct value
*
6554 value_pos_atr (struct value
*arg
)
6556 struct type
*type
= VALUE_TYPE (arg
);
6558 if (!discrete_type_p (type
))
6559 error ("'POS only defined on discrete types");
6561 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6564 LONGEST v
= value_as_long (arg
);
6566 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6568 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6569 return value_from_longest (builtin_type_ada_int
, i
);
6571 error ("enumeration value is invalid: can't find 'POS");
6574 return value_from_longest (builtin_type_ada_int
, value_as_long (arg
));
6577 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6579 static struct value
*
6580 value_val_atr (struct type
*type
, struct value
*arg
)
6582 if (!discrete_type_p (type
))
6583 error ("'VAL only defined on discrete types");
6584 if (!integer_type_p (VALUE_TYPE (arg
)))
6585 error ("'VAL requires integral argument");
6587 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6589 long pos
= value_as_long (arg
);
6590 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6591 error ("argument to 'VAL out of range");
6592 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6595 return value_from_longest (type
, value_as_long (arg
));
6601 /* True if TYPE appears to be an Ada character type.
6602 * [At the moment, this is true only for Character and Wide_Character;
6603 * It is a heuristic test that could stand improvement]. */
6606 ada_is_character_type (struct type
*type
)
6608 const char *name
= ada_type_name (type
);
6611 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6612 || TYPE_CODE (type
) == TYPE_CODE_INT
6613 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6614 && (STREQ (name
, "character") || STREQ (name
, "wide_character")
6615 || STREQ (name
, "unsigned char"));
6618 /* True if TYPE appears to be an Ada string type. */
6621 ada_is_string_type (struct type
*type
)
6623 CHECK_TYPEDEF (type
);
6625 && TYPE_CODE (type
) != TYPE_CODE_PTR
6626 && (ada_is_simple_array (type
) || ada_is_array_descriptor (type
))
6627 && ada_array_arity (type
) == 1)
6629 struct type
*elttype
= ada_array_element_type (type
, 1);
6631 return ada_is_character_type (elttype
);
6638 /* True if TYPE is a struct type introduced by the compiler to force the
6639 alignment of a value. Such types have a single field with a
6640 distinctive name. */
6643 ada_is_aligner_type (struct type
*type
)
6645 CHECK_TYPEDEF (type
);
6646 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6647 && TYPE_NFIELDS (type
) == 1
6648 && STREQ (TYPE_FIELD_NAME (type
, 0), "F"));
6651 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6652 the parallel type. */
6655 ada_get_base_type (struct type
*raw_type
)
6657 struct type
*real_type_namer
;
6658 struct type
*raw_real_type
;
6659 struct type
*real_type
;
6661 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6664 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6665 if (real_type_namer
== NULL
6666 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6667 || TYPE_NFIELDS (real_type_namer
) != 1)
6670 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6671 if (raw_real_type
== NULL
)
6674 return raw_real_type
;
6677 /* The type of value designated by TYPE, with all aligners removed. */
6680 ada_aligned_type (struct type
*type
)
6682 if (ada_is_aligner_type (type
))
6683 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6685 return ada_get_base_type (type
);
6689 /* The address of the aligned value in an object at address VALADDR
6690 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6693 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6695 if (ada_is_aligner_type (type
))
6696 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6698 TYPE_FIELD_BITPOS (type
,
6699 0) / TARGET_CHAR_BIT
);
6704 /* The printed representation of an enumeration literal with encoded
6705 name NAME. The value is good to the next call of ada_enum_name. */
6707 ada_enum_name (const char *name
)
6713 if ((tmp
= strstr (name
, "__")) != NULL
)
6715 else if ((tmp
= strchr (name
, '.')) != NULL
)
6723 static char result
[16];
6725 if (name
[1] == 'U' || name
[1] == 'W')
6727 if (sscanf (name
+ 2, "%x", &v
) != 1)
6733 if (isascii (v
) && isprint (v
))
6734 sprintf (result
, "'%c'", v
);
6735 else if (name
[1] == 'U')
6736 sprintf (result
, "[\"%02x\"]", v
);
6738 sprintf (result
, "[\"%04x\"]", v
);
6746 static struct value
*
6747 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6750 return (*exp
->language_defn
->evaluate_exp
) (expect_type
, exp
, pos
, noside
);
6753 /* Evaluate the subexpression of EXP starting at *POS as for
6754 evaluate_type, updating *POS to point just past the evaluated
6757 static struct value
*
6758 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6760 return (*exp
->language_defn
->evaluate_exp
)
6761 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6764 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6767 static struct value
*
6768 unwrap_value (struct value
*val
)
6770 struct type
*type
= check_typedef (VALUE_TYPE (val
));
6771 if (ada_is_aligner_type (type
))
6773 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6774 NULL
, "internal structure");
6775 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
6776 if (ada_type_name (val_type
) == NULL
)
6777 TYPE_NAME (val_type
) = ada_type_name (type
);
6779 return unwrap_value (v
);
6783 struct type
*raw_real_type
=
6784 ada_completed_type (ada_get_base_type (type
));
6786 if (type
== raw_real_type
)
6790 coerce_unspec_val_to_type
6791 (val
, 0, ada_to_fixed_type (raw_real_type
, 0,
6792 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6797 static struct value
*
6798 cast_to_fixed (struct type
*type
, struct value
*arg
)
6802 if (type
== VALUE_TYPE (arg
))
6804 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
6805 val
= ada_float_to_fixed (type
,
6806 ada_fixed_to_float (VALUE_TYPE (arg
),
6807 value_as_long (arg
)));
6811 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
6812 val
= ada_float_to_fixed (type
, argd
);
6815 return value_from_longest (type
, val
);
6818 static struct value
*
6819 cast_from_fixed_to_double (struct value
*arg
)
6821 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
6822 value_as_long (arg
));
6823 return value_from_double (builtin_type_double
, val
);
6826 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6827 * return the converted value. */
6828 static struct value
*
6829 coerce_for_assign (struct type
*type
, struct value
*val
)
6831 struct type
*type2
= VALUE_TYPE (val
);
6835 CHECK_TYPEDEF (type2
);
6836 CHECK_TYPEDEF (type
);
6838 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
6839 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6841 val
= ada_value_ind (val
);
6842 type2
= VALUE_TYPE (val
);
6845 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
6846 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6848 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
6849 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
6850 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
6851 error ("Incompatible types in assignment");
6852 VALUE_TYPE (val
) = type
;
6858 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
6859 int *pos
, enum noside noside
)
6862 enum ada_attribute atr
;
6863 int tem
, tem2
, tem3
;
6865 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
6868 struct value
**argvec
;
6872 op
= exp
->elts
[pc
].opcode
;
6879 unwrap_value (evaluate_subexp_standard
6880 (expect_type
, exp
, pos
, noside
));
6884 type
= exp
->elts
[pc
+ 1].type
;
6885 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
6886 if (noside
== EVAL_SKIP
)
6888 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
6890 if (ada_is_fixed_point_type (type
))
6891 arg1
= cast_to_fixed (type
, arg1
);
6892 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6893 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
6894 else if (VALUE_LVAL (arg1
) == lval_memory
)
6896 /* This is in case of the really obscure (and undocumented,
6897 but apparently expected) case of (Foo) Bar.all, where Bar
6898 is an integer constant and Foo is a dynamic-sized type.
6899 If we don't do this, ARG1 will simply be relabeled with
6901 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
6902 return value_zero (to_static_fixed_type (type
), not_lval
);
6905 (type
, 0, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
6908 arg1
= value_cast (type
, arg1
);
6912 /* FIXME: UNOP_QUAL should be defined in expression.h */
6915 type = exp->elts[pc + 1].type;
6916 return ada_evaluate_subexp (type, exp, pos, noside);
6919 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6920 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
6921 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
6923 if (binop_user_defined_p (op
, arg1
, arg2
))
6924 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6927 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6928 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
6929 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6931 ("Fixed-point values must be assigned to fixed-point variables");
6933 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
6934 return ada_value_assign (arg1
, arg2
);
6938 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6939 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6940 if (noside
== EVAL_SKIP
)
6942 if (binop_user_defined_p (op
, arg1
, arg2
))
6943 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6946 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6947 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6948 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6950 ("Operands of fixed-point addition must have the same type");
6951 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
6955 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6956 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6957 if (noside
== EVAL_SKIP
)
6959 if (binop_user_defined_p (op
, arg1
, arg2
))
6960 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6963 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6964 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6965 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6967 ("Operands of fixed-point subtraction must have the same type");
6968 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
6973 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6974 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6975 if (noside
== EVAL_SKIP
)
6977 if (binop_user_defined_p (op
, arg1
, arg2
))
6978 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6980 if (noside
== EVAL_AVOID_SIDE_EFFECTS
6981 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
6982 return value_zero (VALUE_TYPE (arg1
), not_lval
);
6985 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6986 arg1
= cast_from_fixed_to_double (arg1
);
6987 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6988 arg2
= cast_from_fixed_to_double (arg2
);
6989 return value_binop (arg1
, arg2
, op
);
6993 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6994 if (noside
== EVAL_SKIP
)
6996 if (unop_user_defined_p (op
, arg1
))
6997 return value_x_unop (arg1
, op
, EVAL_NORMAL
);
6998 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6999 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
7001 return value_neg (arg1
);
7003 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7004 /* case OP_UNRESOLVED_VALUE:
7005 /* Only encountered when an unresolved symbol occurs in a
7006 context other than a function call, in which case, it is
7009 if (noside == EVAL_SKIP)
7012 error ("Unexpected unresolved symbol, %s, during evaluation",
7013 ada_demangle (exp->elts[pc + 2].name));
7017 if (noside
== EVAL_SKIP
)
7022 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7026 (to_static_fixed_type
7027 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7033 unwrap_value (evaluate_subexp_standard
7034 (expect_type
, exp
, pos
, noside
));
7035 return ada_to_fixed_value (VALUE_TYPE (arg1
), 0,
7036 VALUE_ADDRESS (arg1
) +
7037 VALUE_OFFSET (arg1
), arg1
);
7042 tem2
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7043 tem3
= longest_to_int (exp
->elts
[pc
+ 2].longconst
);
7044 nargs
= tem3
- tem2
+ 1;
7045 type
= expect_type
? check_typedef (expect_type
) : NULL_TYPE
;
7048 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
7049 for (tem
= 0; tem
== 0 || tem
< nargs
; tem
+= 1)
7050 /* At least one element gets inserted for the type */
7052 /* Ensure that array expressions are coerced into pointer objects. */
7053 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
7055 if (noside
== EVAL_SKIP
)
7057 return value_array (tem2
, tem3
, argvec
);
7062 /* Allocate arg vector, including space for the function to be
7063 called in argvec[0] and a terminating NULL */
7064 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7066 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 2));
7068 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7069 /* FIXME: name should be defined in expresion.h */
7070 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7071 error ("Unexpected unresolved symbol, %s, during evaluation",
7072 ada_demangle (exp->elts[pc + 5].name));
7076 error ("unexpected code path, FIXME");
7080 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7081 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7084 if (noside
== EVAL_SKIP
)
7088 if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
)
7089 argvec
[0] = value_addr (argvec
[0]);
7091 if (ada_is_packed_array_type (VALUE_TYPE (argvec
[0])))
7092 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7094 type
= check_typedef (VALUE_TYPE (argvec
[0]));
7095 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7097 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
7099 case TYPE_CODE_FUNC
:
7100 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7102 case TYPE_CODE_ARRAY
:
7104 case TYPE_CODE_STRUCT
:
7105 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7106 argvec
[0] = ada_value_ind (argvec
[0]);
7107 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7110 error ("cannot subscript or call something of type `%s'",
7111 ada_type_name (VALUE_TYPE (argvec
[0])));
7116 switch (TYPE_CODE (type
))
7118 case TYPE_CODE_FUNC
:
7119 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7120 return allocate_value (TYPE_TARGET_TYPE (type
));
7121 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7122 case TYPE_CODE_STRUCT
:
7124 int arity
= ada_array_arity (type
);
7125 type
= ada_array_element_type (type
, nargs
);
7127 error ("cannot subscript or call a record");
7129 error ("wrong number of subscripts; expecting %d", arity
);
7130 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7131 return allocate_value (ada_aligned_type (type
));
7133 unwrap_value (ada_value_subscript
7134 (argvec
[0], nargs
, argvec
+ 1));
7136 case TYPE_CODE_ARRAY
:
7137 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7139 type
= ada_array_element_type (type
, nargs
);
7141 error ("element type of array unknown");
7143 return allocate_value (ada_aligned_type (type
));
7146 unwrap_value (ada_value_subscript
7147 (ada_coerce_to_simple_array (argvec
[0]),
7148 nargs
, argvec
+ 1));
7149 case TYPE_CODE_PTR
: /* Pointer to array */
7150 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7151 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7153 type
= ada_array_element_type (type
, nargs
);
7155 error ("element type of array unknown");
7157 return allocate_value (ada_aligned_type (type
));
7160 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7161 nargs
, argvec
+ 1));
7164 error ("Internal error in evaluate_subexp");
7169 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7171 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7173 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7174 if (noside
== EVAL_SKIP
)
7177 /* If this is a reference to an array, then dereference it */
7178 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7179 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7180 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7182 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7184 array
= ada_coerce_ref (array
);
7187 if (noside
== EVAL_AVOID_SIDE_EFFECTS
&&
7188 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7190 /* Try to dereference the array, in case it is an access to array */
7191 struct type
*arrType
= ada_type_of_array (array
, 0);
7192 if (arrType
!= NULL
)
7193 array
= value_at_lazy (arrType
, 0, NULL
);
7195 if (ada_is_array_descriptor (VALUE_TYPE (array
)))
7196 array
= ada_coerce_to_simple_array (array
);
7198 /* If at this point we have a pointer to an array, it means that
7199 it is a pointer to a simple (non-ada) array. We just then
7201 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
7202 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7203 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7206 array
= ada_value_ind (array
);
7209 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7210 /* The following will get the bounds wrong, but only in contexts
7211 where the value is not being requested (FIXME?). */
7214 return value_slice (array
, lowbound
, upper
- lowbound
+ 1);
7217 /* FIXME: UNOP_MBR should be defined in expression.h */
7220 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7221 type = exp->elts[pc + 1].type;
7223 if (noside == EVAL_SKIP)
7226 switch (TYPE_CODE (type))
7229 warning ("Membership test incompletely implemented; always returns true");
7230 return value_from_longest (builtin_type_int, (LONGEST) 1);
7232 case TYPE_CODE_RANGE:
7233 arg2 = value_from_longest (builtin_type_int,
7234 (LONGEST) TYPE_LOW_BOUND (type));
7235 arg3 = value_from_longest (builtin_type_int,
7236 (LONGEST) TYPE_HIGH_BOUND (type));
7238 value_from_longest (builtin_type_int,
7239 (value_less (arg1,arg3)
7240 || value_equal (arg1,arg3))
7241 && (value_less (arg2,arg1)
7242 || value_equal (arg2,arg1)));
7245 /* FIXME: BINOP_MBR should be defined in expression.h */
7248 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7249 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7251 if (noside == EVAL_SKIP)
7254 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7255 return value_zero (builtin_type_int, not_lval);
7257 tem = longest_to_int (exp->elts[pc + 1].longconst);
7259 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7260 error ("invalid dimension number to '%s", "range");
7262 arg3 = ada_array_bound (arg2, tem, 1);
7263 arg2 = ada_array_bound (arg2, tem, 0);
7266 value_from_longest (builtin_type_int,
7267 (value_less (arg1,arg3)
7268 || value_equal (arg1,arg3))
7269 && (value_less (arg2,arg1)
7270 || value_equal (arg2,arg1)));
7272 /* FIXME: TERNOP_MBR should be defined in expression.h */
7274 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7275 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7276 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7278 if (noside == EVAL_SKIP)
7282 value_from_longest (builtin_type_int,
7283 (value_less (arg1,arg3)
7284 || value_equal (arg1,arg3))
7285 && (value_less (arg2,arg1)
7286 || value_equal (arg2,arg1)));
7288 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7289 /* case OP_ATTRIBUTE:
7291 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7295 error ("unexpected attribute encountered");
7301 struct type* type_arg;
7302 if (exp->elts[*pos].opcode == OP_TYPE)
7304 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7306 type_arg = exp->elts[pc + 5].type;
7310 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7314 if (exp->elts[*pos].opcode != OP_LONG)
7315 error ("illegal operand to '%s", ada_attribute_name (atr));
7316 tem = longest_to_int (exp->elts[*pos+2].longconst);
7319 if (noside == EVAL_SKIP)
7322 if (type_arg == NULL)
7324 arg1 = ada_coerce_ref (arg1);
7326 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7327 arg1 = ada_coerce_to_simple_array (arg1);
7329 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7330 error ("invalid dimension number to '%s",
7331 ada_attribute_name (atr));
7333 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7335 type = ada_index_type (VALUE_TYPE (arg1), tem);
7337 error ("attempt to take bound of something that is not an array");
7338 return allocate_value (type);
7344 error ("unexpected attribute encountered");
7346 return ada_array_bound (arg1, tem, 0);
7348 return ada_array_bound (arg1, tem, 1);
7350 return ada_array_length (arg1, tem);
7353 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7354 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7356 struct type* range_type;
7357 char* name = ada_type_name (type_arg);
7360 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7361 range_type = type_arg;
7363 error ("unimplemented type attribute");
7367 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7371 error ("unexpected attribute encountered");
7373 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7374 TYPE_LOW_BOUND (range_type));
7376 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7377 TYPE_HIGH_BOUND (range_type));
7380 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7385 error ("unexpected attribute encountered");
7387 return value_from_longest
7388 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7390 return value_from_longest
7392 TYPE_FIELD_BITPOS (type_arg,
7393 TYPE_NFIELDS (type_arg) - 1));
7396 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7397 error ("unimplemented type attribute");
7402 if (ada_is_packed_array_type (type_arg))
7403 type_arg = decode_packed_array_type (type_arg);
7405 if (tem < 1 || tem > ada_array_arity (type_arg))
7406 error ("invalid dimension number to '%s",
7407 ada_attribute_name (atr));
7409 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7411 type = ada_index_type (type_arg, tem);
7413 error ("attempt to take bound of something that is not an array");
7414 return allocate_value (type);
7420 error ("unexpected attribute encountered");
7422 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7423 return value_from_longest (type, low);
7425 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7426 return value_from_longest (type, high);
7428 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7429 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7430 return value_from_longest (type, high-low+1);
7436 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7437 if (noside == EVAL_SKIP)
7440 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7442 value_zero (ada_tag_type (arg1), not_lval);
7444 return ada_value_tag (arg1);
7448 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7449 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7450 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7451 if (noside == EVAL_SKIP)
7453 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7454 return value_zero (VALUE_TYPE (arg1), not_lval);
7456 return value_binop (arg1, arg2,
7457 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7461 struct type* type_arg = exp->elts[pc + 5].type;
7462 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7465 if (noside == EVAL_SKIP)
7468 if (! ada_is_modular_type (type_arg))
7469 error ("'modulus must be applied to modular type");
7471 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7472 ada_modulus (type_arg));
7477 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7478 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7479 if (noside == EVAL_SKIP)
7481 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7482 return value_zero (builtin_type_ada_int, not_lval);
7484 return value_pos_atr (arg1);
7487 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7488 if (noside == EVAL_SKIP)
7490 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7491 return value_zero (builtin_type_ada_int, not_lval);
7493 return value_from_longest (builtin_type_ada_int,
7495 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7498 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7499 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7500 type = exp->elts[pc + 5].type;
7501 if (noside == EVAL_SKIP)
7503 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7504 return value_zero (type, not_lval);
7506 return value_val_atr (type, arg1);
7509 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7510 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7511 if (noside
== EVAL_SKIP
)
7513 if (binop_user_defined_p (op
, arg1
, arg2
))
7514 return unwrap_value (value_x_binop (arg1
, arg2
, op
, OP_NULL
,
7516 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7517 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7519 return value_binop (arg1
, arg2
, op
);
7522 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7523 if (noside
== EVAL_SKIP
)
7525 if (unop_user_defined_p (op
, arg1
))
7526 return unwrap_value (value_x_unop (arg1
, op
, EVAL_NORMAL
));
7531 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7532 if (noside
== EVAL_SKIP
)
7534 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
7535 return value_neg (arg1
);
7540 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7541 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
7542 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7543 if (noside
== EVAL_SKIP
)
7545 type
= check_typedef (VALUE_TYPE (arg1
));
7546 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7548 if (ada_is_array_descriptor (type
))
7549 /* GDB allows dereferencing GNAT array descriptors. */
7551 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7552 if (arrType
== NULL
)
7553 error ("Attempt to dereference null array pointer.");
7554 return value_at_lazy (arrType
, 0, NULL
);
7556 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7557 || TYPE_CODE (type
) == TYPE_CODE_REF
7558 /* In C you can dereference an array to get the 1st elt. */
7559 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7562 (to_static_fixed_type
7563 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
7565 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7566 /* GDB allows dereferencing an int. */
7567 return value_zero (builtin_type_int
, lval_memory
);
7569 error ("Attempt to take contents of a non-pointer value.");
7571 arg1
= ada_coerce_ref (arg1
);
7572 type
= check_typedef (VALUE_TYPE (arg1
));
7574 if (ada_is_array_descriptor (type
))
7575 /* GDB allows dereferencing GNAT array descriptors. */
7576 return ada_coerce_to_simple_array (arg1
);
7578 return ada_value_ind (arg1
);
7580 case STRUCTOP_STRUCT
:
7581 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7582 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7583 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7584 if (noside
== EVAL_SKIP
)
7586 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7587 return value_zero (ada_aligned_type
7588 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7594 return unwrap_value (ada_value_struct_elt (arg1
,
7595 &exp
->elts
[pc
+ 2].string
,
7598 /* The value is not supposed to be used. This is here to make it
7599 easier to accommodate expressions that contain types. */
7601 if (noside
== EVAL_SKIP
)
7603 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7604 return allocate_value (builtin_type_void
);
7606 error ("Attempt to use a type name as an expression");
7609 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7610 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7611 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7612 if (noside
== EVAL_SKIP
)
7614 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7615 return value_zero (ada_aligned_type
7616 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7622 return unwrap_value (ada_value_struct_elt (arg1
,
7623 &exp
->elts
[pc
+ 2].string
,
7628 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7634 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7635 type name that encodes the 'small and 'delta information.
7636 Otherwise, return NULL. */
7639 fixed_type_info (struct type
*type
)
7641 const char *name
= ada_type_name (type
);
7642 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7644 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7646 const char *tail
= strstr (name
, "___XF_");
7652 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7653 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7658 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7661 ada_is_fixed_point_type (struct type
*type
)
7663 return fixed_type_info (type
) != NULL
;
7666 /* Assuming that TYPE is the representation of an Ada fixed-point
7667 type, return its delta, or -1 if the type is malformed and the
7668 delta cannot be determined. */
7671 ada_delta (struct type
*type
)
7673 const char *encoding
= fixed_type_info (type
);
7676 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7679 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7682 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7683 factor ('SMALL value) associated with the type. */
7686 scaling_factor (struct type
*type
)
7688 const char *encoding
= fixed_type_info (type
);
7689 unsigned long num0
, den0
, num1
, den1
;
7692 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7697 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7699 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7703 /* Assuming that X is the representation of a value of fixed-point
7704 type TYPE, return its floating-point equivalent. */
7707 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7709 return (DOUBLEST
) x
*scaling_factor (type
);
7712 /* The representation of a fixed-point value of type TYPE
7713 corresponding to the value X. */
7716 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7718 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7722 /* VAX floating formats */
7724 /* Non-zero iff TYPE represents one of the special VAX floating-point
7727 ada_is_vax_floating_type (struct type
*type
)
7730 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7733 && (TYPE_CODE (type
) == TYPE_CODE_INT
7734 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7735 && STREQN (ada_type_name (type
) + name_len
- 6, "___XF", 5);
7738 /* The type of special VAX floating-point type this is, assuming
7739 ada_is_vax_floating_point */
7741 ada_vax_float_type_suffix (struct type
*type
)
7743 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7746 /* A value representing the special debugging function that outputs
7747 VAX floating-point values of the type represented by TYPE. Assumes
7748 ada_is_vax_floating_type (TYPE). */
7750 ada_vax_float_print_function (struct type
*type
)
7752 switch (ada_vax_float_type_suffix (type
))
7755 return get_var_value ("DEBUG_STRING_F", 0);
7757 return get_var_value ("DEBUG_STRING_D", 0);
7759 return get_var_value ("DEBUG_STRING_G", 0);
7761 error ("invalid VAX floating-point type");
7768 /* Scan STR beginning at position K for a discriminant name, and
7769 return the value of that discriminant field of DVAL in *PX. If
7770 PNEW_K is not null, put the position of the character beyond the
7771 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7772 not alter *PX and *PNEW_K if unsuccessful. */
7775 scan_discrim_bound (char *, int k
, struct value
*dval
, LONGEST
* px
,
7778 static char *bound_buffer
= NULL
;
7779 static size_t bound_buffer_len
= 0;
7782 struct value
*bound_val
;
7784 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
7787 pend
= strstr (str
+ k
, "__");
7791 k
+= strlen (bound
);
7795 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
7796 bound
= bound_buffer
;
7797 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
7798 bound
[pend
- (str
+ k
)] = '\0';
7802 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
7803 if (bound_val
== NULL
)
7806 *px
= value_as_long (bound_val
);
7812 /* Value of variable named NAME in the current environment. If
7813 no such variable found, then if ERR_MSG is null, returns 0, and
7814 otherwise causes an error with message ERR_MSG. */
7815 static struct value
*
7816 get_var_value (char *name
, char *err_msg
)
7818 struct symbol
**syms
;
7819 struct block
**blocks
;
7823 ada_lookup_symbol_list (name
, get_selected_block (NULL
), VAR_DOMAIN
,
7828 if (err_msg
== NULL
)
7831 error ("%s", err_msg
);
7834 return value_of_variable (syms
[0], blocks
[0]);
7837 /* Value of integer variable named NAME in the current environment. If
7838 no such variable found, then if ERR_MSG is null, returns 0, and sets
7839 *FLAG to 0. If successful, sets *FLAG to 1. */
7841 get_int_var_value (char *name
, char *err_msg
, int *flag
)
7843 struct value
*var_val
= get_var_value (name
, err_msg
);
7855 return value_as_long (var_val
);
7860 /* Return a range type whose base type is that of the range type named
7861 NAME in the current environment, and whose bounds are calculated
7862 from NAME according to the GNAT range encoding conventions.
7863 Extract discriminant values, if needed, from DVAL. If a new type
7864 must be created, allocate in OBJFILE's space. The bounds
7865 information, in general, is encoded in NAME, the base type given in
7866 the named range type. */
7868 static struct type
*
7869 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
7871 struct type
*raw_type
= ada_find_any_type (name
);
7872 struct type
*base_type
;
7876 if (raw_type
== NULL
)
7877 base_type
= builtin_type_int
;
7878 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
7879 base_type
= TYPE_TARGET_TYPE (raw_type
);
7881 base_type
= raw_type
;
7883 subtype_info
= strstr (name
, "___XD");
7884 if (subtype_info
== NULL
)
7888 static char *name_buf
= NULL
;
7889 static size_t name_len
= 0;
7890 int prefix_len
= subtype_info
- name
;
7896 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
7897 strncpy (name_buf
, name
, prefix_len
);
7898 name_buf
[prefix_len
] = '\0';
7901 bounds_str
= strchr (subtype_info
, '_');
7904 if (*subtype_info
== 'L')
7906 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
7907 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
7909 if (bounds_str
[n
] == '_')
7911 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
7917 strcpy (name_buf
+ prefix_len
, "___L");
7918 L
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7921 if (*subtype_info
== 'U')
7923 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
7924 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
7929 strcpy (name_buf
+ prefix_len
, "___U");
7930 U
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7933 if (objfile
== NULL
)
7934 objfile
= TYPE_OBJFILE (base_type
);
7935 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
7936 TYPE_NAME (type
) = name
;
7941 /* True iff NAME is the name of a range type. */
7943 ada_is_range_type_name (const char *name
)
7945 return (name
!= NULL
&& strstr (name
, "___XD"));
7951 /* True iff TYPE is an Ada modular type. */
7953 ada_is_modular_type (struct type
*type
)
7955 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
7957 struct type
*subranged_type
; /* = base_type (type); */
7959 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
7960 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
7961 && TYPE_UNSIGNED (subranged_type
));
7964 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
7966 ada_modulus (struct type
* type
)
7968 return TYPE_HIGH_BOUND (type
) + 1;
7975 /* Table mapping opcodes into strings for printing operators
7976 and precedences of the operators. */
7978 static const struct op_print ada_op_print_tab
[] = {
7979 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
7980 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
7981 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
7982 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
7983 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
7984 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
7985 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
7986 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
7987 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
7988 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
7989 {">", BINOP_GTR
, PREC_ORDER
, 0},
7990 {"<", BINOP_LESS
, PREC_ORDER
, 0},
7991 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
7992 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
7993 {"+", BINOP_ADD
, PREC_ADD
, 0},
7994 {"-", BINOP_SUB
, PREC_ADD
, 0},
7995 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
7996 {"*", BINOP_MUL
, PREC_MUL
, 0},
7997 {"/", BINOP_DIV
, PREC_MUL
, 0},
7998 {"rem", BINOP_REM
, PREC_MUL
, 0},
7999 {"mod", BINOP_MOD
, PREC_MUL
, 0},
8000 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8001 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8002 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8003 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8004 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8005 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8006 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8007 {".all", UNOP_IND
, PREC_SUFFIX
, 1}, /* FIXME: postfix .ALL */
8008 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1}, /* FIXME: postfix 'ACCESS */
8012 /* Assorted Types and Interfaces */
8014 struct type
*builtin_type_ada_int
;
8015 struct type
*builtin_type_ada_short
;
8016 struct type
*builtin_type_ada_long
;
8017 struct type
*builtin_type_ada_long_long
;
8018 struct type
*builtin_type_ada_char
;
8019 struct type
*builtin_type_ada_float
;
8020 struct type
*builtin_type_ada_double
;
8021 struct type
*builtin_type_ada_long_double
;
8022 struct type
*builtin_type_ada_natural
;
8023 struct type
*builtin_type_ada_positive
;
8024 struct type
*builtin_type_ada_system_address
;
8026 struct type
**const (ada_builtin_types
[]) =
8029 &builtin_type_ada_int
,
8030 &builtin_type_ada_long
,
8031 &builtin_type_ada_short
,
8032 &builtin_type_ada_char
,
8033 &builtin_type_ada_float
,
8034 &builtin_type_ada_double
,
8035 &builtin_type_ada_long_long
,
8036 &builtin_type_ada_long_double
,
8037 &builtin_type_ada_natural
, &builtin_type_ada_positive
,
8038 /* The following types are carried over from C for convenience. */
8041 &builtin_type_short
,
8043 &builtin_type_float
,
8044 &builtin_type_double
,
8045 &builtin_type_long_long
,
8047 &builtin_type_signed_char
,
8048 &builtin_type_unsigned_char
,
8049 &builtin_type_unsigned_short
,
8050 &builtin_type_unsigned_int
,
8051 &builtin_type_unsigned_long
,
8052 &builtin_type_unsigned_long_long
,
8053 &builtin_type_long_double
,
8054 &builtin_type_complex
, &builtin_type_double_complex
, 0};
8056 /* Not really used, but needed in the ada_language_defn. */
8058 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8060 ada_emit_char (c
, stream
, quoter
, 1);
8063 const struct language_defn ada_language_defn
= {
8064 "ada", /* Language name */
8067 /* FIXME: language_ada should be defined in defs.h */
8071 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8072 * that's not quite what this means. */
8075 ada_evaluate_subexp
,
8076 ada_printchar
, /* Print a character constant */
8077 ada_printstr
, /* Function to print string constant */
8078 emit_char
, /* Function to print single char (not used) */
8079 ada_create_fundamental_type
, /* Create fundamental type in this language */
8080 ada_print_type
, /* Print a type using appropriate syntax */
8081 ada_val_print
, /* Print a value using appropriate syntax */
8082 ada_value_print
, /* Print a top-level value */
8083 NULL
, /* Language specific skip_trampoline */
8084 value_of_this
, /* value_of_this */
8085 basic_lookup_symbol_nonlocal
, /* lookup_symbol_nonlocal */
8086 NULL
, /* Language specific symbol demangler */
8087 {"", "", "", ""}, /* Binary format info */
8089 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8090 {"%ld", "", "d", ""}, /* Decimal format info */
8091 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8093 /* Copied from c-lang.c. */
8094 {"0%lo", "0", "o", ""}, /* Octal format info */
8095 {"%ld", "", "d", ""}, /* Decimal format info */
8096 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8098 ada_op_print_tab
, /* expression operators for printing */
8099 1, /* c-style arrays (FIXME?) */
8100 0, /* String lower bound (FIXME?) */
8101 &builtin_type_ada_char
,
8106 _initialize_ada_language (void)
8108 builtin_type_ada_int
=
8109 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8110 0, "integer", (struct objfile
*) NULL
);
8111 builtin_type_ada_long
=
8112 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8113 0, "long_integer", (struct objfile
*) NULL
);
8114 builtin_type_ada_short
=
8115 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8116 0, "short_integer", (struct objfile
*) NULL
);
8117 builtin_type_ada_char
=
8118 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8119 0, "character", (struct objfile
*) NULL
);
8120 builtin_type_ada_float
=
8121 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8122 0, "float", (struct objfile
*) NULL
);
8123 builtin_type_ada_double
=
8124 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8125 0, "long_float", (struct objfile
*) NULL
);
8126 builtin_type_ada_long_long
=
8127 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8128 0, "long_long_integer", (struct objfile
*) NULL
);
8129 builtin_type_ada_long_double
=
8130 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8131 0, "long_long_float", (struct objfile
*) NULL
);
8132 builtin_type_ada_natural
=
8133 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8134 0, "natural", (struct objfile
*) NULL
);
8135 builtin_type_ada_positive
=
8136 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8137 0, "positive", (struct objfile
*) NULL
);
8140 builtin_type_ada_system_address
=
8141 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8142 (struct objfile
*) NULL
));
8143 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
8145 add_language (&ada_language_defn
);
8148 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
8149 (char *) &varsize_limit
,
8150 "Set maximum bytes in dynamic-sized object.",
8151 &setlist
), &showlist
);
8152 varsize_limit
= 65536;
8154 add_com ("begin", class_breakpoint
, begin_command
,
8155 "Start the debugged program, stopping at the beginning of the\n\
8156 main program. You may specify command-line arguments to give it, as for\n\
8157 the \"run\" command (q.v.).");
8161 /* Create a fundamental Ada type using default reasonable for the current
8164 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8165 define fundamental types such as "int" or "double". Others (stabs or
8166 DWARF version 2, etc) do define fundamental types. For the formats which
8167 don't provide fundamental types, gdb can create such types using this
8170 FIXME: Some compilers distinguish explicitly signed integral types
8171 (signed short, signed int, signed long) from "regular" integral types
8172 (short, int, long) in the debugging information. There is some dis-
8173 agreement as to how useful this feature is. In particular, gcc does
8174 not support this. Also, only some debugging formats allow the
8175 distinction to be passed on to a debugger. For now, we always just
8176 use "short", "int", or "long" as the type name, for both the implicit
8177 and explicitly signed types. This also makes life easier for the
8178 gdb test suite since we don't have to account for the differences
8179 in output depending upon what the compiler and debugging format
8180 support. We will probably have to re-examine the issue when gdb
8181 starts taking it's fundamental type information directly from the
8182 debugging information supplied by the compiler. fnf@cygnus.com */
8184 static struct type
*
8185 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8187 struct type
*type
= NULL
;
8192 /* FIXME: For now, if we are asked to produce a type not in this
8193 language, create the equivalent of a C integer type with the
8194 name "<?type?>". When all the dust settles from the type
8195 reconstruction work, this should probably become an error. */
8196 type
= init_type (TYPE_CODE_INT
,
8197 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8198 0, "<?type?>", objfile
);
8199 warning ("internal error: no Ada fundamental type %d", typeid);
8202 type
= init_type (TYPE_CODE_VOID
,
8203 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8204 0, "void", objfile
);
8207 type
= init_type (TYPE_CODE_INT
,
8208 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8209 0, "character", objfile
);
8211 case FT_SIGNED_CHAR
:
8212 type
= init_type (TYPE_CODE_INT
,
8213 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8214 0, "signed char", objfile
);
8216 case FT_UNSIGNED_CHAR
:
8217 type
= init_type (TYPE_CODE_INT
,
8218 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8219 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8222 type
= init_type (TYPE_CODE_INT
,
8223 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8224 0, "short_integer", objfile
);
8226 case FT_SIGNED_SHORT
:
8227 type
= init_type (TYPE_CODE_INT
,
8228 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8229 0, "short_integer", objfile
);
8231 case FT_UNSIGNED_SHORT
:
8232 type
= init_type (TYPE_CODE_INT
,
8233 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8234 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8237 type
= init_type (TYPE_CODE_INT
,
8238 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8239 0, "integer", objfile
);
8241 case FT_SIGNED_INTEGER
:
8242 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
, 0, "integer", objfile
); /* FIXME -fnf */
8244 case FT_UNSIGNED_INTEGER
:
8245 type
= init_type (TYPE_CODE_INT
,
8246 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8247 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8250 type
= init_type (TYPE_CODE_INT
,
8251 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8252 0, "long_integer", objfile
);
8254 case FT_SIGNED_LONG
:
8255 type
= init_type (TYPE_CODE_INT
,
8256 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8257 0, "long_integer", objfile
);
8259 case FT_UNSIGNED_LONG
:
8260 type
= init_type (TYPE_CODE_INT
,
8261 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8262 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8265 type
= init_type (TYPE_CODE_INT
,
8266 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8267 0, "long_long_integer", objfile
);
8269 case FT_SIGNED_LONG_LONG
:
8270 type
= init_type (TYPE_CODE_INT
,
8271 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8272 0, "long_long_integer", objfile
);
8274 case FT_UNSIGNED_LONG_LONG
:
8275 type
= init_type (TYPE_CODE_INT
,
8276 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8277 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8280 type
= init_type (TYPE_CODE_FLT
,
8281 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8282 0, "float", objfile
);
8284 case FT_DBL_PREC_FLOAT
:
8285 type
= init_type (TYPE_CODE_FLT
,
8286 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8287 0, "long_float", objfile
);
8289 case FT_EXT_PREC_FLOAT
:
8290 type
= init_type (TYPE_CODE_FLT
,
8291 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8292 0, "long_long_float", objfile
);
8299 ada_dump_symtab (struct symtab
*s
)
8302 fprintf (stderr
, "New symtab: [\n");
8303 fprintf (stderr
, " Name: %s/%s;\n",
8304 s
->dirname
? s
->dirname
: "?", s
->filename
? s
->filename
: "?");
8305 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
8306 if (s
->linetable
!= NULL
)
8308 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
8309 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
8311 struct linetable_entry
*e
= s
->linetable
->item
+ i
;
8312 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
8315 fprintf (stderr
, "]\n");