1 /* Ada language support routines for GDB, the GNU debugger. Copyright (C)
3 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005, 2007, 2008,
4 2009 Free Software Foundation, Inc.
6 This file is part of GDB.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
24 #include "gdb_string.h"
28 #include "gdb_regex.h"
33 #include "expression.h"
34 #include "parser-defs.h"
40 #include "breakpoint.h"
43 #include "gdb_obstack.h"
45 #include "completer.h"
52 #include "dictionary.h"
53 #include "exceptions.h"
64 /* Define whether or not the C operator '/' truncates towards zero for
65 differently signed operands (truncation direction is undefined in C).
66 Copied from valarith.c. */
68 #ifndef TRUNCATION_TOWARDS_ZERO
69 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
72 static void modify_general_field (struct type
*, char *, LONGEST
, int, int);
74 static struct type
*desc_base_type (struct type
*);
76 static struct type
*desc_bounds_type (struct type
*);
78 static struct value
*desc_bounds (struct value
*);
80 static int fat_pntr_bounds_bitpos (struct type
*);
82 static int fat_pntr_bounds_bitsize (struct type
*);
84 static struct type
*desc_data_target_type (struct type
*);
86 static struct value
*desc_data (struct value
*);
88 static int fat_pntr_data_bitpos (struct type
*);
90 static int fat_pntr_data_bitsize (struct type
*);
92 static struct value
*desc_one_bound (struct value
*, int, int);
94 static int desc_bound_bitpos (struct type
*, int, int);
96 static int desc_bound_bitsize (struct type
*, int, int);
98 static struct type
*desc_index_type (struct type
*, int);
100 static int desc_arity (struct type
*);
102 static int ada_type_match (struct type
*, struct type
*, int);
104 static int ada_args_match (struct symbol
*, struct value
**, int);
106 static struct value
*make_array_descriptor (struct type
*, struct value
*);
108 static void ada_add_block_symbols (struct obstack
*,
109 struct block
*, const char *,
110 domain_enum
, struct objfile
*, int);
112 static int is_nonfunction (struct ada_symbol_info
*, int);
114 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
117 static int num_defns_collected (struct obstack
*);
119 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
121 static struct value
*resolve_subexp (struct expression
**, int *, int,
124 static void replace_operator_with_call (struct expression
**, int, int, int,
125 struct symbol
*, struct block
*);
127 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
129 static char *ada_op_name (enum exp_opcode
);
131 static const char *ada_decoded_op_name (enum exp_opcode
);
133 static int numeric_type_p (struct type
*);
135 static int integer_type_p (struct type
*);
137 static int scalar_type_p (struct type
*);
139 static int discrete_type_p (struct type
*);
141 static enum ada_renaming_category
parse_old_style_renaming (struct type
*,
146 static struct symbol
*find_old_style_renaming_symbol (const char *,
149 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
152 static struct value
*evaluate_subexp_type (struct expression
*, int *);
154 static struct type
*ada_find_parallel_type_with_name (struct type
*,
157 static int is_dynamic_field (struct type
*, int);
159 static struct type
*to_fixed_variant_branch_type (struct type
*,
161 CORE_ADDR
, struct value
*);
163 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
165 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
167 static struct type
*to_static_fixed_type (struct type
*);
168 static struct type
*static_unwrap_type (struct type
*type
);
170 static struct value
*unwrap_value (struct value
*);
172 static struct type
*constrained_packed_array_type (struct type
*, long *);
174 static struct type
*decode_constrained_packed_array_type (struct type
*);
176 static long decode_packed_array_bitsize (struct type
*);
178 static struct value
*decode_constrained_packed_array (struct value
*);
180 static int ada_is_packed_array_type (struct type
*);
182 static int ada_is_unconstrained_packed_array_type (struct type
*);
184 static struct value
*value_subscript_packed (struct value
*, int,
187 static void move_bits (gdb_byte
*, int, const gdb_byte
*, int, int, int);
189 static struct value
*coerce_unspec_val_to_type (struct value
*,
192 static struct value
*get_var_value (char *, char *);
194 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
196 static int equiv_types (struct type
*, struct type
*);
198 static int is_name_suffix (const char *);
200 static int advance_wild_match (const char **, const char *, int);
202 static int wild_match (const char *, const char *);
204 static struct value
*ada_coerce_ref (struct value
*);
206 static LONGEST
pos_atr (struct value
*);
208 static struct value
*value_pos_atr (struct type
*, struct value
*);
210 static struct value
*value_val_atr (struct type
*, struct value
*);
212 static struct symbol
*standard_lookup (const char *, const struct block
*,
215 static struct value
*ada_search_struct_field (char *, struct value
*, int,
218 static struct value
*ada_value_primitive_field (struct value
*, int, int,
221 static int find_struct_field (char *, struct type
*, int,
222 struct type
**, int *, int *, int *, int *);
224 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
227 static int ada_resolve_function (struct ada_symbol_info
*, int,
228 struct value
**, int, const char *,
231 static struct value
*ada_coerce_to_simple_array (struct value
*);
233 static int ada_is_direct_array_type (struct type
*);
235 static void ada_language_arch_info (struct gdbarch
*,
236 struct language_arch_info
*);
238 static void check_size (const struct type
*);
240 static struct value
*ada_index_struct_field (int, struct value
*, int,
243 static struct value
*assign_aggregate (struct value
*, struct value
*,
244 struct expression
*, int *, enum noside
);
246 static void aggregate_assign_from_choices (struct value
*, struct value
*,
248 int *, LONGEST
*, int *,
249 int, LONGEST
, LONGEST
);
251 static void aggregate_assign_positional (struct value
*, struct value
*,
253 int *, LONGEST
*, int *, int,
257 static void aggregate_assign_others (struct value
*, struct value
*,
259 int *, LONGEST
*, int, LONGEST
, LONGEST
);
262 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
265 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
268 static void ada_forward_operator_length (struct expression
*, int, int *,
273 /* Maximum-sized dynamic type. */
274 static unsigned int varsize_limit
;
276 /* FIXME: brobecker/2003-09-17: No longer a const because it is
277 returned by a function that does not return a const char *. */
278 static char *ada_completer_word_break_characters
=
280 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
282 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
285 /* The name of the symbol to use to get the name of the main subprogram. */
286 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
287 = "__gnat_ada_main_program_name";
289 /* Limit on the number of warnings to raise per expression evaluation. */
290 static int warning_limit
= 2;
292 /* Number of warning messages issued; reset to 0 by cleanups after
293 expression evaluation. */
294 static int warnings_issued
= 0;
296 static const char *known_runtime_file_name_patterns
[] = {
297 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
300 static const char *known_auxiliary_function_name_patterns
[] = {
301 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
304 /* Space for allocating results of ada_lookup_symbol_list. */
305 static struct obstack symbol_list_obstack
;
307 /* Inferior-specific data. */
309 /* Per-inferior data for this module. */
311 struct ada_inferior_data
313 /* The ada__tags__type_specific_data type, which is used when decoding
314 tagged types. With older versions of GNAT, this type was directly
315 accessible through a component ("tsd") in the object tag. But this
316 is no longer the case, so we cache it for each inferior. */
317 struct type
*tsd_type
;
320 /* Our key to this module's inferior data. */
321 static const struct inferior_data
*ada_inferior_data
;
323 /* A cleanup routine for our inferior data. */
325 ada_inferior_data_cleanup (struct inferior
*inf
, void *arg
)
327 struct ada_inferior_data
*data
;
329 data
= inferior_data (inf
, ada_inferior_data
);
334 /* Return our inferior data for the given inferior (INF).
336 This function always returns a valid pointer to an allocated
337 ada_inferior_data structure. If INF's inferior data has not
338 been previously set, this functions creates a new one with all
339 fields set to zero, sets INF's inferior to it, and then returns
340 a pointer to that newly allocated ada_inferior_data. */
342 static struct ada_inferior_data
*
343 get_ada_inferior_data (struct inferior
*inf
)
345 struct ada_inferior_data
*data
;
347 data
= inferior_data (inf
, ada_inferior_data
);
350 data
= XZALLOC (struct ada_inferior_data
);
351 set_inferior_data (inf
, ada_inferior_data
, data
);
357 /* Perform all necessary cleanups regarding our module's inferior data
358 that is required after the inferior INF just exited. */
361 ada_inferior_exit (struct inferior
*inf
)
363 ada_inferior_data_cleanup (inf
, NULL
);
364 set_inferior_data (inf
, ada_inferior_data
, NULL
);
369 /* Given DECODED_NAME a string holding a symbol name in its
370 decoded form (ie using the Ada dotted notation), returns
371 its unqualified name. */
374 ada_unqualified_name (const char *decoded_name
)
376 const char *result
= strrchr (decoded_name
, '.');
379 result
++; /* Skip the dot... */
381 result
= decoded_name
;
386 /* Return a string starting with '<', followed by STR, and '>'.
387 The result is good until the next call. */
390 add_angle_brackets (const char *str
)
392 static char *result
= NULL
;
395 result
= xstrprintf ("<%s>", str
);
400 ada_get_gdb_completer_word_break_characters (void)
402 return ada_completer_word_break_characters
;
405 /* Print an array element index using the Ada syntax. */
408 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
409 const struct value_print_options
*options
)
411 LA_VALUE_PRINT (index_value
, stream
, options
);
412 fprintf_filtered (stream
, " => ");
415 /* Assuming VECT points to an array of *SIZE objects of size
416 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
417 updating *SIZE as necessary and returning the (new) array. */
420 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
422 if (*size
< min_size
)
425 if (*size
< min_size
)
427 vect
= xrealloc (vect
, *size
* element_size
);
432 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
433 suffix of FIELD_NAME beginning "___". */
436 field_name_match (const char *field_name
, const char *target
)
438 int len
= strlen (target
);
441 (strncmp (field_name
, target
, len
) == 0
442 && (field_name
[len
] == '\0'
443 || (strncmp (field_name
+ len
, "___", 3) == 0
444 && strcmp (field_name
+ strlen (field_name
) - 6,
449 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
450 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
451 and return its index. This function also handles fields whose name
452 have ___ suffixes because the compiler sometimes alters their name
453 by adding such a suffix to represent fields with certain constraints.
454 If the field could not be found, return a negative number if
455 MAYBE_MISSING is set. Otherwise raise an error. */
458 ada_get_field_index (const struct type
*type
, const char *field_name
,
462 struct type
*struct_type
= check_typedef ((struct type
*) type
);
464 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (struct_type
); fieldno
++)
465 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
469 error (_("Unable to find field %s in struct %s. Aborting"),
470 field_name
, TYPE_NAME (struct_type
));
475 /* The length of the prefix of NAME prior to any "___" suffix. */
478 ada_name_prefix_len (const char *name
)
484 const char *p
= strstr (name
, "___");
487 return strlen (name
);
493 /* Return non-zero if SUFFIX is a suffix of STR.
494 Return zero if STR is null. */
497 is_suffix (const char *str
, const char *suffix
)
504 len2
= strlen (suffix
);
505 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
508 /* The contents of value VAL, treated as a value of type TYPE. The
509 result is an lval in memory if VAL is. */
511 static struct value
*
512 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
514 type
= ada_check_typedef (type
);
515 if (value_type (val
) == type
)
519 struct value
*result
;
521 /* Make sure that the object size is not unreasonable before
522 trying to allocate some memory for it. */
525 result
= allocate_value (type
);
526 set_value_component_location (result
, val
);
527 set_value_bitsize (result
, value_bitsize (val
));
528 set_value_bitpos (result
, value_bitpos (val
));
529 set_value_address (result
, value_address (val
));
531 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
532 set_value_lazy (result
, 1);
534 memcpy (value_contents_raw (result
), value_contents (val
),
540 static const gdb_byte
*
541 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
546 return valaddr
+ offset
;
550 cond_offset_target (CORE_ADDR address
, long offset
)
555 return address
+ offset
;
558 /* Issue a warning (as for the definition of warning in utils.c, but
559 with exactly one argument rather than ...), unless the limit on the
560 number of warnings has passed during the evaluation of the current
563 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
564 provided by "complaint". */
565 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
568 lim_warning (const char *format
, ...)
572 va_start (args
, format
);
573 warnings_issued
+= 1;
574 if (warnings_issued
<= warning_limit
)
575 vwarning (format
, args
);
580 /* Issue an error if the size of an object of type T is unreasonable,
581 i.e. if it would be a bad idea to allocate a value of this type in
585 check_size (const struct type
*type
)
587 if (TYPE_LENGTH (type
) > varsize_limit
)
588 error (_("object size is larger than varsize-limit"));
591 /* Maximum value of a SIZE-byte signed integer type. */
593 max_of_size (int size
)
595 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
597 return top_bit
| (top_bit
- 1);
600 /* Minimum value of a SIZE-byte signed integer type. */
602 min_of_size (int size
)
604 return -max_of_size (size
) - 1;
607 /* Maximum value of a SIZE-byte unsigned integer type. */
609 umax_of_size (int size
)
611 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
613 return top_bit
| (top_bit
- 1);
616 /* Maximum value of integral type T, as a signed quantity. */
618 max_of_type (struct type
*t
)
620 if (TYPE_UNSIGNED (t
))
621 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
623 return max_of_size (TYPE_LENGTH (t
));
626 /* Minimum value of integral type T, as a signed quantity. */
628 min_of_type (struct type
*t
)
630 if (TYPE_UNSIGNED (t
))
633 return min_of_size (TYPE_LENGTH (t
));
636 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
638 ada_discrete_type_high_bound (struct type
*type
)
640 switch (TYPE_CODE (type
))
642 case TYPE_CODE_RANGE
:
643 return TYPE_HIGH_BOUND (type
);
645 return TYPE_FIELD_BITPOS (type
, TYPE_NFIELDS (type
) - 1);
650 return max_of_type (type
);
652 error (_("Unexpected type in ada_discrete_type_high_bound."));
656 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
658 ada_discrete_type_low_bound (struct type
*type
)
660 switch (TYPE_CODE (type
))
662 case TYPE_CODE_RANGE
:
663 return TYPE_LOW_BOUND (type
);
665 return TYPE_FIELD_BITPOS (type
, 0);
670 return min_of_type (type
);
672 error (_("Unexpected type in ada_discrete_type_low_bound."));
676 /* The identity on non-range types. For range types, the underlying
677 non-range scalar type. */
680 base_type (struct type
*type
)
682 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
684 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
686 type
= TYPE_TARGET_TYPE (type
);
692 /* Language Selection */
694 /* If the main program is in Ada, return language_ada, otherwise return LANG
695 (the main program is in Ada iif the adainit symbol is found). */
698 ada_update_initial_language (enum language lang
)
700 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
701 (struct objfile
*) NULL
) != NULL
)
707 /* If the main procedure is written in Ada, then return its name.
708 The result is good until the next call. Return NULL if the main
709 procedure doesn't appear to be in Ada. */
714 struct minimal_symbol
*msym
;
715 static char *main_program_name
= NULL
;
717 /* For Ada, the name of the main procedure is stored in a specific
718 string constant, generated by the binder. Look for that symbol,
719 extract its address, and then read that string. If we didn't find
720 that string, then most probably the main procedure is not written
722 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
726 CORE_ADDR main_program_name_addr
;
729 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
730 if (main_program_name_addr
== 0)
731 error (_("Invalid address for Ada main program name."));
733 xfree (main_program_name
);
734 target_read_string (main_program_name_addr
, &main_program_name
,
739 return main_program_name
;
742 /* The main procedure doesn't seem to be in Ada. */
748 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
751 const struct ada_opname_map ada_opname_table
[] = {
752 {"Oadd", "\"+\"", BINOP_ADD
},
753 {"Osubtract", "\"-\"", BINOP_SUB
},
754 {"Omultiply", "\"*\"", BINOP_MUL
},
755 {"Odivide", "\"/\"", BINOP_DIV
},
756 {"Omod", "\"mod\"", BINOP_MOD
},
757 {"Orem", "\"rem\"", BINOP_REM
},
758 {"Oexpon", "\"**\"", BINOP_EXP
},
759 {"Olt", "\"<\"", BINOP_LESS
},
760 {"Ole", "\"<=\"", BINOP_LEQ
},
761 {"Ogt", "\">\"", BINOP_GTR
},
762 {"Oge", "\">=\"", BINOP_GEQ
},
763 {"Oeq", "\"=\"", BINOP_EQUAL
},
764 {"One", "\"/=\"", BINOP_NOTEQUAL
},
765 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
766 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
767 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
768 {"Oconcat", "\"&\"", BINOP_CONCAT
},
769 {"Oabs", "\"abs\"", UNOP_ABS
},
770 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
771 {"Oadd", "\"+\"", UNOP_PLUS
},
772 {"Osubtract", "\"-\"", UNOP_NEG
},
776 /* The "encoded" form of DECODED, according to GNAT conventions.
777 The result is valid until the next call to ada_encode. */
780 ada_encode (const char *decoded
)
782 static char *encoding_buffer
= NULL
;
783 static size_t encoding_buffer_size
= 0;
790 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
791 2 * strlen (decoded
) + 10);
794 for (p
= decoded
; *p
!= '\0'; p
+= 1)
798 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
803 const struct ada_opname_map
*mapping
;
805 for (mapping
= ada_opname_table
;
806 mapping
->encoded
!= NULL
807 && strncmp (mapping
->decoded
, p
,
808 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
810 if (mapping
->encoded
== NULL
)
811 error (_("invalid Ada operator name: %s"), p
);
812 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
813 k
+= strlen (mapping
->encoded
);
818 encoding_buffer
[k
] = *p
;
823 encoding_buffer
[k
] = '\0';
824 return encoding_buffer
;
827 /* Return NAME folded to lower case, or, if surrounded by single
828 quotes, unfolded, but with the quotes stripped away. Result good
832 ada_fold_name (const char *name
)
834 static char *fold_buffer
= NULL
;
835 static size_t fold_buffer_size
= 0;
837 int len
= strlen (name
);
838 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
842 strncpy (fold_buffer
, name
+ 1, len
- 2);
843 fold_buffer
[len
- 2] = '\000';
849 for (i
= 0; i
<= len
; i
+= 1)
850 fold_buffer
[i
] = tolower (name
[i
]);
856 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
859 is_lower_alphanum (const char c
)
861 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
864 /* Remove either of these suffixes:
869 These are suffixes introduced by the compiler for entities such as
870 nested subprogram for instance, in order to avoid name clashes.
871 They do not serve any purpose for the debugger. */
874 ada_remove_trailing_digits (const char *encoded
, int *len
)
876 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
880 while (i
> 0 && isdigit (encoded
[i
]))
882 if (i
>= 0 && encoded
[i
] == '.')
884 else if (i
>= 0 && encoded
[i
] == '$')
886 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
888 else if (i
>= 1 && strncmp (encoded
+ i
- 1, "__", 2) == 0)
893 /* Remove the suffix introduced by the compiler for protected object
897 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
899 /* Remove trailing N. */
901 /* Protected entry subprograms are broken into two
902 separate subprograms: The first one is unprotected, and has
903 a 'N' suffix; the second is the protected version, and has
904 the 'P' suffix. The second calls the first one after handling
905 the protection. Since the P subprograms are internally generated,
906 we leave these names undecoded, giving the user a clue that this
907 entity is internal. */
910 && encoded
[*len
- 1] == 'N'
911 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
915 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
918 ada_remove_Xbn_suffix (const char *encoded
, int *len
)
922 while (i
> 0 && (encoded
[i
] == 'b' || encoded
[i
] == 'n'))
925 if (encoded
[i
] != 'X')
931 if (isalnum (encoded
[i
-1]))
935 /* If ENCODED follows the GNAT entity encoding conventions, then return
936 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
939 The resulting string is valid until the next call of ada_decode.
940 If the string is unchanged by decoding, the original string pointer
944 ada_decode (const char *encoded
)
951 static char *decoding_buffer
= NULL
;
952 static size_t decoding_buffer_size
= 0;
954 /* The name of the Ada main procedure starts with "_ada_".
955 This prefix is not part of the decoded name, so skip this part
956 if we see this prefix. */
957 if (strncmp (encoded
, "_ada_", 5) == 0)
960 /* If the name starts with '_', then it is not a properly encoded
961 name, so do not attempt to decode it. Similarly, if the name
962 starts with '<', the name should not be decoded. */
963 if (encoded
[0] == '_' || encoded
[0] == '<')
966 len0
= strlen (encoded
);
968 ada_remove_trailing_digits (encoded
, &len0
);
969 ada_remove_po_subprogram_suffix (encoded
, &len0
);
971 /* Remove the ___X.* suffix if present. Do not forget to verify that
972 the suffix is located before the current "end" of ENCODED. We want
973 to avoid re-matching parts of ENCODED that have previously been
974 marked as discarded (by decrementing LEN0). */
975 p
= strstr (encoded
, "___");
976 if (p
!= NULL
&& p
- encoded
< len0
- 3)
984 /* Remove any trailing TKB suffix. It tells us that this symbol
985 is for the body of a task, but that information does not actually
986 appear in the decoded name. */
988 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
991 /* Remove any trailing TB suffix. The TB suffix is slightly different
992 from the TKB suffix because it is used for non-anonymous task
995 if (len0
> 2 && strncmp (encoded
+ len0
- 2, "TB", 2) == 0)
998 /* Remove trailing "B" suffixes. */
999 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1001 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
1004 /* Make decoded big enough for possible expansion by operator name. */
1006 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
1007 decoded
= decoding_buffer
;
1009 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1011 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1014 while ((i
>= 0 && isdigit (encoded
[i
]))
1015 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1017 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1019 else if (encoded
[i
] == '$')
1023 /* The first few characters that are not alphabetic are not part
1024 of any encoding we use, so we can copy them over verbatim. */
1026 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1027 decoded
[j
] = encoded
[i
];
1032 /* Is this a symbol function? */
1033 if (at_start_name
&& encoded
[i
] == 'O')
1037 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1039 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1040 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1042 && !isalnum (encoded
[i
+ op_len
]))
1044 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1047 j
+= strlen (ada_opname_table
[k
].decoded
);
1051 if (ada_opname_table
[k
].encoded
!= NULL
)
1056 /* Replace "TK__" with "__", which will eventually be translated
1057 into "." (just below). */
1059 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
1062 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1063 be translated into "." (just below). These are internal names
1064 generated for anonymous blocks inside which our symbol is nested. */
1066 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1067 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1068 && isdigit (encoded
[i
+4]))
1072 while (k
< len0
&& isdigit (encoded
[k
]))
1073 k
++; /* Skip any extra digit. */
1075 /* Double-check that the "__B_{DIGITS}+" sequence we found
1076 is indeed followed by "__". */
1077 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1081 /* Remove _E{DIGITS}+[sb] */
1083 /* Just as for protected object subprograms, there are 2 categories
1084 of subprograms created by the compiler for each entry. The first
1085 one implements the actual entry code, and has a suffix following
1086 the convention above; the second one implements the barrier and
1087 uses the same convention as above, except that the 'E' is replaced
1090 Just as above, we do not decode the name of barrier functions
1091 to give the user a clue that the code he is debugging has been
1092 internally generated. */
1094 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1095 && isdigit (encoded
[i
+2]))
1099 while (k
< len0
&& isdigit (encoded
[k
]))
1103 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1106 /* Just as an extra precaution, make sure that if this
1107 suffix is followed by anything else, it is a '_'.
1108 Otherwise, we matched this sequence by accident. */
1110 || (k
< len0
&& encoded
[k
] == '_'))
1115 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1116 the GNAT front-end in protected object subprograms. */
1119 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1121 /* Backtrack a bit up until we reach either the begining of
1122 the encoded name, or "__". Make sure that we only find
1123 digits or lowercase characters. */
1124 const char *ptr
= encoded
+ i
- 1;
1126 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1129 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1133 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1135 /* This is a X[bn]* sequence not separated from the previous
1136 part of the name with a non-alpha-numeric character (in other
1137 words, immediately following an alpha-numeric character), then
1138 verify that it is placed at the end of the encoded name. If
1139 not, then the encoding is not valid and we should abort the
1140 decoding. Otherwise, just skip it, it is used in body-nested
1144 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1148 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1150 /* Replace '__' by '.'. */
1158 /* It's a character part of the decoded name, so just copy it
1160 decoded
[j
] = encoded
[i
];
1165 decoded
[j
] = '\000';
1167 /* Decoded names should never contain any uppercase character.
1168 Double-check this, and abort the decoding if we find one. */
1170 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1171 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1174 if (strcmp (decoded
, encoded
) == 0)
1180 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1181 decoded
= decoding_buffer
;
1182 if (encoded
[0] == '<')
1183 strcpy (decoded
, encoded
);
1185 xsnprintf (decoded
, decoding_buffer_size
, "<%s>", encoded
);
1190 /* Table for keeping permanent unique copies of decoded names. Once
1191 allocated, names in this table are never released. While this is a
1192 storage leak, it should not be significant unless there are massive
1193 changes in the set of decoded names in successive versions of a
1194 symbol table loaded during a single session. */
1195 static struct htab
*decoded_names_store
;
1197 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1198 in the language-specific part of GSYMBOL, if it has not been
1199 previously computed. Tries to save the decoded name in the same
1200 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1201 in any case, the decoded symbol has a lifetime at least that of
1203 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1204 const, but nevertheless modified to a semantically equivalent form
1205 when a decoded name is cached in it.
1209 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1212 (char **) &gsymbol
->language_specific
.mangled_lang
.demangled_name
;
1214 if (*resultp
== NULL
)
1216 const char *decoded
= ada_decode (gsymbol
->name
);
1218 if (gsymbol
->obj_section
!= NULL
)
1220 struct objfile
*objf
= gsymbol
->obj_section
->objfile
;
1222 *resultp
= obsavestring (decoded
, strlen (decoded
),
1223 &objf
->objfile_obstack
);
1225 /* Sometimes, we can't find a corresponding objfile, in which
1226 case, we put the result on the heap. Since we only decode
1227 when needed, we hope this usually does not cause a
1228 significant memory leak (FIXME). */
1229 if (*resultp
== NULL
)
1231 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1235 *slot
= xstrdup (decoded
);
1244 ada_la_decode (const char *encoded
, int options
)
1246 return xstrdup (ada_decode (encoded
));
1249 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1250 suffixes that encode debugging information or leading _ada_ on
1251 SYM_NAME (see is_name_suffix commentary for the debugging
1252 information that is ignored). If WILD, then NAME need only match a
1253 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1254 either argument is NULL. */
1257 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1259 if (sym_name
== NULL
|| name
== NULL
)
1262 return wild_match (sym_name
, name
) == 0;
1265 int len_name
= strlen (name
);
1267 return (strncmp (sym_name
, name
, len_name
) == 0
1268 && is_name_suffix (sym_name
+ len_name
))
1269 || (strncmp (sym_name
, "_ada_", 5) == 0
1270 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1271 && is_name_suffix (sym_name
+ len_name
+ 5));
1278 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1279 generated by the GNAT compiler to describe the index type used
1280 for each dimension of an array, check whether it follows the latest
1281 known encoding. If not, fix it up to conform to the latest encoding.
1282 Otherwise, do nothing. This function also does nothing if
1283 INDEX_DESC_TYPE is NULL.
1285 The GNAT encoding used to describle the array index type evolved a bit.
1286 Initially, the information would be provided through the name of each
1287 field of the structure type only, while the type of these fields was
1288 described as unspecified and irrelevant. The debugger was then expected
1289 to perform a global type lookup using the name of that field in order
1290 to get access to the full index type description. Because these global
1291 lookups can be very expensive, the encoding was later enhanced to make
1292 the global lookup unnecessary by defining the field type as being
1293 the full index type description.
1295 The purpose of this routine is to allow us to support older versions
1296 of the compiler by detecting the use of the older encoding, and by
1297 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1298 we essentially replace each field's meaningless type by the associated
1302 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1306 if (index_desc_type
== NULL
)
1308 gdb_assert (TYPE_NFIELDS (index_desc_type
) > 0);
1310 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1311 to check one field only, no need to check them all). If not, return
1314 If our INDEX_DESC_TYPE was generated using the older encoding,
1315 the field type should be a meaningless integer type whose name
1316 is not equal to the field name. */
1317 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)) != NULL
1318 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)),
1319 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1322 /* Fixup each field of INDEX_DESC_TYPE. */
1323 for (i
= 0; i
< TYPE_NFIELDS (index_desc_type
); i
++)
1325 char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1326 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1329 TYPE_FIELD_TYPE (index_desc_type
, i
) = raw_type
;
1333 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1335 static char *bound_name
[] = {
1336 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1337 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1340 /* Maximum number of array dimensions we are prepared to handle. */
1342 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1344 /* Like modify_field, but allows bitpos > wordlength. */
1347 modify_general_field (struct type
*type
, char *addr
,
1348 LONGEST fieldval
, int bitpos
, int bitsize
)
1350 modify_field (type
, addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1354 /* The desc_* routines return primitive portions of array descriptors
1357 /* The descriptor or array type, if any, indicated by TYPE; removes
1358 level of indirection, if needed. */
1360 static struct type
*
1361 desc_base_type (struct type
*type
)
1365 type
= ada_check_typedef (type
);
1367 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1368 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1369 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1374 /* True iff TYPE indicates a "thin" array pointer type. */
1377 is_thin_pntr (struct type
*type
)
1380 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1381 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1384 /* The descriptor type for thin pointer type TYPE. */
1386 static struct type
*
1387 thin_descriptor_type (struct type
*type
)
1389 struct type
*base_type
= desc_base_type (type
);
1391 if (base_type
== NULL
)
1393 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1397 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1399 if (alt_type
== NULL
)
1406 /* A pointer to the array data for thin-pointer value VAL. */
1408 static struct value
*
1409 thin_data_pntr (struct value
*val
)
1411 struct type
*type
= value_type (val
);
1412 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1414 data_type
= lookup_pointer_type (data_type
);
1416 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1417 return value_cast (data_type
, value_copy (val
));
1419 return value_from_longest (data_type
, value_address (val
));
1422 /* True iff TYPE indicates a "thick" array pointer type. */
1425 is_thick_pntr (struct type
*type
)
1427 type
= desc_base_type (type
);
1428 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1429 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1432 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1433 pointer to one, the type of its bounds data; otherwise, NULL. */
1435 static struct type
*
1436 desc_bounds_type (struct type
*type
)
1440 type
= desc_base_type (type
);
1444 else if (is_thin_pntr (type
))
1446 type
= thin_descriptor_type (type
);
1449 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1451 return ada_check_typedef (r
);
1453 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1455 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1457 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1462 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1463 one, a pointer to its bounds data. Otherwise NULL. */
1465 static struct value
*
1466 desc_bounds (struct value
*arr
)
1468 struct type
*type
= ada_check_typedef (value_type (arr
));
1470 if (is_thin_pntr (type
))
1472 struct type
*bounds_type
=
1473 desc_bounds_type (thin_descriptor_type (type
));
1476 if (bounds_type
== NULL
)
1477 error (_("Bad GNAT array descriptor"));
1479 /* NOTE: The following calculation is not really kosher, but
1480 since desc_type is an XVE-encoded type (and shouldn't be),
1481 the correct calculation is a real pain. FIXME (and fix GCC). */
1482 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1483 addr
= value_as_long (arr
);
1485 addr
= value_address (arr
);
1488 value_from_longest (lookup_pointer_type (bounds_type
),
1489 addr
- TYPE_LENGTH (bounds_type
));
1492 else if (is_thick_pntr (type
))
1494 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1495 _("Bad GNAT array descriptor"));
1496 struct type
*p_bounds_type
= value_type (p_bounds
);
1499 && TYPE_CODE (p_bounds_type
) == TYPE_CODE_PTR
)
1501 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1503 if (TYPE_STUB (target_type
))
1504 p_bounds
= value_cast (lookup_pointer_type
1505 (ada_check_typedef (target_type
)),
1509 error (_("Bad GNAT array descriptor"));
1517 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1518 position of the field containing the address of the bounds data. */
1521 fat_pntr_bounds_bitpos (struct type
*type
)
1523 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1526 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1527 size of the field containing the address of the bounds data. */
1530 fat_pntr_bounds_bitsize (struct type
*type
)
1532 type
= desc_base_type (type
);
1534 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1535 return TYPE_FIELD_BITSIZE (type
, 1);
1537 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1540 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1541 pointer to one, the type of its array data (a array-with-no-bounds type);
1542 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1545 static struct type
*
1546 desc_data_target_type (struct type
*type
)
1548 type
= desc_base_type (type
);
1550 /* NOTE: The following is bogus; see comment in desc_bounds. */
1551 if (is_thin_pntr (type
))
1552 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1));
1553 else if (is_thick_pntr (type
))
1555 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1558 && TYPE_CODE (ada_check_typedef (data_type
)) == TYPE_CODE_PTR
)
1559 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1565 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1568 static struct value
*
1569 desc_data (struct value
*arr
)
1571 struct type
*type
= value_type (arr
);
1573 if (is_thin_pntr (type
))
1574 return thin_data_pntr (arr
);
1575 else if (is_thick_pntr (type
))
1576 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1577 _("Bad GNAT array descriptor"));
1583 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1584 position of the field containing the address of the data. */
1587 fat_pntr_data_bitpos (struct type
*type
)
1589 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1592 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1593 size of the field containing the address of the data. */
1596 fat_pntr_data_bitsize (struct type
*type
)
1598 type
= desc_base_type (type
);
1600 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1601 return TYPE_FIELD_BITSIZE (type
, 0);
1603 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1606 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1607 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1608 bound, if WHICH is 1. The first bound is I=1. */
1610 static struct value
*
1611 desc_one_bound (struct value
*bounds
, int i
, int which
)
1613 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1614 _("Bad GNAT array descriptor bounds"));
1617 /* If BOUNDS is an array-bounds structure type, return the bit position
1618 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1619 bound, if WHICH is 1. The first bound is I=1. */
1622 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1624 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1627 /* If BOUNDS is an array-bounds structure type, return the bit field size
1628 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1629 bound, if WHICH is 1. The first bound is I=1. */
1632 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1634 type
= desc_base_type (type
);
1636 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1637 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1639 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1642 /* If TYPE is the type of an array-bounds structure, the type of its
1643 Ith bound (numbering from 1). Otherwise, NULL. */
1645 static struct type
*
1646 desc_index_type (struct type
*type
, int i
)
1648 type
= desc_base_type (type
);
1650 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1651 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1656 /* The number of index positions in the array-bounds type TYPE.
1657 Return 0 if TYPE is NULL. */
1660 desc_arity (struct type
*type
)
1662 type
= desc_base_type (type
);
1665 return TYPE_NFIELDS (type
) / 2;
1669 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1670 an array descriptor type (representing an unconstrained array
1674 ada_is_direct_array_type (struct type
*type
)
1678 type
= ada_check_typedef (type
);
1679 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1680 || ada_is_array_descriptor_type (type
));
1683 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1687 ada_is_array_type (struct type
*type
)
1690 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1691 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1692 type
= TYPE_TARGET_TYPE (type
);
1693 return ada_is_direct_array_type (type
);
1696 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1699 ada_is_simple_array_type (struct type
*type
)
1703 type
= ada_check_typedef (type
);
1704 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1705 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1706 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1709 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1712 ada_is_array_descriptor_type (struct type
*type
)
1714 struct type
*data_type
= desc_data_target_type (type
);
1718 type
= ada_check_typedef (type
);
1719 return (data_type
!= NULL
1720 && TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
1721 && desc_arity (desc_bounds_type (type
)) > 0);
1724 /* Non-zero iff type is a partially mal-formed GNAT array
1725 descriptor. FIXME: This is to compensate for some problems with
1726 debugging output from GNAT. Re-examine periodically to see if it
1730 ada_is_bogus_array_descriptor (struct type
*type
)
1734 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1735 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1736 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1737 && !ada_is_array_descriptor_type (type
);
1741 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1742 (fat pointer) returns the type of the array data described---specifically,
1743 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1744 in from the descriptor; otherwise, they are left unspecified. If
1745 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1746 returns NULL. The result is simply the type of ARR if ARR is not
1749 ada_type_of_array (struct value
*arr
, int bounds
)
1751 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1752 return decode_constrained_packed_array_type (value_type (arr
));
1754 if (!ada_is_array_descriptor_type (value_type (arr
)))
1755 return value_type (arr
);
1759 struct type
*array_type
=
1760 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1762 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1763 TYPE_FIELD_BITSIZE (array_type
, 0) =
1764 decode_packed_array_bitsize (value_type (arr
));
1770 struct type
*elt_type
;
1772 struct value
*descriptor
;
1774 elt_type
= ada_array_element_type (value_type (arr
), -1);
1775 arity
= ada_array_arity (value_type (arr
));
1777 if (elt_type
== NULL
|| arity
== 0)
1778 return ada_check_typedef (value_type (arr
));
1780 descriptor
= desc_bounds (arr
);
1781 if (value_as_long (descriptor
) == 0)
1785 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1786 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1787 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1788 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1791 create_range_type (range_type
, value_type (low
),
1792 longest_to_int (value_as_long (low
)),
1793 longest_to_int (value_as_long (high
)));
1794 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1796 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1797 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1798 decode_packed_array_bitsize (value_type (arr
));
1801 return lookup_pointer_type (elt_type
);
1805 /* If ARR does not represent an array, returns ARR unchanged.
1806 Otherwise, returns either a standard GDB array with bounds set
1807 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1808 GDB array. Returns NULL if ARR is a null fat pointer. */
1811 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1813 if (ada_is_array_descriptor_type (value_type (arr
)))
1815 struct type
*arrType
= ada_type_of_array (arr
, 1);
1817 if (arrType
== NULL
)
1819 return value_cast (arrType
, value_copy (desc_data (arr
)));
1821 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1822 return decode_constrained_packed_array (arr
);
1827 /* If ARR does not represent an array, returns ARR unchanged.
1828 Otherwise, returns a standard GDB array describing ARR (which may
1829 be ARR itself if it already is in the proper form). */
1831 static struct value
*
1832 ada_coerce_to_simple_array (struct value
*arr
)
1834 if (ada_is_array_descriptor_type (value_type (arr
)))
1836 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1839 error (_("Bounds unavailable for null array pointer."));
1840 check_size (TYPE_TARGET_TYPE (value_type (arrVal
)));
1841 return value_ind (arrVal
);
1843 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1844 return decode_constrained_packed_array (arr
);
1849 /* If TYPE represents a GNAT array type, return it translated to an
1850 ordinary GDB array type (possibly with BITSIZE fields indicating
1851 packing). For other types, is the identity. */
1854 ada_coerce_to_simple_array_type (struct type
*type
)
1856 if (ada_is_constrained_packed_array_type (type
))
1857 return decode_constrained_packed_array_type (type
);
1859 if (ada_is_array_descriptor_type (type
))
1860 return ada_check_typedef (desc_data_target_type (type
));
1865 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1868 ada_is_packed_array_type (struct type
*type
)
1872 type
= desc_base_type (type
);
1873 type
= ada_check_typedef (type
);
1875 ada_type_name (type
) != NULL
1876 && strstr (ada_type_name (type
), "___XP") != NULL
;
1879 /* Non-zero iff TYPE represents a standard GNAT constrained
1880 packed-array type. */
1883 ada_is_constrained_packed_array_type (struct type
*type
)
1885 return ada_is_packed_array_type (type
)
1886 && !ada_is_array_descriptor_type (type
);
1889 /* Non-zero iff TYPE represents an array descriptor for a
1890 unconstrained packed-array type. */
1893 ada_is_unconstrained_packed_array_type (struct type
*type
)
1895 return ada_is_packed_array_type (type
)
1896 && ada_is_array_descriptor_type (type
);
1899 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
1900 return the size of its elements in bits. */
1903 decode_packed_array_bitsize (struct type
*type
)
1905 char *raw_name
= ada_type_name (ada_check_typedef (type
));
1910 raw_name
= ada_type_name (desc_base_type (type
));
1915 tail
= strstr (raw_name
, "___XP");
1917 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1920 (_("could not understand bit size information on packed array"));
1927 /* Given that TYPE is a standard GDB array type with all bounds filled
1928 in, and that the element size of its ultimate scalar constituents
1929 (that is, either its elements, or, if it is an array of arrays, its
1930 elements' elements, etc.) is *ELT_BITS, return an identical type,
1931 but with the bit sizes of its elements (and those of any
1932 constituent arrays) recorded in the BITSIZE components of its
1933 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1936 static struct type
*
1937 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
1939 struct type
*new_elt_type
;
1940 struct type
*new_type
;
1941 LONGEST low_bound
, high_bound
;
1943 type
= ada_check_typedef (type
);
1944 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1947 new_type
= alloc_type_copy (type
);
1949 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1951 create_array_type (new_type
, new_elt_type
, TYPE_INDEX_TYPE (type
));
1952 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1953 TYPE_NAME (new_type
) = ada_type_name (type
);
1955 if (get_discrete_bounds (TYPE_INDEX_TYPE (type
),
1956 &low_bound
, &high_bound
) < 0)
1957 low_bound
= high_bound
= 0;
1958 if (high_bound
< low_bound
)
1959 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1962 *elt_bits
*= (high_bound
- low_bound
+ 1);
1963 TYPE_LENGTH (new_type
) =
1964 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1967 TYPE_FIXED_INSTANCE (new_type
) = 1;
1971 /* The array type encoded by TYPE, where
1972 ada_is_constrained_packed_array_type (TYPE). */
1974 static struct type
*
1975 decode_constrained_packed_array_type (struct type
*type
)
1977 char *raw_name
= ada_type_name (ada_check_typedef (type
));
1980 struct type
*shadow_type
;
1984 raw_name
= ada_type_name (desc_base_type (type
));
1989 name
= (char *) alloca (strlen (raw_name
) + 1);
1990 tail
= strstr (raw_name
, "___XP");
1991 type
= desc_base_type (type
);
1993 memcpy (name
, raw_name
, tail
- raw_name
);
1994 name
[tail
- raw_name
] = '\000';
1996 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
1998 if (shadow_type
== NULL
)
2000 lim_warning (_("could not find bounds information on packed array"));
2003 CHECK_TYPEDEF (shadow_type
);
2005 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
2007 lim_warning (_("could not understand bounds information on packed array"));
2011 bits
= decode_packed_array_bitsize (type
);
2012 return constrained_packed_array_type (shadow_type
, &bits
);
2015 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2016 array, returns a simple array that denotes that array. Its type is a
2017 standard GDB array type except that the BITSIZEs of the array
2018 target types are set to the number of bits in each element, and the
2019 type length is set appropriately. */
2021 static struct value
*
2022 decode_constrained_packed_array (struct value
*arr
)
2026 arr
= ada_coerce_ref (arr
);
2028 /* If our value is a pointer, then dererence it. Make sure that
2029 this operation does not cause the target type to be fixed, as
2030 this would indirectly cause this array to be decoded. The rest
2031 of the routine assumes that the array hasn't been decoded yet,
2032 so we use the basic "value_ind" routine to perform the dereferencing,
2033 as opposed to using "ada_value_ind". */
2034 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
2035 arr
= value_ind (arr
);
2037 type
= decode_constrained_packed_array_type (value_type (arr
));
2040 error (_("can't unpack array"));
2044 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr
)))
2045 && ada_is_modular_type (value_type (arr
)))
2047 /* This is a (right-justified) modular type representing a packed
2048 array with no wrapper. In order to interpret the value through
2049 the (left-justified) packed array type we just built, we must
2050 first left-justify it. */
2051 int bit_size
, bit_pos
;
2054 mod
= ada_modulus (value_type (arr
)) - 1;
2061 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2062 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2063 bit_pos
/ HOST_CHAR_BIT
,
2064 bit_pos
% HOST_CHAR_BIT
,
2069 return coerce_unspec_val_to_type (arr
, type
);
2073 /* The value of the element of packed array ARR at the ARITY indices
2074 given in IND. ARR must be a simple array. */
2076 static struct value
*
2077 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2080 int bits
, elt_off
, bit_off
;
2081 long elt_total_bit_offset
;
2082 struct type
*elt_type
;
2086 elt_total_bit_offset
= 0;
2087 elt_type
= ada_check_typedef (value_type (arr
));
2088 for (i
= 0; i
< arity
; i
+= 1)
2090 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
2091 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2093 (_("attempt to do packed indexing of something other than a packed array"));
2096 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
2097 LONGEST lowerbound
, upperbound
;
2100 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2102 lim_warning (_("don't know bounds of array"));
2103 lowerbound
= upperbound
= 0;
2106 idx
= pos_atr (ind
[i
]);
2107 if (idx
< lowerbound
|| idx
> upperbound
)
2108 lim_warning (_("packed array index %ld out of bounds"), (long) idx
);
2109 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2110 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2111 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2114 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2115 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2117 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2122 /* Non-zero iff TYPE includes negative integer values. */
2125 has_negatives (struct type
*type
)
2127 switch (TYPE_CODE (type
))
2132 return !TYPE_UNSIGNED (type
);
2133 case TYPE_CODE_RANGE
:
2134 return TYPE_LOW_BOUND (type
) < 0;
2139 /* Create a new value of type TYPE from the contents of OBJ starting
2140 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2141 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2142 assigning through the result will set the field fetched from.
2143 VALADDR is ignored unless OBJ is NULL, in which case,
2144 VALADDR+OFFSET must address the start of storage containing the
2145 packed value. The value returned in this case is never an lval.
2146 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2149 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2150 long offset
, int bit_offset
, int bit_size
,
2154 int src
, /* Index into the source area */
2155 targ
, /* Index into the target area */
2156 srcBitsLeft
, /* Number of source bits left to move */
2157 nsrc
, ntarg
, /* Number of source and target bytes */
2158 unusedLS
, /* Number of bits in next significant
2159 byte of source that are unused */
2160 accumSize
; /* Number of meaningful bits in accum */
2161 unsigned char *bytes
; /* First byte containing data to unpack */
2162 unsigned char *unpacked
;
2163 unsigned long accum
; /* Staging area for bits being transferred */
2165 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2166 /* Transmit bytes from least to most significant; delta is the direction
2167 the indices move. */
2168 int delta
= gdbarch_bits_big_endian (get_type_arch (type
)) ? -1 : 1;
2170 type
= ada_check_typedef (type
);
2174 v
= allocate_value (type
);
2175 bytes
= (unsigned char *) (valaddr
+ offset
);
2177 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2180 value_address (obj
) + offset
);
2181 bytes
= (unsigned char *) alloca (len
);
2182 read_memory (value_address (v
), bytes
, len
);
2186 v
= allocate_value (type
);
2187 bytes
= (unsigned char *) value_contents (obj
) + offset
;
2194 set_value_component_location (v
, obj
);
2195 new_addr
= value_address (obj
) + offset
;
2196 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2197 set_value_bitsize (v
, bit_size
);
2198 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2201 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2203 set_value_address (v
, new_addr
);
2206 set_value_bitsize (v
, bit_size
);
2207 unpacked
= (unsigned char *) value_contents (v
);
2209 srcBitsLeft
= bit_size
;
2211 ntarg
= TYPE_LENGTH (type
);
2215 memset (unpacked
, 0, TYPE_LENGTH (type
));
2218 else if (gdbarch_bits_big_endian (get_type_arch (type
)))
2221 if (has_negatives (type
)
2222 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2226 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2229 switch (TYPE_CODE (type
))
2231 case TYPE_CODE_ARRAY
:
2232 case TYPE_CODE_UNION
:
2233 case TYPE_CODE_STRUCT
:
2234 /* Non-scalar values must be aligned at a byte boundary... */
2236 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2237 /* ... And are placed at the beginning (most-significant) bytes
2239 targ
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2244 targ
= TYPE_LENGTH (type
) - 1;
2250 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2253 unusedLS
= bit_offset
;
2256 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
2263 /* Mask for removing bits of the next source byte that are not
2264 part of the value. */
2265 unsigned int unusedMSMask
=
2266 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2268 /* Sign-extend bits for this byte. */
2269 unsigned int signMask
= sign
& ~unusedMSMask
;
2272 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2273 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2274 if (accumSize
>= HOST_CHAR_BIT
)
2276 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2277 accumSize
-= HOST_CHAR_BIT
;
2278 accum
>>= HOST_CHAR_BIT
;
2282 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2289 accum
|= sign
<< accumSize
;
2290 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2291 accumSize
-= HOST_CHAR_BIT
;
2292 accum
>>= HOST_CHAR_BIT
;
2300 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2301 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2304 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
2305 int src_offset
, int n
, int bits_big_endian_p
)
2307 unsigned int accum
, mask
;
2308 int accum_bits
, chunk_size
;
2310 target
+= targ_offset
/ HOST_CHAR_BIT
;
2311 targ_offset
%= HOST_CHAR_BIT
;
2312 source
+= src_offset
/ HOST_CHAR_BIT
;
2313 src_offset
%= HOST_CHAR_BIT
;
2314 if (bits_big_endian_p
)
2316 accum
= (unsigned char) *source
;
2318 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2324 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2325 accum_bits
+= HOST_CHAR_BIT
;
2327 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2330 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2331 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2334 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2336 accum_bits
-= chunk_size
;
2343 accum
= (unsigned char) *source
>> src_offset
;
2345 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2349 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2350 accum_bits
+= HOST_CHAR_BIT
;
2352 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2355 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2356 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2358 accum_bits
-= chunk_size
;
2359 accum
>>= chunk_size
;
2366 /* Store the contents of FROMVAL into the location of TOVAL.
2367 Return a new value with the location of TOVAL and contents of
2368 FROMVAL. Handles assignment into packed fields that have
2369 floating-point or non-scalar types. */
2371 static struct value
*
2372 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2374 struct type
*type
= value_type (toval
);
2375 int bits
= value_bitsize (toval
);
2377 toval
= ada_coerce_ref (toval
);
2378 fromval
= ada_coerce_ref (fromval
);
2380 if (ada_is_direct_array_type (value_type (toval
)))
2381 toval
= ada_coerce_to_simple_array (toval
);
2382 if (ada_is_direct_array_type (value_type (fromval
)))
2383 fromval
= ada_coerce_to_simple_array (fromval
);
2385 if (!deprecated_value_modifiable (toval
))
2386 error (_("Left operand of assignment is not a modifiable lvalue."));
2388 if (VALUE_LVAL (toval
) == lval_memory
2390 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2391 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2393 int len
= (value_bitpos (toval
)
2394 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2396 char *buffer
= (char *) alloca (len
);
2398 CORE_ADDR to_addr
= value_address (toval
);
2400 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2401 fromval
= value_cast (type
, fromval
);
2403 read_memory (to_addr
, buffer
, len
);
2404 from_size
= value_bitsize (fromval
);
2406 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2407 if (gdbarch_bits_big_endian (get_type_arch (type
)))
2408 move_bits (buffer
, value_bitpos (toval
),
2409 value_contents (fromval
), from_size
- bits
, bits
, 1);
2411 move_bits (buffer
, value_bitpos (toval
),
2412 value_contents (fromval
), 0, bits
, 0);
2413 write_memory (to_addr
, buffer
, len
);
2414 observer_notify_memory_changed (to_addr
, len
, buffer
);
2416 val
= value_copy (toval
);
2417 memcpy (value_contents_raw (val
), value_contents (fromval
),
2418 TYPE_LENGTH (type
));
2419 deprecated_set_value_type (val
, type
);
2424 return value_assign (toval
, fromval
);
2428 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2429 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2430 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2431 * COMPONENT, and not the inferior's memory. The current contents
2432 * of COMPONENT are ignored. */
2434 value_assign_to_component (struct value
*container
, struct value
*component
,
2437 LONGEST offset_in_container
=
2438 (LONGEST
) (value_address (component
) - value_address (container
));
2439 int bit_offset_in_container
=
2440 value_bitpos (component
) - value_bitpos (container
);
2443 val
= value_cast (value_type (component
), val
);
2445 if (value_bitsize (component
) == 0)
2446 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2448 bits
= value_bitsize (component
);
2450 if (gdbarch_bits_big_endian (get_type_arch (value_type (container
))))
2451 move_bits (value_contents_writeable (container
) + offset_in_container
,
2452 value_bitpos (container
) + bit_offset_in_container
,
2453 value_contents (val
),
2454 TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
,
2457 move_bits (value_contents_writeable (container
) + offset_in_container
,
2458 value_bitpos (container
) + bit_offset_in_container
,
2459 value_contents (val
), 0, bits
, 0);
2462 /* The value of the element of array ARR at the ARITY indices given in IND.
2463 ARR may be either a simple array, GNAT array descriptor, or pointer
2467 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2471 struct type
*elt_type
;
2473 elt
= ada_coerce_to_simple_array (arr
);
2475 elt_type
= ada_check_typedef (value_type (elt
));
2476 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2477 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2478 return value_subscript_packed (elt
, arity
, ind
);
2480 for (k
= 0; k
< arity
; k
+= 1)
2482 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2483 error (_("too many subscripts (%d expected)"), k
);
2484 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2489 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2490 value of the element of *ARR at the ARITY indices given in
2491 IND. Does not read the entire array into memory. */
2493 static struct value
*
2494 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2499 for (k
= 0; k
< arity
; k
+= 1)
2503 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2504 error (_("too many subscripts (%d expected)"), k
);
2505 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2507 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2508 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2509 type
= TYPE_TARGET_TYPE (type
);
2512 return value_ind (arr
);
2515 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2516 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2517 elements starting at index LOW. The lower bound of this array is LOW, as
2519 static struct value
*
2520 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2523 CORE_ADDR base
= value_as_address (array_ptr
)
2524 + ((low
- ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type
)))
2525 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2526 struct type
*index_type
=
2527 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2529 struct type
*slice_type
=
2530 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2532 return value_at_lazy (slice_type
, base
);
2536 static struct value
*
2537 ada_value_slice (struct value
*array
, int low
, int high
)
2539 struct type
*type
= value_type (array
);
2540 struct type
*index_type
=
2541 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2542 struct type
*slice_type
=
2543 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2545 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2548 /* If type is a record type in the form of a standard GNAT array
2549 descriptor, returns the number of dimensions for type. If arr is a
2550 simple array, returns the number of "array of"s that prefix its
2551 type designation. Otherwise, returns 0. */
2554 ada_array_arity (struct type
*type
)
2561 type
= desc_base_type (type
);
2564 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2565 return desc_arity (desc_bounds_type (type
));
2567 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2570 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2576 /* If TYPE is a record type in the form of a standard GNAT array
2577 descriptor or a simple array type, returns the element type for
2578 TYPE after indexing by NINDICES indices, or by all indices if
2579 NINDICES is -1. Otherwise, returns NULL. */
2582 ada_array_element_type (struct type
*type
, int nindices
)
2584 type
= desc_base_type (type
);
2586 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2589 struct type
*p_array_type
;
2591 p_array_type
= desc_data_target_type (type
);
2593 k
= ada_array_arity (type
);
2597 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2598 if (nindices
>= 0 && k
> nindices
)
2600 while (k
> 0 && p_array_type
!= NULL
)
2602 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2605 return p_array_type
;
2607 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2609 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2611 type
= TYPE_TARGET_TYPE (type
);
2620 /* The type of nth index in arrays of given type (n numbering from 1).
2621 Does not examine memory. Throws an error if N is invalid or TYPE
2622 is not an array type. NAME is the name of the Ada attribute being
2623 evaluated ('range, 'first, 'last, or 'length); it is used in building
2624 the error message. */
2626 static struct type
*
2627 ada_index_type (struct type
*type
, int n
, const char *name
)
2629 struct type
*result_type
;
2631 type
= desc_base_type (type
);
2633 if (n
< 0 || n
> ada_array_arity (type
))
2634 error (_("invalid dimension number to '%s"), name
);
2636 if (ada_is_simple_array_type (type
))
2640 for (i
= 1; i
< n
; i
+= 1)
2641 type
= TYPE_TARGET_TYPE (type
);
2642 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2643 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2644 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2645 perhaps stabsread.c would make more sense. */
2646 if (result_type
&& TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2651 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2652 if (result_type
== NULL
)
2653 error (_("attempt to take bound of something that is not an array"));
2659 /* Given that arr is an array type, returns the lower bound of the
2660 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2661 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2662 array-descriptor type. It works for other arrays with bounds supplied
2663 by run-time quantities other than discriminants. */
2666 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
)
2668 struct type
*type
, *elt_type
, *index_type_desc
, *index_type
;
2671 gdb_assert (which
== 0 || which
== 1);
2673 if (ada_is_constrained_packed_array_type (arr_type
))
2674 arr_type
= decode_constrained_packed_array_type (arr_type
);
2676 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2677 return (LONGEST
) - which
;
2679 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2680 type
= TYPE_TARGET_TYPE (arr_type
);
2685 for (i
= n
; i
> 1; i
--)
2686 elt_type
= TYPE_TARGET_TYPE (type
);
2688 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2689 ada_fixup_array_indexes_type (index_type_desc
);
2690 if (index_type_desc
!= NULL
)
2691 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, n
- 1),
2694 index_type
= TYPE_INDEX_TYPE (elt_type
);
2697 (LONGEST
) (which
== 0
2698 ? ada_discrete_type_low_bound (index_type
)
2699 : ada_discrete_type_high_bound (index_type
));
2702 /* Given that arr is an array value, returns the lower bound of the
2703 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2704 WHICH is 1. This routine will also work for arrays with bounds
2705 supplied by run-time quantities other than discriminants. */
2708 ada_array_bound (struct value
*arr
, int n
, int which
)
2710 struct type
*arr_type
= value_type (arr
);
2712 if (ada_is_constrained_packed_array_type (arr_type
))
2713 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
2714 else if (ada_is_simple_array_type (arr_type
))
2715 return ada_array_bound_from_type (arr_type
, n
, which
);
2717 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
2720 /* Given that arr is an array value, returns the length of the
2721 nth index. This routine will also work for arrays with bounds
2722 supplied by run-time quantities other than discriminants.
2723 Does not work for arrays indexed by enumeration types with representation
2724 clauses at the moment. */
2727 ada_array_length (struct value
*arr
, int n
)
2729 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2731 if (ada_is_constrained_packed_array_type (arr_type
))
2732 return ada_array_length (decode_constrained_packed_array (arr
), n
);
2734 if (ada_is_simple_array_type (arr_type
))
2735 return (ada_array_bound_from_type (arr_type
, n
, 1)
2736 - ada_array_bound_from_type (arr_type
, n
, 0) + 1);
2738 return (value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1))
2739 - value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0)) + 1);
2742 /* An empty array whose type is that of ARR_TYPE (an array type),
2743 with bounds LOW to LOW-1. */
2745 static struct value
*
2746 empty_array (struct type
*arr_type
, int low
)
2748 struct type
*index_type
=
2749 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2751 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2753 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2757 /* Name resolution */
2759 /* The "decoded" name for the user-definable Ada operator corresponding
2763 ada_decoded_op_name (enum exp_opcode op
)
2767 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2769 if (ada_opname_table
[i
].op
== op
)
2770 return ada_opname_table
[i
].decoded
;
2772 error (_("Could not find operator name for opcode"));
2776 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2777 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2778 undefined namespace) and converts operators that are
2779 user-defined into appropriate function calls. If CONTEXT_TYPE is
2780 non-null, it provides a preferred result type [at the moment, only
2781 type void has any effect---causing procedures to be preferred over
2782 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2783 return type is preferred. May change (expand) *EXP. */
2786 resolve (struct expression
**expp
, int void_context_p
)
2788 struct type
*context_type
= NULL
;
2792 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
2794 resolve_subexp (expp
, &pc
, 1, context_type
);
2797 /* Resolve the operator of the subexpression beginning at
2798 position *POS of *EXPP. "Resolving" consists of replacing
2799 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2800 with their resolutions, replacing built-in operators with
2801 function calls to user-defined operators, where appropriate, and,
2802 when DEPROCEDURE_P is non-zero, converting function-valued variables
2803 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2804 are as in ada_resolve, above. */
2806 static struct value
*
2807 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2808 struct type
*context_type
)
2812 struct expression
*exp
; /* Convenience: == *expp. */
2813 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2814 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2815 int nargs
; /* Number of operands. */
2822 /* Pass one: resolve operands, saving their types and updating *pos,
2827 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2828 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2833 resolve_subexp (expp
, pos
, 0, NULL
);
2835 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2840 resolve_subexp (expp
, pos
, 0, NULL
);
2845 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
));
2848 case OP_ATR_MODULUS
:
2858 case TERNOP_IN_RANGE
:
2859 case BINOP_IN_BOUNDS
:
2865 case OP_DISCRETE_RANGE
:
2867 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
2876 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2878 resolve_subexp (expp
, pos
, 1, NULL
);
2880 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2897 case BINOP_LOGICAL_AND
:
2898 case BINOP_LOGICAL_OR
:
2899 case BINOP_BITWISE_AND
:
2900 case BINOP_BITWISE_IOR
:
2901 case BINOP_BITWISE_XOR
:
2904 case BINOP_NOTEQUAL
:
2911 case BINOP_SUBSCRIPT
:
2919 case UNOP_LOGICAL_NOT
:
2935 case OP_INTERNALVAR
:
2945 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2948 case STRUCTOP_STRUCT
:
2949 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2962 error (_("Unexpected operator during name resolution"));
2965 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2966 for (i
= 0; i
< nargs
; i
+= 1)
2967 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2971 /* Pass two: perform any resolution on principal operator. */
2978 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2980 struct ada_symbol_info
*candidates
;
2984 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2985 (exp
->elts
[pc
+ 2].symbol
),
2986 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2989 if (n_candidates
> 1)
2991 /* Types tend to get re-introduced locally, so if there
2992 are any local symbols that are not types, first filter
2995 for (j
= 0; j
< n_candidates
; j
+= 1)
2996 switch (SYMBOL_CLASS (candidates
[j
].sym
))
3001 case LOC_REGPARM_ADDR
:
3009 if (j
< n_candidates
)
3012 while (j
< n_candidates
)
3014 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
3016 candidates
[j
] = candidates
[n_candidates
- 1];
3025 if (n_candidates
== 0)
3026 error (_("No definition found for %s"),
3027 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3028 else if (n_candidates
== 1)
3030 else if (deprocedure_p
3031 && !is_nonfunction (candidates
, n_candidates
))
3033 i
= ada_resolve_function
3034 (candidates
, n_candidates
, NULL
, 0,
3035 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
3038 error (_("Could not find a match for %s"),
3039 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3043 printf_filtered (_("Multiple matches for %s\n"),
3044 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3045 user_select_syms (candidates
, n_candidates
, 1);
3049 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3050 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
3051 if (innermost_block
== NULL
3052 || contained_in (candidates
[i
].block
, innermost_block
))
3053 innermost_block
= candidates
[i
].block
;
3057 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
3060 replace_operator_with_call (expp
, pc
, 0, 0,
3061 exp
->elts
[pc
+ 2].symbol
,
3062 exp
->elts
[pc
+ 1].block
);
3069 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3070 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3072 struct ada_symbol_info
*candidates
;
3076 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3077 (exp
->elts
[pc
+ 5].symbol
),
3078 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3080 if (n_candidates
== 1)
3084 i
= ada_resolve_function
3085 (candidates
, n_candidates
,
3087 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
3090 error (_("Could not find a match for %s"),
3091 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
3094 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3095 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
3096 if (innermost_block
== NULL
3097 || contained_in (candidates
[i
].block
, innermost_block
))
3098 innermost_block
= candidates
[i
].block
;
3109 case BINOP_BITWISE_AND
:
3110 case BINOP_BITWISE_IOR
:
3111 case BINOP_BITWISE_XOR
:
3113 case BINOP_NOTEQUAL
:
3121 case UNOP_LOGICAL_NOT
:
3123 if (possible_user_operator_p (op
, argvec
))
3125 struct ada_symbol_info
*candidates
;
3129 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
3130 (struct block
*) NULL
, VAR_DOMAIN
,
3132 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
3133 ada_decoded_op_name (op
), NULL
);
3137 replace_operator_with_call (expp
, pc
, nargs
, 1,
3138 candidates
[i
].sym
, candidates
[i
].block
);
3149 return evaluate_subexp_type (exp
, pos
);
3152 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3153 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3155 /* The term "match" here is rather loose. The match is heuristic and
3159 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3161 ftype
= ada_check_typedef (ftype
);
3162 atype
= ada_check_typedef (atype
);
3164 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3165 ftype
= TYPE_TARGET_TYPE (ftype
);
3166 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3167 atype
= TYPE_TARGET_TYPE (atype
);
3169 switch (TYPE_CODE (ftype
))
3172 return TYPE_CODE (ftype
) == TYPE_CODE (atype
);
3174 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3175 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3176 TYPE_TARGET_TYPE (atype
), 0);
3179 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3181 case TYPE_CODE_ENUM
:
3182 case TYPE_CODE_RANGE
:
3183 switch (TYPE_CODE (atype
))
3186 case TYPE_CODE_ENUM
:
3187 case TYPE_CODE_RANGE
:
3193 case TYPE_CODE_ARRAY
:
3194 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3195 || ada_is_array_descriptor_type (atype
));
3197 case TYPE_CODE_STRUCT
:
3198 if (ada_is_array_descriptor_type (ftype
))
3199 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3200 || ada_is_array_descriptor_type (atype
));
3202 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3203 && !ada_is_array_descriptor_type (atype
));
3205 case TYPE_CODE_UNION
:
3207 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3211 /* Return non-zero if the formals of FUNC "sufficiently match" the
3212 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3213 may also be an enumeral, in which case it is treated as a 0-
3214 argument function. */
3217 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3220 struct type
*func_type
= SYMBOL_TYPE (func
);
3222 if (SYMBOL_CLASS (func
) == LOC_CONST
3223 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3224 return (n_actuals
== 0);
3225 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3228 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3231 for (i
= 0; i
< n_actuals
; i
+= 1)
3233 if (actuals
[i
] == NULL
)
3237 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
,
3239 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3241 if (!ada_type_match (ftype
, atype
, 1))
3248 /* False iff function type FUNC_TYPE definitely does not produce a value
3249 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3250 FUNC_TYPE is not a valid function type with a non-null return type
3251 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3254 return_match (struct type
*func_type
, struct type
*context_type
)
3256 struct type
*return_type
;
3258 if (func_type
== NULL
)
3261 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3262 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
3264 return_type
= base_type (func_type
);
3265 if (return_type
== NULL
)
3268 context_type
= base_type (context_type
);
3270 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3271 return context_type
== NULL
|| return_type
== context_type
;
3272 else if (context_type
== NULL
)
3273 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3275 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3279 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3280 function (if any) that matches the types of the NARGS arguments in
3281 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3282 that returns that type, then eliminate matches that don't. If
3283 CONTEXT_TYPE is void and there is at least one match that does not
3284 return void, eliminate all matches that do.
3286 Asks the user if there is more than one match remaining. Returns -1
3287 if there is no such symbol or none is selected. NAME is used
3288 solely for messages. May re-arrange and modify SYMS in
3289 the process; the index returned is for the modified vector. */
3292 ada_resolve_function (struct ada_symbol_info syms
[],
3293 int nsyms
, struct value
**args
, int nargs
,
3294 const char *name
, struct type
*context_type
)
3298 int m
; /* Number of hits */
3301 /* In the first pass of the loop, we only accept functions matching
3302 context_type. If none are found, we add a second pass of the loop
3303 where every function is accepted. */
3304 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3306 for (k
= 0; k
< nsyms
; k
+= 1)
3308 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3310 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3311 && (fallback
|| return_match (type
, context_type
)))
3323 printf_filtered (_("Multiple matches for %s\n"), name
);
3324 user_select_syms (syms
, m
, 1);
3330 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3331 in a listing of choices during disambiguation (see sort_choices, below).
3332 The idea is that overloadings of a subprogram name from the
3333 same package should sort in their source order. We settle for ordering
3334 such symbols by their trailing number (__N or $N). */
3337 encoded_ordered_before (char *N0
, char *N1
)
3341 else if (N0
== NULL
)
3347 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3349 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3351 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3352 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3357 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3360 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3362 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3363 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3365 return (strcmp (N0
, N1
) < 0);
3369 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3373 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3377 for (i
= 1; i
< nsyms
; i
+= 1)
3379 struct ada_symbol_info sym
= syms
[i
];
3382 for (j
= i
- 1; j
>= 0; j
-= 1)
3384 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3385 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3387 syms
[j
+ 1] = syms
[j
];
3393 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3394 by asking the user (if necessary), returning the number selected,
3395 and setting the first elements of SYMS items. Error if no symbols
3398 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3399 to be re-integrated one of these days. */
3402 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3405 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3407 int first_choice
= (max_results
== 1) ? 1 : 2;
3408 const char *select_mode
= multiple_symbols_select_mode ();
3410 if (max_results
< 1)
3411 error (_("Request to select 0 symbols!"));
3415 if (select_mode
== multiple_symbols_cancel
)
3417 canceled because the command is ambiguous\n\
3418 See set/show multiple-symbol."));
3420 /* If select_mode is "all", then return all possible symbols.
3421 Only do that if more than one symbol can be selected, of course.
3422 Otherwise, display the menu as usual. */
3423 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3426 printf_unfiltered (_("[0] cancel\n"));
3427 if (max_results
> 1)
3428 printf_unfiltered (_("[1] all\n"));
3430 sort_choices (syms
, nsyms
);
3432 for (i
= 0; i
< nsyms
; i
+= 1)
3434 if (syms
[i
].sym
== NULL
)
3437 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3439 struct symtab_and_line sal
=
3440 find_function_start_sal (syms
[i
].sym
, 1);
3442 if (sal
.symtab
== NULL
)
3443 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3445 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3448 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3449 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3450 sal
.symtab
->filename
, sal
.line
);
3456 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3457 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3458 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3459 struct symtab
*symtab
= syms
[i
].sym
->symtab
;
3461 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3462 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3464 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3465 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3466 else if (is_enumeral
3467 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3469 printf_unfiltered (("[%d] "), i
+ first_choice
);
3470 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3472 printf_unfiltered (_("'(%s) (enumeral)\n"),
3473 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3475 else if (symtab
!= NULL
)
3476 printf_unfiltered (is_enumeral
3477 ? _("[%d] %s in %s (enumeral)\n")
3478 : _("[%d] %s at %s:?\n"),
3480 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3483 printf_unfiltered (is_enumeral
3484 ? _("[%d] %s (enumeral)\n")
3485 : _("[%d] %s at ?\n"),
3487 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3491 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3494 for (i
= 0; i
< n_chosen
; i
+= 1)
3495 syms
[i
] = syms
[chosen
[i
]];
3500 /* Read and validate a set of numeric choices from the user in the
3501 range 0 .. N_CHOICES-1. Place the results in increasing
3502 order in CHOICES[0 .. N-1], and return N.
3504 The user types choices as a sequence of numbers on one line
3505 separated by blanks, encoding them as follows:
3507 + A choice of 0 means to cancel the selection, throwing an error.
3508 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3509 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3511 The user is not allowed to choose more than MAX_RESULTS values.
3513 ANNOTATION_SUFFIX, if present, is used to annotate the input
3514 prompts (for use with the -f switch). */
3517 get_selections (int *choices
, int n_choices
, int max_results
,
3518 int is_all_choice
, char *annotation_suffix
)
3523 int first_choice
= is_all_choice
? 2 : 1;
3525 prompt
= getenv ("PS2");
3529 args
= command_line_input (prompt
, 0, annotation_suffix
);
3532 error_no_arg (_("one or more choice numbers"));
3536 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3537 order, as given in args. Choices are validated. */
3543 while (isspace (*args
))
3545 if (*args
== '\0' && n_chosen
== 0)
3546 error_no_arg (_("one or more choice numbers"));
3547 else if (*args
== '\0')
3550 choice
= strtol (args
, &args2
, 10);
3551 if (args
== args2
|| choice
< 0
3552 || choice
> n_choices
+ first_choice
- 1)
3553 error (_("Argument must be choice number"));
3557 error (_("cancelled"));
3559 if (choice
< first_choice
)
3561 n_chosen
= n_choices
;
3562 for (j
= 0; j
< n_choices
; j
+= 1)
3566 choice
-= first_choice
;
3568 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3572 if (j
< 0 || choice
!= choices
[j
])
3576 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3577 choices
[k
+ 1] = choices
[k
];
3578 choices
[j
+ 1] = choice
;
3583 if (n_chosen
> max_results
)
3584 error (_("Select no more than %d of the above"), max_results
);
3589 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3590 on the function identified by SYM and BLOCK, and taking NARGS
3591 arguments. Update *EXPP as needed to hold more space. */
3594 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3595 int oplen
, struct symbol
*sym
,
3596 struct block
*block
)
3598 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3599 symbol, -oplen for operator being replaced). */
3600 struct expression
*newexp
= (struct expression
*)
3601 xmalloc (sizeof (struct expression
)
3602 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3603 struct expression
*exp
= *expp
;
3605 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3606 newexp
->language_defn
= exp
->language_defn
;
3607 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3608 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3609 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3611 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3612 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3614 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3615 newexp
->elts
[pc
+ 4].block
= block
;
3616 newexp
->elts
[pc
+ 5].symbol
= sym
;
3622 /* Type-class predicates */
3624 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3628 numeric_type_p (struct type
*type
)
3634 switch (TYPE_CODE (type
))
3639 case TYPE_CODE_RANGE
:
3640 return (type
== TYPE_TARGET_TYPE (type
)
3641 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3648 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3651 integer_type_p (struct type
*type
)
3657 switch (TYPE_CODE (type
))
3661 case TYPE_CODE_RANGE
:
3662 return (type
== TYPE_TARGET_TYPE (type
)
3663 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3670 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3673 scalar_type_p (struct type
*type
)
3679 switch (TYPE_CODE (type
))
3682 case TYPE_CODE_RANGE
:
3683 case TYPE_CODE_ENUM
:
3692 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3695 discrete_type_p (struct type
*type
)
3701 switch (TYPE_CODE (type
))
3704 case TYPE_CODE_RANGE
:
3705 case TYPE_CODE_ENUM
:
3706 case TYPE_CODE_BOOL
:
3714 /* Returns non-zero if OP with operands in the vector ARGS could be
3715 a user-defined function. Errs on the side of pre-defined operators
3716 (i.e., result 0). */
3719 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3721 struct type
*type0
=
3722 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3723 struct type
*type1
=
3724 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3738 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3742 case BINOP_BITWISE_AND
:
3743 case BINOP_BITWISE_IOR
:
3744 case BINOP_BITWISE_XOR
:
3745 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3748 case BINOP_NOTEQUAL
:
3753 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3756 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
3759 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3763 case UNOP_LOGICAL_NOT
:
3765 return (!numeric_type_p (type0
));
3774 1. In the following, we assume that a renaming type's name may
3775 have an ___XD suffix. It would be nice if this went away at some
3777 2. We handle both the (old) purely type-based representation of
3778 renamings and the (new) variable-based encoding. At some point,
3779 it is devoutly to be hoped that the former goes away
3780 (FIXME: hilfinger-2007-07-09).
3781 3. Subprogram renamings are not implemented, although the XRS
3782 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3784 /* If SYM encodes a renaming,
3786 <renaming> renames <renamed entity>,
3788 sets *LEN to the length of the renamed entity's name,
3789 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3790 the string describing the subcomponent selected from the renamed
3791 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3792 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3793 are undefined). Otherwise, returns a value indicating the category
3794 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3795 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3796 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3797 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3798 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3799 may be NULL, in which case they are not assigned.
3801 [Currently, however, GCC does not generate subprogram renamings.] */
3803 enum ada_renaming_category
3804 ada_parse_renaming (struct symbol
*sym
,
3805 const char **renamed_entity
, int *len
,
3806 const char **renaming_expr
)
3808 enum ada_renaming_category kind
;
3813 return ADA_NOT_RENAMING
;
3814 switch (SYMBOL_CLASS (sym
))
3817 return ADA_NOT_RENAMING
;
3819 return parse_old_style_renaming (SYMBOL_TYPE (sym
),
3820 renamed_entity
, len
, renaming_expr
);
3824 case LOC_OPTIMIZED_OUT
:
3825 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
3827 return ADA_NOT_RENAMING
;
3831 kind
= ADA_OBJECT_RENAMING
;
3835 kind
= ADA_EXCEPTION_RENAMING
;
3839 kind
= ADA_PACKAGE_RENAMING
;
3843 kind
= ADA_SUBPROGRAM_RENAMING
;
3847 return ADA_NOT_RENAMING
;
3851 if (renamed_entity
!= NULL
)
3852 *renamed_entity
= info
;
3853 suffix
= strstr (info
, "___XE");
3854 if (suffix
== NULL
|| suffix
== info
)
3855 return ADA_NOT_RENAMING
;
3857 *len
= strlen (info
) - strlen (suffix
);
3859 if (renaming_expr
!= NULL
)
3860 *renaming_expr
= suffix
;
3864 /* Assuming TYPE encodes a renaming according to the old encoding in
3865 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3866 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3867 ADA_NOT_RENAMING otherwise. */
3868 static enum ada_renaming_category
3869 parse_old_style_renaming (struct type
*type
,
3870 const char **renamed_entity
, int *len
,
3871 const char **renaming_expr
)
3873 enum ada_renaming_category kind
;
3878 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
3879 || TYPE_NFIELDS (type
) != 1)
3880 return ADA_NOT_RENAMING
;
3882 name
= type_name_no_tag (type
);
3884 return ADA_NOT_RENAMING
;
3886 name
= strstr (name
, "___XR");
3888 return ADA_NOT_RENAMING
;
3893 kind
= ADA_OBJECT_RENAMING
;
3896 kind
= ADA_EXCEPTION_RENAMING
;
3899 kind
= ADA_PACKAGE_RENAMING
;
3902 kind
= ADA_SUBPROGRAM_RENAMING
;
3905 return ADA_NOT_RENAMING
;
3908 info
= TYPE_FIELD_NAME (type
, 0);
3910 return ADA_NOT_RENAMING
;
3911 if (renamed_entity
!= NULL
)
3912 *renamed_entity
= info
;
3913 suffix
= strstr (info
, "___XE");
3914 if (renaming_expr
!= NULL
)
3915 *renaming_expr
= suffix
+ 5;
3916 if (suffix
== NULL
|| suffix
== info
)
3917 return ADA_NOT_RENAMING
;
3919 *len
= suffix
- info
;
3925 /* Evaluation: Function Calls */
3927 /* Return an lvalue containing the value VAL. This is the identity on
3928 lvalues, and otherwise has the side-effect of allocating memory
3929 in the inferior where a copy of the value contents is copied. */
3931 static struct value
*
3932 ensure_lval (struct value
*val
)
3934 if (VALUE_LVAL (val
) == not_lval
3935 || VALUE_LVAL (val
) == lval_internalvar
)
3937 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3938 const CORE_ADDR addr
=
3939 value_as_long (value_allocate_space_in_inferior (len
));
3941 set_value_address (val
, addr
);
3942 VALUE_LVAL (val
) = lval_memory
;
3943 write_memory (addr
, value_contents (val
), len
);
3949 /* Return the value ACTUAL, converted to be an appropriate value for a
3950 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3951 allocating any necessary descriptors (fat pointers), or copies of
3952 values not residing in memory, updating it as needed. */
3955 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
3957 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3958 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3959 struct type
*formal_target
=
3960 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3961 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3962 struct type
*actual_target
=
3963 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3964 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3966 if (ada_is_array_descriptor_type (formal_target
)
3967 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3968 return make_array_descriptor (formal_type
, actual
);
3969 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3970 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
3972 struct value
*result
;
3974 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3975 && ada_is_array_descriptor_type (actual_target
))
3976 result
= desc_data (actual
);
3977 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3979 if (VALUE_LVAL (actual
) != lval_memory
)
3983 actual_type
= ada_check_typedef (value_type (actual
));
3984 val
= allocate_value (actual_type
);
3985 memcpy ((char *) value_contents_raw (val
),
3986 (char *) value_contents (actual
),
3987 TYPE_LENGTH (actual_type
));
3988 actual
= ensure_lval (val
);
3990 result
= value_addr (actual
);
3994 return value_cast_pointers (formal_type
, result
);
3996 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3997 return ada_value_ind (actual
);
4002 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4003 type TYPE. This is usually an inefficient no-op except on some targets
4004 (such as AVR) where the representation of a pointer and an address
4008 value_pointer (struct value
*value
, struct type
*type
)
4010 struct gdbarch
*gdbarch
= get_type_arch (type
);
4011 unsigned len
= TYPE_LENGTH (type
);
4012 gdb_byte
*buf
= alloca (len
);
4015 addr
= value_address (value
);
4016 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4017 addr
= extract_unsigned_integer (buf
, len
, gdbarch_byte_order (gdbarch
));
4022 /* Push a descriptor of type TYPE for array value ARR on the stack at
4023 *SP, updating *SP to reflect the new descriptor. Return either
4024 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4025 to-descriptor type rather than a descriptor type), a struct value *
4026 representing a pointer to this descriptor. */
4028 static struct value
*
4029 make_array_descriptor (struct type
*type
, struct value
*arr
)
4031 struct type
*bounds_type
= desc_bounds_type (type
);
4032 struct type
*desc_type
= desc_base_type (type
);
4033 struct value
*descriptor
= allocate_value (desc_type
);
4034 struct value
*bounds
= allocate_value (bounds_type
);
4037 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
4039 modify_general_field (value_type (bounds
),
4040 value_contents_writeable (bounds
),
4041 ada_array_bound (arr
, i
, 0),
4042 desc_bound_bitpos (bounds_type
, i
, 0),
4043 desc_bound_bitsize (bounds_type
, i
, 0));
4044 modify_general_field (value_type (bounds
),
4045 value_contents_writeable (bounds
),
4046 ada_array_bound (arr
, i
, 1),
4047 desc_bound_bitpos (bounds_type
, i
, 1),
4048 desc_bound_bitsize (bounds_type
, i
, 1));
4051 bounds
= ensure_lval (bounds
);
4053 modify_general_field (value_type (descriptor
),
4054 value_contents_writeable (descriptor
),
4055 value_pointer (ensure_lval (arr
),
4056 TYPE_FIELD_TYPE (desc_type
, 0)),
4057 fat_pntr_data_bitpos (desc_type
),
4058 fat_pntr_data_bitsize (desc_type
));
4060 modify_general_field (value_type (descriptor
),
4061 value_contents_writeable (descriptor
),
4062 value_pointer (bounds
,
4063 TYPE_FIELD_TYPE (desc_type
, 1)),
4064 fat_pntr_bounds_bitpos (desc_type
),
4065 fat_pntr_bounds_bitsize (desc_type
));
4067 descriptor
= ensure_lval (descriptor
);
4069 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
4070 return value_addr (descriptor
);
4075 /* Dummy definitions for an experimental caching module that is not
4076 * used in the public sources. */
4079 lookup_cached_symbol (const char *name
, domain_enum
namespace,
4080 struct symbol
**sym
, struct block
**block
)
4086 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
4087 struct block
*block
)
4093 /* Return the result of a standard (literal, C-like) lookup of NAME in
4094 given DOMAIN, visible from lexical block BLOCK. */
4096 static struct symbol
*
4097 standard_lookup (const char *name
, const struct block
*block
,
4102 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
))
4104 sym
= lookup_symbol_in_language (name
, block
, domain
, language_c
, 0);
4105 cache_symbol (name
, domain
, sym
, block_found
);
4110 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4111 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4112 since they contend in overloading in the same way. */
4114 is_nonfunction (struct ada_symbol_info syms
[], int n
)
4118 for (i
= 0; i
< n
; i
+= 1)
4119 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
4120 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
4121 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
4127 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4128 struct types. Otherwise, they may not. */
4131 equiv_types (struct type
*type0
, struct type
*type1
)
4135 if (type0
== NULL
|| type1
== NULL
4136 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
4138 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
4139 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
4140 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4141 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4147 /* True iff SYM0 represents the same entity as SYM1, or one that is
4148 no more defined than that of SYM1. */
4151 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4155 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4156 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4159 switch (SYMBOL_CLASS (sym0
))
4165 struct type
*type0
= SYMBOL_TYPE (sym0
);
4166 struct type
*type1
= SYMBOL_TYPE (sym1
);
4167 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4168 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4169 int len0
= strlen (name0
);
4172 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4173 && (equiv_types (type0
, type1
)
4174 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4175 && strncmp (name1
+ len0
, "___XV", 5) == 0));
4178 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4179 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4185 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4186 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4189 add_defn_to_vec (struct obstack
*obstackp
,
4191 struct block
*block
)
4194 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
4196 /* Do not try to complete stub types, as the debugger is probably
4197 already scanning all symbols matching a certain name at the
4198 time when this function is called. Trying to replace the stub
4199 type by its associated full type will cause us to restart a scan
4200 which may lead to an infinite recursion. Instead, the client
4201 collecting the matching symbols will end up collecting several
4202 matches, with at least one of them complete. It can then filter
4203 out the stub ones if needed. */
4205 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4207 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
4209 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
4211 prevDefns
[i
].sym
= sym
;
4212 prevDefns
[i
].block
= block
;
4218 struct ada_symbol_info info
;
4222 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
4226 /* Number of ada_symbol_info structures currently collected in
4227 current vector in *OBSTACKP. */
4230 num_defns_collected (struct obstack
*obstackp
)
4232 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
4235 /* Vector of ada_symbol_info structures currently collected in current
4236 vector in *OBSTACKP. If FINISH, close off the vector and return
4237 its final address. */
4239 static struct ada_symbol_info
*
4240 defns_collected (struct obstack
*obstackp
, int finish
)
4243 return obstack_finish (obstackp
);
4245 return (struct ada_symbol_info
*) obstack_base (obstackp
);
4248 /* Return a minimal symbol matching NAME according to Ada decoding
4249 rules. Returns NULL if there is no such minimal symbol. Names
4250 prefixed with "standard__" are handled specially: "standard__" is
4251 first stripped off, and only static and global symbols are searched. */
4253 struct minimal_symbol
*
4254 ada_lookup_simple_minsym (const char *name
)
4256 struct objfile
*objfile
;
4257 struct minimal_symbol
*msymbol
;
4260 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4262 name
+= sizeof ("standard__") - 1;
4266 wild_match
= (strstr (name
, "__") == NULL
);
4268 ALL_MSYMBOLS (objfile
, msymbol
)
4270 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4271 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4278 /* For all subprograms that statically enclose the subprogram of the
4279 selected frame, add symbols matching identifier NAME in DOMAIN
4280 and their blocks to the list of data in OBSTACKP, as for
4281 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4285 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4286 const char *name
, domain_enum
namespace,
4291 /* True if TYPE is definitely an artificial type supplied to a symbol
4292 for which no debugging information was given in the symbol file. */
4295 is_nondebugging_type (struct type
*type
)
4297 char *name
= ada_type_name (type
);
4299 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4302 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4303 duplicate other symbols in the list (The only case I know of where
4304 this happens is when object files containing stabs-in-ecoff are
4305 linked with files containing ordinary ecoff debugging symbols (or no
4306 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4307 Returns the number of items in the modified list. */
4310 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4319 /* If two symbols have the same name and one of them is a stub type,
4320 the get rid of the stub. */
4322 if (TYPE_STUB (SYMBOL_TYPE (syms
[i
].sym
))
4323 && SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
)
4325 for (j
= 0; j
< nsyms
; j
++)
4328 && !TYPE_STUB (SYMBOL_TYPE (syms
[j
].sym
))
4329 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4330 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4331 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0)
4336 /* Two symbols with the same name, same class and same address
4337 should be identical. */
4339 else if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4340 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4341 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4343 for (j
= 0; j
< nsyms
; j
+= 1)
4346 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4347 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4348 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4349 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4350 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4351 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4358 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4359 syms
[j
- 1] = syms
[j
];
4368 /* Given a type that corresponds to a renaming entity, use the type name
4369 to extract the scope (package name or function name, fully qualified,
4370 and following the GNAT encoding convention) where this renaming has been
4371 defined. The string returned needs to be deallocated after use. */
4374 xget_renaming_scope (struct type
*renaming_type
)
4376 /* The renaming types adhere to the following convention:
4377 <scope>__<rename>___<XR extension>.
4378 So, to extract the scope, we search for the "___XR" extension,
4379 and then backtrack until we find the first "__". */
4381 const char *name
= type_name_no_tag (renaming_type
);
4382 char *suffix
= strstr (name
, "___XR");
4387 /* Now, backtrack a bit until we find the first "__". Start looking
4388 at suffix - 3, as the <rename> part is at least one character long. */
4390 for (last
= suffix
- 3; last
> name
; last
--)
4391 if (last
[0] == '_' && last
[1] == '_')
4394 /* Make a copy of scope and return it. */
4396 scope_len
= last
- name
;
4397 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4399 strncpy (scope
, name
, scope_len
);
4400 scope
[scope_len
] = '\0';
4405 /* Return nonzero if NAME corresponds to a package name. */
4408 is_package_name (const char *name
)
4410 /* Here, We take advantage of the fact that no symbols are generated
4411 for packages, while symbols are generated for each function.
4412 So the condition for NAME represent a package becomes equivalent
4413 to NAME not existing in our list of symbols. There is only one
4414 small complication with library-level functions (see below). */
4418 /* If it is a function that has not been defined at library level,
4419 then we should be able to look it up in the symbols. */
4420 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4423 /* Library-level function names start with "_ada_". See if function
4424 "_ada_" followed by NAME can be found. */
4426 /* Do a quick check that NAME does not contain "__", since library-level
4427 functions names cannot contain "__" in them. */
4428 if (strstr (name
, "__") != NULL
)
4431 fun_name
= xstrprintf ("_ada_%s", name
);
4433 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4436 /* Return nonzero if SYM corresponds to a renaming entity that is
4437 not visible from FUNCTION_NAME. */
4440 old_renaming_is_invisible (const struct symbol
*sym
, char *function_name
)
4444 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
4447 scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4449 make_cleanup (xfree
, scope
);
4451 /* If the rename has been defined in a package, then it is visible. */
4452 if (is_package_name (scope
))
4455 /* Check that the rename is in the current function scope by checking
4456 that its name starts with SCOPE. */
4458 /* If the function name starts with "_ada_", it means that it is
4459 a library-level function. Strip this prefix before doing the
4460 comparison, as the encoding for the renaming does not contain
4462 if (strncmp (function_name
, "_ada_", 5) == 0)
4465 return (strncmp (function_name
, scope
, strlen (scope
)) != 0);
4468 /* Remove entries from SYMS that corresponds to a renaming entity that
4469 is not visible from the function associated with CURRENT_BLOCK or
4470 that is superfluous due to the presence of more specific renaming
4471 information. Places surviving symbols in the initial entries of
4472 SYMS and returns the number of surviving symbols.
4475 First, in cases where an object renaming is implemented as a
4476 reference variable, GNAT may produce both the actual reference
4477 variable and the renaming encoding. In this case, we discard the
4480 Second, GNAT emits a type following a specified encoding for each renaming
4481 entity. Unfortunately, STABS currently does not support the definition
4482 of types that are local to a given lexical block, so all renamings types
4483 are emitted at library level. As a consequence, if an application
4484 contains two renaming entities using the same name, and a user tries to
4485 print the value of one of these entities, the result of the ada symbol
4486 lookup will also contain the wrong renaming type.
4488 This function partially covers for this limitation by attempting to
4489 remove from the SYMS list renaming symbols that should be visible
4490 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4491 method with the current information available. The implementation
4492 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4494 - When the user tries to print a rename in a function while there
4495 is another rename entity defined in a package: Normally, the
4496 rename in the function has precedence over the rename in the
4497 package, so the latter should be removed from the list. This is
4498 currently not the case.
4500 - This function will incorrectly remove valid renames if
4501 the CURRENT_BLOCK corresponds to a function which symbol name
4502 has been changed by an "Export" pragma. As a consequence,
4503 the user will be unable to print such rename entities. */
4506 remove_irrelevant_renamings (struct ada_symbol_info
*syms
,
4507 int nsyms
, const struct block
*current_block
)
4509 struct symbol
*current_function
;
4510 char *current_function_name
;
4512 int is_new_style_renaming
;
4514 /* If there is both a renaming foo___XR... encoded as a variable and
4515 a simple variable foo in the same block, discard the latter.
4516 First, zero out such symbols, then compress. */
4517 is_new_style_renaming
= 0;
4518 for (i
= 0; i
< nsyms
; i
+= 1)
4520 struct symbol
*sym
= syms
[i
].sym
;
4521 struct block
*block
= syms
[i
].block
;
4525 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
4527 name
= SYMBOL_LINKAGE_NAME (sym
);
4528 suffix
= strstr (name
, "___XR");
4532 int name_len
= suffix
- name
;
4535 is_new_style_renaming
= 1;
4536 for (j
= 0; j
< nsyms
; j
+= 1)
4537 if (i
!= j
&& syms
[j
].sym
!= NULL
4538 && strncmp (name
, SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
4540 && block
== syms
[j
].block
)
4544 if (is_new_style_renaming
)
4548 for (j
= k
= 0; j
< nsyms
; j
+= 1)
4549 if (syms
[j
].sym
!= NULL
)
4557 /* Extract the function name associated to CURRENT_BLOCK.
4558 Abort if unable to do so. */
4560 if (current_block
== NULL
)
4563 current_function
= block_linkage_function (current_block
);
4564 if (current_function
== NULL
)
4567 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4568 if (current_function_name
== NULL
)
4571 /* Check each of the symbols, and remove it from the list if it is
4572 a type corresponding to a renaming that is out of the scope of
4573 the current block. */
4578 if (ada_parse_renaming (syms
[i
].sym
, NULL
, NULL
, NULL
)
4579 == ADA_OBJECT_RENAMING
4580 && old_renaming_is_invisible (syms
[i
].sym
, current_function_name
))
4584 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4585 syms
[j
- 1] = syms
[j
];
4595 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4596 whose name and domain match NAME and DOMAIN respectively.
4597 If no match was found, then extend the search to "enclosing"
4598 routines (in other words, if we're inside a nested function,
4599 search the symbols defined inside the enclosing functions).
4601 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4604 ada_add_local_symbols (struct obstack
*obstackp
, const char *name
,
4605 struct block
*block
, domain_enum domain
,
4608 int block_depth
= 0;
4610 while (block
!= NULL
)
4613 ada_add_block_symbols (obstackp
, block
, name
, domain
, NULL
, wild_match
);
4615 /* If we found a non-function match, assume that's the one. */
4616 if (is_nonfunction (defns_collected (obstackp
, 0),
4617 num_defns_collected (obstackp
)))
4620 block
= BLOCK_SUPERBLOCK (block
);
4623 /* If no luck so far, try to find NAME as a local symbol in some lexically
4624 enclosing subprogram. */
4625 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
4626 add_symbols_from_enclosing_procs (obstackp
, name
, domain
, wild_match
);
4629 /* An object of this type is used as the user_data argument when
4630 calling the map_ada_symtabs method. */
4632 struct ada_psym_data
4634 struct obstack
*obstackp
;
4641 /* Callback function for map_ada_symtabs. */
4644 ada_add_psyms (struct objfile
*objfile
, struct symtab
*s
, void *user_data
)
4646 struct ada_psym_data
*data
= user_data
;
4647 const int block_kind
= data
->global
? GLOBAL_BLOCK
: STATIC_BLOCK
;
4649 ada_add_block_symbols (data
->obstackp
,
4650 BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), block_kind
),
4651 data
->name
, data
->domain
, objfile
, data
->wild_match
);
4654 /* Add to OBSTACKP all non-local symbols whose name and domain match
4655 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
4656 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
4659 ada_add_non_local_symbols (struct obstack
*obstackp
, const char *name
,
4660 domain_enum domain
, int global
,
4663 struct objfile
*objfile
;
4664 struct ada_psym_data data
;
4666 data
.obstackp
= obstackp
;
4668 data
.domain
= domain
;
4669 data
.global
= global
;
4670 data
.wild_match
= is_wild_match
;
4672 ALL_OBJFILES (objfile
)
4675 objfile
->sf
->qf
->map_ada_symtabs (objfile
, wild_match
, is_name_suffix
,
4676 ada_add_psyms
, name
,
4678 is_wild_match
, &data
);
4682 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4683 scope and in global scopes, returning the number of matches. Sets
4684 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4685 indicating the symbols found and the blocks and symbol tables (if
4686 any) in which they were found. This vector are transient---good only to
4687 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4688 symbol match within the nest of blocks whose innermost member is BLOCK0,
4689 is the one match returned (no other matches in that or
4690 enclosing blocks is returned). If there are any matches in or
4691 surrounding BLOCK0, then these alone are returned. Otherwise, the
4692 search extends to global and file-scope (static) symbol tables.
4693 Names prefixed with "standard__" are handled specially: "standard__"
4694 is first stripped off, and only static and global symbols are searched. */
4697 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4698 domain_enum
namespace,
4699 struct ada_symbol_info
**results
)
4702 struct block
*block
;
4708 obstack_free (&symbol_list_obstack
, NULL
);
4709 obstack_init (&symbol_list_obstack
);
4713 /* Search specified block and its superiors. */
4715 wild_match
= (strstr (name0
, "__") == NULL
);
4717 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4718 needed, but adding const will
4719 have a cascade effect. */
4721 /* Special case: If the user specifies a symbol name inside package
4722 Standard, do a non-wild matching of the symbol name without
4723 the "standard__" prefix. This was primarily introduced in order
4724 to allow the user to specifically access the standard exceptions
4725 using, for instance, Standard.Constraint_Error when Constraint_Error
4726 is ambiguous (due to the user defining its own Constraint_Error
4727 entity inside its program). */
4728 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4732 name
= name0
+ sizeof ("standard__") - 1;
4735 /* Check the non-global symbols. If we have ANY match, then we're done. */
4737 ada_add_local_symbols (&symbol_list_obstack
, name
, block
, namespace,
4739 if (num_defns_collected (&symbol_list_obstack
) > 0)
4742 /* No non-global symbols found. Check our cache to see if we have
4743 already performed this search before. If we have, then return
4747 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
))
4750 add_defn_to_vec (&symbol_list_obstack
, sym
, block
);
4754 /* Search symbols from all global blocks. */
4756 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 1,
4759 /* Now add symbols from all per-file blocks if we've gotten no hits
4760 (not strictly correct, but perhaps better than an error). */
4762 if (num_defns_collected (&symbol_list_obstack
) == 0)
4763 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 0,
4767 ndefns
= num_defns_collected (&symbol_list_obstack
);
4768 *results
= defns_collected (&symbol_list_obstack
, 1);
4770 ndefns
= remove_extra_symbols (*results
, ndefns
);
4773 cache_symbol (name0
, namespace, NULL
, NULL
);
4775 if (ndefns
== 1 && cacheIfUnique
)
4776 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
);
4778 ndefns
= remove_irrelevant_renamings (*results
, ndefns
, block0
);
4784 ada_lookup_encoded_symbol (const char *name
, const struct block
*block0
,
4785 domain_enum
namespace, struct block
**block_found
)
4787 struct ada_symbol_info
*candidates
;
4790 n_candidates
= ada_lookup_symbol_list (name
, block0
, namespace, &candidates
);
4792 if (n_candidates
== 0)
4795 if (block_found
!= NULL
)
4796 *block_found
= candidates
[0].block
;
4798 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4801 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4802 scope and in global scopes, or NULL if none. NAME is folded and
4803 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4804 choosing the first symbol if there are multiple choices.
4805 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4806 table in which the symbol was found (in both cases, these
4807 assignments occur only if the pointers are non-null). */
4809 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4810 domain_enum
namespace, int *is_a_field_of_this
)
4812 if (is_a_field_of_this
!= NULL
)
4813 *is_a_field_of_this
= 0;
4816 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name
)),
4817 block0
, namespace, NULL
);
4820 static struct symbol
*
4821 ada_lookup_symbol_nonlocal (const char *name
,
4822 const struct block
*block
,
4823 const domain_enum domain
)
4825 return ada_lookup_symbol (name
, block_static_block (block
), domain
, NULL
);
4829 /* True iff STR is a possible encoded suffix of a normal Ada name
4830 that is to be ignored for matching purposes. Suffixes of parallel
4831 names (e.g., XVE) are not included here. Currently, the possible suffixes
4832 are given by any of the regular expressions:
4834 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
4835 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4836 _E[0-9]+[bs]$ [protected object entry suffixes]
4837 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4839 Also, any leading "__[0-9]+" sequence is skipped before the suffix
4840 match is performed. This sequence is used to differentiate homonyms,
4841 is an optional part of a valid name suffix. */
4844 is_name_suffix (const char *str
)
4847 const char *matching
;
4848 const int len
= strlen (str
);
4850 /* Skip optional leading __[0-9]+. */
4852 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4855 while (isdigit (str
[0]))
4861 if (str
[0] == '.' || str
[0] == '$')
4864 while (isdigit (matching
[0]))
4866 if (matching
[0] == '\0')
4872 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4875 while (isdigit (matching
[0]))
4877 if (matching
[0] == '\0')
4882 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4883 with a N at the end. Unfortunately, the compiler uses the same
4884 convention for other internal types it creates. So treating
4885 all entity names that end with an "N" as a name suffix causes
4886 some regressions. For instance, consider the case of an enumerated
4887 type. To support the 'Image attribute, it creates an array whose
4889 Having a single character like this as a suffix carrying some
4890 information is a bit risky. Perhaps we should change the encoding
4891 to be something like "_N" instead. In the meantime, do not do
4892 the following check. */
4893 /* Protected Object Subprograms */
4894 if (len
== 1 && str
[0] == 'N')
4899 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
4902 while (isdigit (matching
[0]))
4904 if ((matching
[0] == 'b' || matching
[0] == 's')
4905 && matching
[1] == '\0')
4909 /* ??? We should not modify STR directly, as we are doing below. This
4910 is fine in this case, but may become problematic later if we find
4911 that this alternative did not work, and want to try matching
4912 another one from the begining of STR. Since we modified it, we
4913 won't be able to find the begining of the string anymore! */
4917 while (str
[0] != '_' && str
[0] != '\0')
4919 if (str
[0] != 'n' && str
[0] != 'b')
4925 if (str
[0] == '\000')
4930 if (str
[1] != '_' || str
[2] == '\000')
4934 if (strcmp (str
+ 3, "JM") == 0)
4936 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4937 the LJM suffix in favor of the JM one. But we will
4938 still accept LJM as a valid suffix for a reasonable
4939 amount of time, just to allow ourselves to debug programs
4940 compiled using an older version of GNAT. */
4941 if (strcmp (str
+ 3, "LJM") == 0)
4945 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4946 || str
[4] == 'U' || str
[4] == 'P')
4948 if (str
[4] == 'R' && str
[5] != 'T')
4952 if (!isdigit (str
[2]))
4954 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4955 if (!isdigit (str
[k
]) && str
[k
] != '_')
4959 if (str
[0] == '$' && isdigit (str
[1]))
4961 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4962 if (!isdigit (str
[k
]) && str
[k
] != '_')
4969 /* Return non-zero if the string starting at NAME and ending before
4970 NAME_END contains no capital letters. */
4973 is_valid_name_for_wild_match (const char *name0
)
4975 const char *decoded_name
= ada_decode (name0
);
4978 /* If the decoded name starts with an angle bracket, it means that
4979 NAME0 does not follow the GNAT encoding format. It should then
4980 not be allowed as a possible wild match. */
4981 if (decoded_name
[0] == '<')
4984 for (i
=0; decoded_name
[i
] != '\0'; i
++)
4985 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
4991 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
4992 that could start a simple name. Assumes that *NAMEP points into
4993 the string beginning at NAME0. */
4996 advance_wild_match (const char **namep
, const char *name0
, int target0
)
4998 const char *name
= *namep
;
5008 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
5011 if (name
== name0
+ 5 && strncmp (name0
, "_ada", 4) == 0)
5016 else if (t1
== '_' &&
5017 (((t2
= name
[2]) >= 'a' && t2
<= 'z') || t2
== target0
))
5025 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
5035 /* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5036 informational suffixes of NAME (i.e., for which is_name_suffix is
5037 true). Assumes that PATN is a lower-cased Ada simple name. */
5040 wild_match (const char *name
, const char *patn
)
5043 const char *name0
= name
;
5047 const char *match
= name
;
5051 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
5054 if (*p
== '\0' && is_name_suffix (name
))
5055 return match
!= name0
&& !is_valid_name_for_wild_match (name0
);
5057 if (name
[-1] == '_')
5060 if (!advance_wild_match (&name
, name0
, *patn
))
5065 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5066 vector *defn_symbols, updating the list of symbols in OBSTACKP
5067 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5068 OBJFILE is the section containing BLOCK.
5069 SYMTAB is recorded with each symbol added. */
5072 ada_add_block_symbols (struct obstack
*obstackp
,
5073 struct block
*block
, const char *name
,
5074 domain_enum domain
, struct objfile
*objfile
,
5077 struct dict_iterator iter
;
5078 int name_len
= strlen (name
);
5079 /* A matching argument symbol, if any. */
5080 struct symbol
*arg_sym
;
5081 /* Set true when we find a matching non-argument symbol. */
5091 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5093 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5094 SYMBOL_DOMAIN (sym
), domain
)
5095 && wild_match (SYMBOL_LINKAGE_NAME (sym
), name
) == 0)
5097 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5099 else if (SYMBOL_IS_ARGUMENT (sym
))
5104 add_defn_to_vec (obstackp
,
5105 fixup_symbol_section (sym
, objfile
),
5113 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5115 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5116 SYMBOL_DOMAIN (sym
), domain
))
5118 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
5121 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5123 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5125 if (SYMBOL_IS_ARGUMENT (sym
))
5130 add_defn_to_vec (obstackp
,
5131 fixup_symbol_section (sym
, objfile
),
5140 if (!found_sym
&& arg_sym
!= NULL
)
5142 add_defn_to_vec (obstackp
,
5143 fixup_symbol_section (arg_sym
, objfile
),
5152 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5154 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5155 SYMBOL_DOMAIN (sym
), domain
))
5159 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5162 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5164 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5169 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5171 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5173 if (SYMBOL_IS_ARGUMENT (sym
))
5178 add_defn_to_vec (obstackp
,
5179 fixup_symbol_section (sym
, objfile
),
5187 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5188 They aren't parameters, right? */
5189 if (!found_sym
&& arg_sym
!= NULL
)
5191 add_defn_to_vec (obstackp
,
5192 fixup_symbol_section (arg_sym
, objfile
),
5199 /* Symbol Completion */
5201 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5202 name in a form that's appropriate for the completion. The result
5203 does not need to be deallocated, but is only good until the next call.
5205 TEXT_LEN is equal to the length of TEXT.
5206 Perform a wild match if WILD_MATCH is set.
5207 ENCODED should be set if TEXT represents the start of a symbol name
5208 in its encoded form. */
5211 symbol_completion_match (const char *sym_name
,
5212 const char *text
, int text_len
,
5213 int wild_match
, int encoded
)
5215 const int verbatim_match
= (text
[0] == '<');
5220 /* Strip the leading angle bracket. */
5225 /* First, test against the fully qualified name of the symbol. */
5227 if (strncmp (sym_name
, text
, text_len
) == 0)
5230 if (match
&& !encoded
)
5232 /* One needed check before declaring a positive match is to verify
5233 that iff we are doing a verbatim match, the decoded version
5234 of the symbol name starts with '<'. Otherwise, this symbol name
5235 is not a suitable completion. */
5236 const char *sym_name_copy
= sym_name
;
5237 int has_angle_bracket
;
5239 sym_name
= ada_decode (sym_name
);
5240 has_angle_bracket
= (sym_name
[0] == '<');
5241 match
= (has_angle_bracket
== verbatim_match
);
5242 sym_name
= sym_name_copy
;
5245 if (match
&& !verbatim_match
)
5247 /* When doing non-verbatim match, another check that needs to
5248 be done is to verify that the potentially matching symbol name
5249 does not include capital letters, because the ada-mode would
5250 not be able to understand these symbol names without the
5251 angle bracket notation. */
5254 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
5259 /* Second: Try wild matching... */
5261 if (!match
&& wild_match
)
5263 /* Since we are doing wild matching, this means that TEXT
5264 may represent an unqualified symbol name. We therefore must
5265 also compare TEXT against the unqualified name of the symbol. */
5266 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
5268 if (strncmp (sym_name
, text
, text_len
) == 0)
5272 /* Finally: If we found a mach, prepare the result to return. */
5278 sym_name
= add_angle_brackets (sym_name
);
5281 sym_name
= ada_decode (sym_name
);
5286 DEF_VEC_P (char_ptr
);
5288 /* A companion function to ada_make_symbol_completion_list().
5289 Check if SYM_NAME represents a symbol which name would be suitable
5290 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5291 it is appended at the end of the given string vector SV.
5293 ORIG_TEXT is the string original string from the user command
5294 that needs to be completed. WORD is the entire command on which
5295 completion should be performed. These two parameters are used to
5296 determine which part of the symbol name should be added to the
5298 if WILD_MATCH is set, then wild matching is performed.
5299 ENCODED should be set if TEXT represents a symbol name in its
5300 encoded formed (in which case the completion should also be
5304 symbol_completion_add (VEC(char_ptr
) **sv
,
5305 const char *sym_name
,
5306 const char *text
, int text_len
,
5307 const char *orig_text
, const char *word
,
5308 int wild_match
, int encoded
)
5310 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
5311 wild_match
, encoded
);
5317 /* We found a match, so add the appropriate completion to the given
5320 if (word
== orig_text
)
5322 completion
= xmalloc (strlen (match
) + 5);
5323 strcpy (completion
, match
);
5325 else if (word
> orig_text
)
5327 /* Return some portion of sym_name. */
5328 completion
= xmalloc (strlen (match
) + 5);
5329 strcpy (completion
, match
+ (word
- orig_text
));
5333 /* Return some of ORIG_TEXT plus sym_name. */
5334 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
5335 strncpy (completion
, word
, orig_text
- word
);
5336 completion
[orig_text
- word
] = '\0';
5337 strcat (completion
, match
);
5340 VEC_safe_push (char_ptr
, *sv
, completion
);
5343 /* An object of this type is passed as the user_data argument to the
5344 map_partial_symbol_names method. */
5345 struct add_partial_datum
5347 VEC(char_ptr
) **completions
;
5356 /* A callback for map_partial_symbol_names. */
5358 ada_add_partial_symbol_completions (const char *name
, void *user_data
)
5360 struct add_partial_datum
*data
= user_data
;
5362 symbol_completion_add (data
->completions
, name
,
5363 data
->text
, data
->text_len
, data
->text0
, data
->word
,
5364 data
->wild_match
, data
->encoded
);
5367 /* Return a list of possible symbol names completing TEXT0. The list
5368 is NULL terminated. WORD is the entire command on which completion
5372 ada_make_symbol_completion_list (char *text0
, char *word
)
5378 VEC(char_ptr
) *completions
= VEC_alloc (char_ptr
, 128);
5381 struct minimal_symbol
*msymbol
;
5382 struct objfile
*objfile
;
5383 struct block
*b
, *surrounding_static_block
= 0;
5385 struct dict_iterator iter
;
5387 if (text0
[0] == '<')
5389 text
= xstrdup (text0
);
5390 make_cleanup (xfree
, text
);
5391 text_len
= strlen (text
);
5397 text
= xstrdup (ada_encode (text0
));
5398 make_cleanup (xfree
, text
);
5399 text_len
= strlen (text
);
5400 for (i
= 0; i
< text_len
; i
++)
5401 text
[i
] = tolower (text
[i
]);
5403 encoded
= (strstr (text0
, "__") != NULL
);
5404 /* If the name contains a ".", then the user is entering a fully
5405 qualified entity name, and the match must not be done in wild
5406 mode. Similarly, if the user wants to complete what looks like
5407 an encoded name, the match must not be done in wild mode. */
5408 wild_match
= (strchr (text0
, '.') == NULL
&& !encoded
);
5411 /* First, look at the partial symtab symbols. */
5413 struct add_partial_datum data
;
5415 data
.completions
= &completions
;
5417 data
.text_len
= text_len
;
5420 data
.wild_match
= wild_match
;
5421 data
.encoded
= encoded
;
5422 map_partial_symbol_names (ada_add_partial_symbol_completions
, &data
);
5425 /* At this point scan through the misc symbol vectors and add each
5426 symbol you find to the list. Eventually we want to ignore
5427 anything that isn't a text symbol (everything else will be
5428 handled by the psymtab code above). */
5430 ALL_MSYMBOLS (objfile
, msymbol
)
5433 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (msymbol
),
5434 text
, text_len
, text0
, word
, wild_match
, encoded
);
5437 /* Search upwards from currently selected frame (so that we can
5438 complete on local vars. */
5440 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
5442 if (!BLOCK_SUPERBLOCK (b
))
5443 surrounding_static_block
= b
; /* For elmin of dups */
5445 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5447 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5448 text
, text_len
, text0
, word
,
5449 wild_match
, encoded
);
5453 /* Go through the symtabs and check the externs and statics for
5454 symbols which match. */
5456 ALL_SYMTABS (objfile
, s
)
5459 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
5460 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5462 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5463 text
, text_len
, text0
, word
,
5464 wild_match
, encoded
);
5468 ALL_SYMTABS (objfile
, s
)
5471 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
5472 /* Don't do this block twice. */
5473 if (b
== surrounding_static_block
)
5475 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5477 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5478 text
, text_len
, text0
, word
,
5479 wild_match
, encoded
);
5483 /* Append the closing NULL entry. */
5484 VEC_safe_push (char_ptr
, completions
, NULL
);
5486 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5487 return the copy. It's unfortunate that we have to make a copy
5488 of an array that we're about to destroy, but there is nothing much
5489 we can do about it. Fortunately, it's typically not a very large
5492 const size_t completions_size
=
5493 VEC_length (char_ptr
, completions
) * sizeof (char *);
5494 char **result
= malloc (completions_size
);
5496 memcpy (result
, VEC_address (char_ptr
, completions
), completions_size
);
5498 VEC_free (char_ptr
, completions
);
5505 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5506 for tagged types. */
5509 ada_is_dispatch_table_ptr_type (struct type
*type
)
5513 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
5516 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
5520 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
5523 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5524 to be invisible to users. */
5527 ada_is_ignored_field (struct type
*type
, int field_num
)
5529 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5532 /* Check the name of that field. */
5534 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5536 /* Anonymous field names should not be printed.
5537 brobecker/2007-02-20: I don't think this can actually happen
5538 but we don't want to print the value of annonymous fields anyway. */
5542 /* A field named "_parent" is internally generated by GNAT for
5543 tagged types, and should not be printed either. */
5544 if (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0)
5548 /* If this is the dispatch table of a tagged type, then ignore. */
5549 if (ada_is_tagged_type (type
, 1)
5550 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
)))
5553 /* Not a special field, so it should not be ignored. */
5557 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5558 pointer or reference type whose ultimate target has a tag field. */
5561 ada_is_tagged_type (struct type
*type
, int refok
)
5563 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
5566 /* True iff TYPE represents the type of X'Tag */
5569 ada_is_tag_type (struct type
*type
)
5571 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
5575 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
5577 return (name
!= NULL
5578 && strcmp (name
, "ada__tags__dispatch_table") == 0);
5582 /* The type of the tag on VAL. */
5585 ada_tag_type (struct value
*val
)
5587 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
5590 /* The value of the tag on VAL. */
5593 ada_value_tag (struct value
*val
)
5595 return ada_value_struct_elt (val
, "_tag", 0);
5598 /* The value of the tag on the object of type TYPE whose contents are
5599 saved at VALADDR, if it is non-null, or is at memory address
5602 static struct value
*
5603 value_tag_from_contents_and_address (struct type
*type
,
5604 const gdb_byte
*valaddr
,
5607 int tag_byte_offset
;
5608 struct type
*tag_type
;
5610 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5613 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
5615 : valaddr
+ tag_byte_offset
);
5616 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5618 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5623 static struct type
*
5624 type_from_tag (struct value
*tag
)
5626 const char *type_name
= ada_tag_name (tag
);
5628 if (type_name
!= NULL
)
5629 return ada_find_any_type (ada_encode (type_name
));
5640 static int ada_tag_name_1 (void *);
5641 static int ada_tag_name_2 (struct tag_args
*);
5643 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5644 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5645 The value stored in ARGS->name is valid until the next call to
5649 ada_tag_name_1 (void *args0
)
5651 struct tag_args
*args
= (struct tag_args
*) args0
;
5652 static char name
[1024];
5657 val
= ada_value_struct_elt (args
->tag
, "tsd", 1);
5659 return ada_tag_name_2 (args
);
5660 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5663 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5664 for (p
= name
; *p
!= '\0'; p
+= 1)
5671 /* Return the "ada__tags__type_specific_data" type. */
5673 static struct type
*
5674 ada_get_tsd_type (struct inferior
*inf
)
5676 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
5678 if (data
->tsd_type
== 0)
5679 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
5680 return data
->tsd_type
;
5683 /* Utility function for ada_tag_name_1 that tries the second
5684 representation for the dispatch table (in which there is no
5685 explicit 'tsd' field in the referent of the tag pointer, and instead
5686 the tsd pointer is stored just before the dispatch table. */
5689 ada_tag_name_2 (struct tag_args
*args
)
5691 struct type
*info_type
;
5692 static char name
[1024];
5694 struct value
*val
, *valp
;
5697 info_type
= ada_get_tsd_type (current_inferior());
5698 if (info_type
== NULL
)
5700 info_type
= lookup_pointer_type (lookup_pointer_type (info_type
));
5701 valp
= value_cast (info_type
, args
->tag
);
5704 val
= value_ind (value_ptradd (valp
, -1));
5707 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5710 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5711 for (p
= name
; *p
!= '\0'; p
+= 1)
5718 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5722 ada_tag_name (struct value
*tag
)
5724 struct tag_args args
;
5726 if (!ada_is_tag_type (value_type (tag
)))
5730 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5734 /* The parent type of TYPE, or NULL if none. */
5737 ada_parent_type (struct type
*type
)
5741 type
= ada_check_typedef (type
);
5743 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5746 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5747 if (ada_is_parent_field (type
, i
))
5749 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
5751 /* If the _parent field is a pointer, then dereference it. */
5752 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
5753 parent_type
= TYPE_TARGET_TYPE (parent_type
);
5754 /* If there is a parallel XVS type, get the actual base type. */
5755 parent_type
= ada_get_base_type (parent_type
);
5757 return ada_check_typedef (parent_type
);
5763 /* True iff field number FIELD_NUM of structure type TYPE contains the
5764 parent-type (inherited) fields of a derived type. Assumes TYPE is
5765 a structure type with at least FIELD_NUM+1 fields. */
5768 ada_is_parent_field (struct type
*type
, int field_num
)
5770 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5772 return (name
!= NULL
5773 && (strncmp (name
, "PARENT", 6) == 0
5774 || strncmp (name
, "_parent", 7) == 0));
5777 /* True iff field number FIELD_NUM of structure type TYPE is a
5778 transparent wrapper field (which should be silently traversed when doing
5779 field selection and flattened when printing). Assumes TYPE is a
5780 structure type with at least FIELD_NUM+1 fields. Such fields are always
5784 ada_is_wrapper_field (struct type
*type
, int field_num
)
5786 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5788 return (name
!= NULL
5789 && (strncmp (name
, "PARENT", 6) == 0
5790 || strcmp (name
, "REP") == 0
5791 || strncmp (name
, "_parent", 7) == 0
5792 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5795 /* True iff field number FIELD_NUM of structure or union type TYPE
5796 is a variant wrapper. Assumes TYPE is a structure type with at least
5797 FIELD_NUM+1 fields. */
5800 ada_is_variant_part (struct type
*type
, int field_num
)
5802 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5804 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5805 || (is_dynamic_field (type
, field_num
)
5806 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5807 == TYPE_CODE_UNION
)));
5810 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5811 whose discriminants are contained in the record type OUTER_TYPE,
5812 returns the type of the controlling discriminant for the variant.
5813 May return NULL if the type could not be found. */
5816 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5818 char *name
= ada_variant_discrim_name (var_type
);
5820 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5823 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5824 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5825 represents a 'when others' clause; otherwise 0. */
5828 ada_is_others_clause (struct type
*type
, int field_num
)
5830 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5832 return (name
!= NULL
&& name
[0] == 'O');
5835 /* Assuming that TYPE0 is the type of the variant part of a record,
5836 returns the name of the discriminant controlling the variant.
5837 The value is valid until the next call to ada_variant_discrim_name. */
5840 ada_variant_discrim_name (struct type
*type0
)
5842 static char *result
= NULL
;
5843 static size_t result_len
= 0;
5846 const char *discrim_end
;
5847 const char *discrim_start
;
5849 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5850 type
= TYPE_TARGET_TYPE (type0
);
5854 name
= ada_type_name (type
);
5856 if (name
== NULL
|| name
[0] == '\000')
5859 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5862 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5865 if (discrim_end
== name
)
5868 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5871 if (discrim_start
== name
+ 1)
5873 if ((discrim_start
> name
+ 3
5874 && strncmp (discrim_start
- 3, "___", 3) == 0)
5875 || discrim_start
[-1] == '.')
5879 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5880 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5881 result
[discrim_end
- discrim_start
] = '\0';
5885 /* Scan STR for a subtype-encoded number, beginning at position K.
5886 Put the position of the character just past the number scanned in
5887 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5888 Return 1 if there was a valid number at the given position, and 0
5889 otherwise. A "subtype-encoded" number consists of the absolute value
5890 in decimal, followed by the letter 'm' to indicate a negative number.
5891 Assumes 0m does not occur. */
5894 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5898 if (!isdigit (str
[k
]))
5901 /* Do it the hard way so as not to make any assumption about
5902 the relationship of unsigned long (%lu scan format code) and
5905 while (isdigit (str
[k
]))
5907 RU
= RU
* 10 + (str
[k
] - '0');
5914 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5920 /* NOTE on the above: Technically, C does not say what the results of
5921 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5922 number representable as a LONGEST (although either would probably work
5923 in most implementations). When RU>0, the locution in the then branch
5924 above is always equivalent to the negative of RU. */
5931 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5932 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5933 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5936 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5938 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5952 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5962 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5963 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5965 if (val
>= L
&& val
<= U
)
5977 /* FIXME: Lots of redundancy below. Try to consolidate. */
5979 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5980 ARG_TYPE, extract and return the value of one of its (non-static)
5981 fields. FIELDNO says which field. Differs from value_primitive_field
5982 only in that it can handle packed values of arbitrary type. */
5984 static struct value
*
5985 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5986 struct type
*arg_type
)
5990 arg_type
= ada_check_typedef (arg_type
);
5991 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5993 /* Handle packed fields. */
5995 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5997 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5998 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6000 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6001 offset
+ bit_pos
/ 8,
6002 bit_pos
% 8, bit_size
, type
);
6005 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6008 /* Find field with name NAME in object of type TYPE. If found,
6009 set the following for each argument that is non-null:
6010 - *FIELD_TYPE_P to the field's type;
6011 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6012 an object of that type;
6013 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6014 - *BIT_SIZE_P to its size in bits if the field is packed, and
6016 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6017 fields up to but not including the desired field, or by the total
6018 number of fields if not found. A NULL value of NAME never
6019 matches; the function just counts visible fields in this case.
6021 Returns 1 if found, 0 otherwise. */
6024 find_struct_field (char *name
, struct type
*type
, int offset
,
6025 struct type
**field_type_p
,
6026 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
6031 type
= ada_check_typedef (type
);
6033 if (field_type_p
!= NULL
)
6034 *field_type_p
= NULL
;
6035 if (byte_offset_p
!= NULL
)
6037 if (bit_offset_p
!= NULL
)
6039 if (bit_size_p
!= NULL
)
6042 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6044 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6045 int fld_offset
= offset
+ bit_pos
/ 8;
6046 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6048 if (t_field_name
== NULL
)
6051 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
6053 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6055 if (field_type_p
!= NULL
)
6056 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6057 if (byte_offset_p
!= NULL
)
6058 *byte_offset_p
= fld_offset
;
6059 if (bit_offset_p
!= NULL
)
6060 *bit_offset_p
= bit_pos
% 8;
6061 if (bit_size_p
!= NULL
)
6062 *bit_size_p
= bit_size
;
6065 else if (ada_is_wrapper_field (type
, i
))
6067 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6068 field_type_p
, byte_offset_p
, bit_offset_p
,
6069 bit_size_p
, index_p
))
6072 else if (ada_is_variant_part (type
, i
))
6074 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6077 struct type
*field_type
6078 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6080 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6082 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
6084 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6085 field_type_p
, byte_offset_p
,
6086 bit_offset_p
, bit_size_p
, index_p
))
6090 else if (index_p
!= NULL
)
6096 /* Number of user-visible fields in record type TYPE. */
6099 num_visible_fields (struct type
*type
)
6104 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
6108 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6109 and search in it assuming it has (class) type TYPE.
6110 If found, return value, else return NULL.
6112 Searches recursively through wrapper fields (e.g., '_parent'). */
6114 static struct value
*
6115 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
6120 type
= ada_check_typedef (type
);
6121 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6123 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6125 if (t_field_name
== NULL
)
6128 else if (field_name_match (t_field_name
, name
))
6129 return ada_value_primitive_field (arg
, offset
, i
, type
);
6131 else if (ada_is_wrapper_field (type
, i
))
6133 struct value
*v
= /* Do not let indent join lines here. */
6134 ada_search_struct_field (name
, arg
,
6135 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6136 TYPE_FIELD_TYPE (type
, i
));
6142 else if (ada_is_variant_part (type
, i
))
6144 /* PNH: Do we ever get here? See find_struct_field. */
6146 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
6148 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6150 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6152 struct value
*v
= ada_search_struct_field
/* Force line break. */
6154 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6155 TYPE_FIELD_TYPE (field_type
, j
));
6165 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
6166 int, struct type
*);
6169 /* Return field #INDEX in ARG, where the index is that returned by
6170 * find_struct_field through its INDEX_P argument. Adjust the address
6171 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6172 * If found, return value, else return NULL. */
6174 static struct value
*
6175 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
6178 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
6182 /* Auxiliary function for ada_index_struct_field. Like
6183 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6186 static struct value
*
6187 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
6191 type
= ada_check_typedef (type
);
6193 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6195 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
6197 else if (ada_is_wrapper_field (type
, i
))
6199 struct value
*v
= /* Do not let indent join lines here. */
6200 ada_index_struct_field_1 (index_p
, arg
,
6201 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6202 TYPE_FIELD_TYPE (type
, i
));
6208 else if (ada_is_variant_part (type
, i
))
6210 /* PNH: Do we ever get here? See ada_search_struct_field,
6211 find_struct_field. */
6212 error (_("Cannot assign this kind of variant record"));
6214 else if (*index_p
== 0)
6215 return ada_value_primitive_field (arg
, offset
, i
, type
);
6222 /* Given ARG, a value of type (pointer or reference to a)*
6223 structure/union, extract the component named NAME from the ultimate
6224 target structure/union and return it as a value with its
6227 The routine searches for NAME among all members of the structure itself
6228 and (recursively) among all members of any wrapper members
6231 If NO_ERR, then simply return NULL in case of error, rather than
6235 ada_value_struct_elt (struct value
*arg
, char *name
, int no_err
)
6237 struct type
*t
, *t1
;
6241 t1
= t
= ada_check_typedef (value_type (arg
));
6242 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6244 t1
= TYPE_TARGET_TYPE (t
);
6247 t1
= ada_check_typedef (t1
);
6248 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6250 arg
= coerce_ref (arg
);
6255 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6257 t1
= TYPE_TARGET_TYPE (t
);
6260 t1
= ada_check_typedef (t1
);
6261 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6263 arg
= value_ind (arg
);
6270 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
6274 v
= ada_search_struct_field (name
, arg
, 0, t
);
6277 int bit_offset
, bit_size
, byte_offset
;
6278 struct type
*field_type
;
6281 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6282 address
= value_as_address (arg
);
6284 address
= unpack_pointer (t
, value_contents (arg
));
6286 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
, 1);
6287 if (find_struct_field (name
, t1
, 0,
6288 &field_type
, &byte_offset
, &bit_offset
,
6293 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6294 arg
= ada_coerce_ref (arg
);
6296 arg
= ada_value_ind (arg
);
6297 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
6298 bit_offset
, bit_size
,
6302 v
= value_at_lazy (field_type
, address
+ byte_offset
);
6306 if (v
!= NULL
|| no_err
)
6309 error (_("There is no member named %s."), name
);
6315 error (_("Attempt to extract a component of a value that is not a record."));
6318 /* Given a type TYPE, look up the type of the component of type named NAME.
6319 If DISPP is non-null, add its byte displacement from the beginning of a
6320 structure (pointed to by a value) of type TYPE to *DISPP (does not
6321 work for packed fields).
6323 Matches any field whose name has NAME as a prefix, possibly
6326 TYPE can be either a struct or union. If REFOK, TYPE may also
6327 be a (pointer or reference)+ to a struct or union, and the
6328 ultimate target type will be searched.
6330 Looks recursively into variant clauses and parent types.
6332 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6333 TYPE is not a type of the right kind. */
6335 static struct type
*
6336 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
6337 int noerr
, int *dispp
)
6344 if (refok
&& type
!= NULL
)
6347 type
= ada_check_typedef (type
);
6348 if (TYPE_CODE (type
) != TYPE_CODE_PTR
6349 && TYPE_CODE (type
) != TYPE_CODE_REF
)
6351 type
= TYPE_TARGET_TYPE (type
);
6355 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
6356 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
6362 target_terminal_ours ();
6363 gdb_flush (gdb_stdout
);
6365 error (_("Type (null) is not a structure or union type"));
6368 /* XXX: type_sprint */
6369 fprintf_unfiltered (gdb_stderr
, _("Type "));
6370 type_print (type
, "", gdb_stderr
, -1);
6371 error (_(" is not a structure or union type"));
6376 type
= to_static_fixed_type (type
);
6378 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6380 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6384 if (t_field_name
== NULL
)
6387 else if (field_name_match (t_field_name
, name
))
6390 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
6391 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6394 else if (ada_is_wrapper_field (type
, i
))
6397 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
6402 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6407 else if (ada_is_variant_part (type
, i
))
6410 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
6413 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
6415 /* FIXME pnh 2008/01/26: We check for a field that is
6416 NOT wrapped in a struct, since the compiler sometimes
6417 generates these for unchecked variant types. Revisit
6418 if the compiler changes this practice. */
6419 char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
6421 if (v_field_name
!= NULL
6422 && field_name_match (v_field_name
, name
))
6423 t
= ada_check_typedef (TYPE_FIELD_TYPE (field_type
, j
));
6425 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
6431 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6442 target_terminal_ours ();
6443 gdb_flush (gdb_stdout
);
6446 /* XXX: type_sprint */
6447 fprintf_unfiltered (gdb_stderr
, _("Type "));
6448 type_print (type
, "", gdb_stderr
, -1);
6449 error (_(" has no component named <null>"));
6453 /* XXX: type_sprint */
6454 fprintf_unfiltered (gdb_stderr
, _("Type "));
6455 type_print (type
, "", gdb_stderr
, -1);
6456 error (_(" has no component named %s"), name
);
6463 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6464 within a value of type OUTER_TYPE, return true iff VAR_TYPE
6465 represents an unchecked union (that is, the variant part of a
6466 record that is named in an Unchecked_Union pragma). */
6469 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
6471 char *discrim_name
= ada_variant_discrim_name (var_type
);
6473 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1, NULL
)
6478 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6479 within a value of type OUTER_TYPE that is stored in GDB at
6480 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6481 numbering from 0) is applicable. Returns -1 if none are. */
6484 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
6485 const gdb_byte
*outer_valaddr
)
6489 char *discrim_name
= ada_variant_discrim_name (var_type
);
6490 struct value
*outer
;
6491 struct value
*discrim
;
6492 LONGEST discrim_val
;
6494 outer
= value_from_contents_and_address (outer_type
, outer_valaddr
, 0);
6495 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
6496 if (discrim
== NULL
)
6498 discrim_val
= value_as_long (discrim
);
6501 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
6503 if (ada_is_others_clause (var_type
, i
))
6505 else if (ada_in_variant (discrim_val
, var_type
, i
))
6509 return others_clause
;
6514 /* Dynamic-Sized Records */
6516 /* Strategy: The type ostensibly attached to a value with dynamic size
6517 (i.e., a size that is not statically recorded in the debugging
6518 data) does not accurately reflect the size or layout of the value.
6519 Our strategy is to convert these values to values with accurate,
6520 conventional types that are constructed on the fly. */
6522 /* There is a subtle and tricky problem here. In general, we cannot
6523 determine the size of dynamic records without its data. However,
6524 the 'struct value' data structure, which GDB uses to represent
6525 quantities in the inferior process (the target), requires the size
6526 of the type at the time of its allocation in order to reserve space
6527 for GDB's internal copy of the data. That's why the
6528 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6529 rather than struct value*s.
6531 However, GDB's internal history variables ($1, $2, etc.) are
6532 struct value*s containing internal copies of the data that are not, in
6533 general, the same as the data at their corresponding addresses in
6534 the target. Fortunately, the types we give to these values are all
6535 conventional, fixed-size types (as per the strategy described
6536 above), so that we don't usually have to perform the
6537 'to_fixed_xxx_type' conversions to look at their values.
6538 Unfortunately, there is one exception: if one of the internal
6539 history variables is an array whose elements are unconstrained
6540 records, then we will need to create distinct fixed types for each
6541 element selected. */
6543 /* The upshot of all of this is that many routines take a (type, host
6544 address, target address) triple as arguments to represent a value.
6545 The host address, if non-null, is supposed to contain an internal
6546 copy of the relevant data; otherwise, the program is to consult the
6547 target at the target address. */
6549 /* Assuming that VAL0 represents a pointer value, the result of
6550 dereferencing it. Differs from value_ind in its treatment of
6551 dynamic-sized types. */
6554 ada_value_ind (struct value
*val0
)
6556 struct value
*val
= unwrap_value (value_ind (val0
));
6558 return ada_to_fixed_value (val
);
6561 /* The value resulting from dereferencing any "reference to"
6562 qualifiers on VAL0. */
6564 static struct value
*
6565 ada_coerce_ref (struct value
*val0
)
6567 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
6569 struct value
*val
= val0
;
6571 val
= coerce_ref (val
);
6572 val
= unwrap_value (val
);
6573 return ada_to_fixed_value (val
);
6579 /* Return OFF rounded upward if necessary to a multiple of
6580 ALIGNMENT (a power of 2). */
6583 align_value (unsigned int off
, unsigned int alignment
)
6585 return (off
+ alignment
- 1) & ~(alignment
- 1);
6588 /* Return the bit alignment required for field #F of template type TYPE. */
6591 field_alignment (struct type
*type
, int f
)
6593 const char *name
= TYPE_FIELD_NAME (type
, f
);
6597 /* The field name should never be null, unless the debugging information
6598 is somehow malformed. In this case, we assume the field does not
6599 require any alignment. */
6603 len
= strlen (name
);
6605 if (!isdigit (name
[len
- 1]))
6608 if (isdigit (name
[len
- 2]))
6609 align_offset
= len
- 2;
6611 align_offset
= len
- 1;
6613 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
6614 return TARGET_CHAR_BIT
;
6616 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
6619 /* Find a symbol named NAME. Ignores ambiguity. */
6622 ada_find_any_symbol (const char *name
)
6626 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
6627 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
6630 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
6634 /* Find a type named NAME. Ignores ambiguity. This routine will look
6635 solely for types defined by debug info, it will not search the GDB
6639 ada_find_any_type (const char *name
)
6641 struct symbol
*sym
= ada_find_any_symbol (name
);
6644 return SYMBOL_TYPE (sym
);
6649 /* Given NAME and an associated BLOCK, search all symbols for
6650 NAME suffixed with "___XR", which is the ``renaming'' symbol
6651 associated to NAME. Return this symbol if found, return
6655 ada_find_renaming_symbol (const char *name
, struct block
*block
)
6659 sym
= find_old_style_renaming_symbol (name
, block
);
6664 /* Not right yet. FIXME pnh 7/20/2007. */
6665 sym
= ada_find_any_symbol (name
);
6666 if (sym
!= NULL
&& strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR") != NULL
)
6672 static struct symbol
*
6673 find_old_style_renaming_symbol (const char *name
, struct block
*block
)
6675 const struct symbol
*function_sym
= block_linkage_function (block
);
6678 if (function_sym
!= NULL
)
6680 /* If the symbol is defined inside a function, NAME is not fully
6681 qualified. This means we need to prepend the function name
6682 as well as adding the ``___XR'' suffix to build the name of
6683 the associated renaming symbol. */
6684 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
6685 /* Function names sometimes contain suffixes used
6686 for instance to qualify nested subprograms. When building
6687 the XR type name, we need to make sure that this suffix is
6688 not included. So do not include any suffix in the function
6689 name length below. */
6690 int function_name_len
= ada_name_prefix_len (function_name
);
6691 const int rename_len
= function_name_len
+ 2 /* "__" */
6692 + strlen (name
) + 6 /* "___XR\0" */ ;
6694 /* Strip the suffix if necessary. */
6695 ada_remove_trailing_digits (function_name
, &function_name_len
);
6696 ada_remove_po_subprogram_suffix (function_name
, &function_name_len
);
6697 ada_remove_Xbn_suffix (function_name
, &function_name_len
);
6699 /* Library-level functions are a special case, as GNAT adds
6700 a ``_ada_'' prefix to the function name to avoid namespace
6701 pollution. However, the renaming symbols themselves do not
6702 have this prefix, so we need to skip this prefix if present. */
6703 if (function_name_len
> 5 /* "_ada_" */
6704 && strstr (function_name
, "_ada_") == function_name
)
6707 function_name_len
-= 5;
6710 rename
= (char *) alloca (rename_len
* sizeof (char));
6711 strncpy (rename
, function_name
, function_name_len
);
6712 xsnprintf (rename
+ function_name_len
, rename_len
- function_name_len
,
6717 const int rename_len
= strlen (name
) + 6;
6719 rename
= (char *) alloca (rename_len
* sizeof (char));
6720 xsnprintf (rename
, rename_len
* sizeof (char), "%s___XR", name
);
6723 return ada_find_any_symbol (rename
);
6726 /* Because of GNAT encoding conventions, several GDB symbols may match a
6727 given type name. If the type denoted by TYPE0 is to be preferred to
6728 that of TYPE1 for purposes of type printing, return non-zero;
6729 otherwise return 0. */
6732 ada_prefer_type (struct type
*type0
, struct type
*type1
)
6736 else if (type0
== NULL
)
6738 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
6740 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
6742 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
6744 else if (ada_is_constrained_packed_array_type (type0
))
6746 else if (ada_is_array_descriptor_type (type0
)
6747 && !ada_is_array_descriptor_type (type1
))
6751 const char *type0_name
= type_name_no_tag (type0
);
6752 const char *type1_name
= type_name_no_tag (type1
);
6754 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
6755 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
6761 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6762 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6765 ada_type_name (struct type
*type
)
6769 else if (TYPE_NAME (type
) != NULL
)
6770 return TYPE_NAME (type
);
6772 return TYPE_TAG_NAME (type
);
6775 /* Search the list of "descriptive" types associated to TYPE for a type
6776 whose name is NAME. */
6778 static struct type
*
6779 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
6781 struct type
*result
;
6783 /* If there no descriptive-type info, then there is no parallel type
6785 if (!HAVE_GNAT_AUX_INFO (type
))
6788 result
= TYPE_DESCRIPTIVE_TYPE (type
);
6789 while (result
!= NULL
)
6791 char *result_name
= ada_type_name (result
);
6793 if (result_name
== NULL
)
6795 warning (_("unexpected null name on descriptive type"));
6799 /* If the names match, stop. */
6800 if (strcmp (result_name
, name
) == 0)
6803 /* Otherwise, look at the next item on the list, if any. */
6804 if (HAVE_GNAT_AUX_INFO (result
))
6805 result
= TYPE_DESCRIPTIVE_TYPE (result
);
6810 /* If we didn't find a match, see whether this is a packed array. With
6811 older compilers, the descriptive type information is either absent or
6812 irrelevant when it comes to packed arrays so the above lookup fails.
6813 Fall back to using a parallel lookup by name in this case. */
6814 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
6815 return ada_find_any_type (name
);
6820 /* Find a parallel type to TYPE with the specified NAME, using the
6821 descriptive type taken from the debugging information, if available,
6822 and otherwise using the (slower) name-based method. */
6824 static struct type
*
6825 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
6827 struct type
*result
= NULL
;
6829 if (HAVE_GNAT_AUX_INFO (type
))
6830 result
= find_parallel_type_by_descriptive_type (type
, name
);
6832 result
= ada_find_any_type (name
);
6837 /* Same as above, but specify the name of the parallel type by appending
6838 SUFFIX to the name of TYPE. */
6841 ada_find_parallel_type (struct type
*type
, const char *suffix
)
6843 char *name
, *typename
= ada_type_name (type
);
6846 if (typename
== NULL
)
6849 len
= strlen (typename
);
6851 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
6853 strcpy (name
, typename
);
6854 strcpy (name
+ len
, suffix
);
6856 return ada_find_parallel_type_with_name (type
, name
);
6859 /* If TYPE is a variable-size record type, return the corresponding template
6860 type describing its fields. Otherwise, return NULL. */
6862 static struct type
*
6863 dynamic_template_type (struct type
*type
)
6865 type
= ada_check_typedef (type
);
6867 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
6868 || ada_type_name (type
) == NULL
)
6872 int len
= strlen (ada_type_name (type
));
6874 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
6877 return ada_find_parallel_type (type
, "___XVE");
6881 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6882 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6885 is_dynamic_field (struct type
*templ_type
, int field_num
)
6887 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
6890 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
6891 && strstr (name
, "___XVL") != NULL
;
6894 /* The index of the variant field of TYPE, or -1 if TYPE does not
6895 represent a variant record type. */
6898 variant_field_index (struct type
*type
)
6902 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6905 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6907 if (ada_is_variant_part (type
, f
))
6913 /* A record type with no fields. */
6915 static struct type
*
6916 empty_record (struct type
*template)
6918 struct type
*type
= alloc_type_copy (template);
6920 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6921 TYPE_NFIELDS (type
) = 0;
6922 TYPE_FIELDS (type
) = NULL
;
6923 INIT_CPLUS_SPECIFIC (type
);
6924 TYPE_NAME (type
) = "<empty>";
6925 TYPE_TAG_NAME (type
) = NULL
;
6926 TYPE_LENGTH (type
) = 0;
6930 /* An ordinary record type (with fixed-length fields) that describes
6931 the value of type TYPE at VALADDR or ADDRESS (see comments at
6932 the beginning of this section) VAL according to GNAT conventions.
6933 DVAL0 should describe the (portion of a) record that contains any
6934 necessary discriminants. It should be NULL if value_type (VAL) is
6935 an outer-level type (i.e., as opposed to a branch of a variant.) A
6936 variant field (unless unchecked) is replaced by a particular branch
6939 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6940 length are not statically known are discarded. As a consequence,
6941 VALADDR, ADDRESS and DVAL0 are ignored.
6943 NOTE: Limitations: For now, we assume that dynamic fields and
6944 variants occupy whole numbers of bytes. However, they need not be
6948 ada_template_to_fixed_record_type_1 (struct type
*type
,
6949 const gdb_byte
*valaddr
,
6950 CORE_ADDR address
, struct value
*dval0
,
6951 int keep_dynamic_fields
)
6953 struct value
*mark
= value_mark ();
6956 int nfields
, bit_len
;
6959 int fld_bit_len
, bit_incr
;
6962 /* Compute the number of fields in this record type that are going
6963 to be processed: unless keep_dynamic_fields, this includes only
6964 fields whose position and length are static will be processed. */
6965 if (keep_dynamic_fields
)
6966 nfields
= TYPE_NFIELDS (type
);
6970 while (nfields
< TYPE_NFIELDS (type
)
6971 && !ada_is_variant_part (type
, nfields
)
6972 && !is_dynamic_field (type
, nfields
))
6976 rtype
= alloc_type_copy (type
);
6977 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6978 INIT_CPLUS_SPECIFIC (rtype
);
6979 TYPE_NFIELDS (rtype
) = nfields
;
6980 TYPE_FIELDS (rtype
) = (struct field
*)
6981 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6982 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6983 TYPE_NAME (rtype
) = ada_type_name (type
);
6984 TYPE_TAG_NAME (rtype
) = NULL
;
6985 TYPE_FIXED_INSTANCE (rtype
) = 1;
6991 for (f
= 0; f
< nfields
; f
+= 1)
6993 off
= align_value (off
, field_alignment (type
, f
))
6994 + TYPE_FIELD_BITPOS (type
, f
);
6995 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6996 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6998 if (ada_is_variant_part (type
, f
))
7001 fld_bit_len
= bit_incr
= 0;
7003 else if (is_dynamic_field (type
, f
))
7005 const gdb_byte
*field_valaddr
= valaddr
;
7006 CORE_ADDR field_address
= address
;
7007 struct type
*field_type
=
7008 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
));
7012 /* rtype's length is computed based on the run-time
7013 value of discriminants. If the discriminants are not
7014 initialized, the type size may be completely bogus and
7015 GDB may fail to allocate a value for it. So check the
7016 size first before creating the value. */
7018 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7023 /* If the type referenced by this field is an aligner type, we need
7024 to unwrap that aligner type, because its size might not be set.
7025 Keeping the aligner type would cause us to compute the wrong
7026 size for this field, impacting the offset of the all the fields
7027 that follow this one. */
7028 if (ada_is_aligner_type (field_type
))
7030 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7032 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7033 field_address
= cond_offset_target (field_address
, field_offset
);
7034 field_type
= ada_aligned_type (field_type
);
7037 field_valaddr
= cond_offset_host (field_valaddr
,
7038 off
/ TARGET_CHAR_BIT
);
7039 field_address
= cond_offset_target (field_address
,
7040 off
/ TARGET_CHAR_BIT
);
7042 /* Get the fixed type of the field. Note that, in this case,
7043 we do not want to get the real type out of the tag: if
7044 the current field is the parent part of a tagged record,
7045 we will get the tag of the object. Clearly wrong: the real
7046 type of the parent is not the real type of the child. We
7047 would end up in an infinite loop. */
7048 field_type
= ada_get_base_type (field_type
);
7049 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7050 field_address
, dval
, 0);
7052 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
7053 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7054 bit_incr
= fld_bit_len
=
7055 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
7059 struct type
*field_type
= TYPE_FIELD_TYPE (type
, f
);
7061 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
7062 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7063 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7064 bit_incr
= fld_bit_len
=
7065 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7067 bit_incr
= fld_bit_len
=
7068 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
7070 if (off
+ fld_bit_len
> bit_len
)
7071 bit_len
= off
+ fld_bit_len
;
7073 TYPE_LENGTH (rtype
) =
7074 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7077 /* We handle the variant part, if any, at the end because of certain
7078 odd cases in which it is re-ordered so as NOT to be the last field of
7079 the record. This can happen in the presence of representation
7081 if (variant_field
>= 0)
7083 struct type
*branch_type
;
7085 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
7088 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7093 to_fixed_variant_branch_type
7094 (TYPE_FIELD_TYPE (type
, variant_field
),
7095 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7096 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7097 if (branch_type
== NULL
)
7099 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
7100 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7101 TYPE_NFIELDS (rtype
) -= 1;
7105 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7106 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7108 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
7110 if (off
+ fld_bit_len
> bit_len
)
7111 bit_len
= off
+ fld_bit_len
;
7112 TYPE_LENGTH (rtype
) =
7113 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7117 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7118 should contain the alignment of that record, which should be a strictly
7119 positive value. If null or negative, then something is wrong, most
7120 probably in the debug info. In that case, we don't round up the size
7121 of the resulting type. If this record is not part of another structure,
7122 the current RTYPE length might be good enough for our purposes. */
7123 if (TYPE_LENGTH (type
) <= 0)
7125 if (TYPE_NAME (rtype
))
7126 warning (_("Invalid type size for `%s' detected: %d."),
7127 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
7129 warning (_("Invalid type size for <unnamed> detected: %d."),
7130 TYPE_LENGTH (type
));
7134 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
7135 TYPE_LENGTH (type
));
7138 value_free_to_mark (mark
);
7139 if (TYPE_LENGTH (rtype
) > varsize_limit
)
7140 error (_("record type with dynamic size is larger than varsize-limit"));
7144 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7147 static struct type
*
7148 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
7149 CORE_ADDR address
, struct value
*dval0
)
7151 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
7155 /* An ordinary record type in which ___XVL-convention fields and
7156 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7157 static approximations, containing all possible fields. Uses
7158 no runtime values. Useless for use in values, but that's OK,
7159 since the results are used only for type determinations. Works on both
7160 structs and unions. Representation note: to save space, we memorize
7161 the result of this function in the TYPE_TARGET_TYPE of the
7164 static struct type
*
7165 template_to_static_fixed_type (struct type
*type0
)
7171 if (TYPE_TARGET_TYPE (type0
) != NULL
)
7172 return TYPE_TARGET_TYPE (type0
);
7174 nfields
= TYPE_NFIELDS (type0
);
7177 for (f
= 0; f
< nfields
; f
+= 1)
7179 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
7180 struct type
*new_type
;
7182 if (is_dynamic_field (type0
, f
))
7183 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
7185 new_type
= static_unwrap_type (field_type
);
7186 if (type
== type0
&& new_type
!= field_type
)
7188 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
7189 TYPE_CODE (type
) = TYPE_CODE (type0
);
7190 INIT_CPLUS_SPECIFIC (type
);
7191 TYPE_NFIELDS (type
) = nfields
;
7192 TYPE_FIELDS (type
) = (struct field
*)
7193 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
7194 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
7195 sizeof (struct field
) * nfields
);
7196 TYPE_NAME (type
) = ada_type_name (type0
);
7197 TYPE_TAG_NAME (type
) = NULL
;
7198 TYPE_FIXED_INSTANCE (type
) = 1;
7199 TYPE_LENGTH (type
) = 0;
7201 TYPE_FIELD_TYPE (type
, f
) = new_type
;
7202 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
7207 /* Given an object of type TYPE whose contents are at VALADDR and
7208 whose address in memory is ADDRESS, returns a revision of TYPE,
7209 which should be a non-dynamic-sized record, in which the variant
7210 part, if any, is replaced with the appropriate branch. Looks
7211 for discriminant values in DVAL0, which can be NULL if the record
7212 contains the necessary discriminant values. */
7214 static struct type
*
7215 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
7216 CORE_ADDR address
, struct value
*dval0
)
7218 struct value
*mark
= value_mark ();
7221 struct type
*branch_type
;
7222 int nfields
= TYPE_NFIELDS (type
);
7223 int variant_field
= variant_field_index (type
);
7225 if (variant_field
== -1)
7229 dval
= value_from_contents_and_address (type
, valaddr
, address
);
7233 rtype
= alloc_type_copy (type
);
7234 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7235 INIT_CPLUS_SPECIFIC (rtype
);
7236 TYPE_NFIELDS (rtype
) = nfields
;
7237 TYPE_FIELDS (rtype
) =
7238 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7239 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
7240 sizeof (struct field
) * nfields
);
7241 TYPE_NAME (rtype
) = ada_type_name (type
);
7242 TYPE_TAG_NAME (rtype
) = NULL
;
7243 TYPE_FIXED_INSTANCE (rtype
) = 1;
7244 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
7246 branch_type
= to_fixed_variant_branch_type
7247 (TYPE_FIELD_TYPE (type
, variant_field
),
7248 cond_offset_host (valaddr
,
7249 TYPE_FIELD_BITPOS (type
, variant_field
)
7251 cond_offset_target (address
,
7252 TYPE_FIELD_BITPOS (type
, variant_field
)
7253 / TARGET_CHAR_BIT
), dval
);
7254 if (branch_type
== NULL
)
7258 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
7259 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7260 TYPE_NFIELDS (rtype
) -= 1;
7264 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7265 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7266 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
7267 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
7269 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
7271 value_free_to_mark (mark
);
7275 /* An ordinary record type (with fixed-length fields) that describes
7276 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7277 beginning of this section]. Any necessary discriminants' values
7278 should be in DVAL, a record value; it may be NULL if the object
7279 at ADDR itself contains any necessary discriminant values.
7280 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7281 values from the record are needed. Except in the case that DVAL,
7282 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7283 unchecked) is replaced by a particular branch of the variant.
7285 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7286 is questionable and may be removed. It can arise during the
7287 processing of an unconstrained-array-of-record type where all the
7288 variant branches have exactly the same size. This is because in
7289 such cases, the compiler does not bother to use the XVS convention
7290 when encoding the record. I am currently dubious of this
7291 shortcut and suspect the compiler should be altered. FIXME. */
7293 static struct type
*
7294 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
7295 CORE_ADDR address
, struct value
*dval
)
7297 struct type
*templ_type
;
7299 if (TYPE_FIXED_INSTANCE (type0
))
7302 templ_type
= dynamic_template_type (type0
);
7304 if (templ_type
!= NULL
)
7305 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
7306 else if (variant_field_index (type0
) >= 0)
7308 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
7310 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
7315 TYPE_FIXED_INSTANCE (type0
) = 1;
7321 /* An ordinary record type (with fixed-length fields) that describes
7322 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7323 union type. Any necessary discriminants' values should be in DVAL,
7324 a record value. That is, this routine selects the appropriate
7325 branch of the union at ADDR according to the discriminant value
7326 indicated in the union's type name. Returns VAR_TYPE0 itself if
7327 it represents a variant subject to a pragma Unchecked_Union. */
7329 static struct type
*
7330 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
7331 CORE_ADDR address
, struct value
*dval
)
7334 struct type
*templ_type
;
7335 struct type
*var_type
;
7337 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
7338 var_type
= TYPE_TARGET_TYPE (var_type0
);
7340 var_type
= var_type0
;
7342 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
7344 if (templ_type
!= NULL
)
7345 var_type
= templ_type
;
7347 if (is_unchecked_variant (var_type
, value_type (dval
)))
7350 ada_which_variant_applies (var_type
,
7351 value_type (dval
), value_contents (dval
));
7354 return empty_record (var_type
);
7355 else if (is_dynamic_field (var_type
, which
))
7356 return to_fixed_record_type
7357 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
7358 valaddr
, address
, dval
);
7359 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
7361 to_fixed_record_type
7362 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
7364 return TYPE_FIELD_TYPE (var_type
, which
);
7367 /* Assuming that TYPE0 is an array type describing the type of a value
7368 at ADDR, and that DVAL describes a record containing any
7369 discriminants used in TYPE0, returns a type for the value that
7370 contains no dynamic components (that is, no components whose sizes
7371 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7372 true, gives an error message if the resulting type's size is over
7375 static struct type
*
7376 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
7379 struct type
*index_type_desc
;
7380 struct type
*result
;
7381 int constrained_packed_array_p
;
7383 if (TYPE_FIXED_INSTANCE (type0
))
7386 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
7387 if (constrained_packed_array_p
)
7388 type0
= decode_constrained_packed_array_type (type0
);
7390 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
7391 ada_fixup_array_indexes_type (index_type_desc
);
7392 if (index_type_desc
== NULL
)
7394 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
7396 /* NOTE: elt_type---the fixed version of elt_type0---should never
7397 depend on the contents of the array in properly constructed
7399 /* Create a fixed version of the array element type.
7400 We're not providing the address of an element here,
7401 and thus the actual object value cannot be inspected to do
7402 the conversion. This should not be a problem, since arrays of
7403 unconstrained objects are not allowed. In particular, all
7404 the elements of an array of a tagged type should all be of
7405 the same type specified in the debugging info. No need to
7406 consult the object tag. */
7407 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
7409 /* Make sure we always create a new array type when dealing with
7410 packed array types, since we're going to fix-up the array
7411 type length and element bitsize a little further down. */
7412 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
7415 result
= create_array_type (alloc_type_copy (type0
),
7416 elt_type
, TYPE_INDEX_TYPE (type0
));
7421 struct type
*elt_type0
;
7424 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
7425 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
7427 /* NOTE: result---the fixed version of elt_type0---should never
7428 depend on the contents of the array in properly constructed
7430 /* Create a fixed version of the array element type.
7431 We're not providing the address of an element here,
7432 and thus the actual object value cannot be inspected to do
7433 the conversion. This should not be a problem, since arrays of
7434 unconstrained objects are not allowed. In particular, all
7435 the elements of an array of a tagged type should all be of
7436 the same type specified in the debugging info. No need to
7437 consult the object tag. */
7439 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
7442 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
7444 struct type
*range_type
=
7445 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, i
), dval
);
7447 result
= create_array_type (alloc_type_copy (elt_type0
),
7448 result
, range_type
);
7449 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
7451 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
7452 error (_("array type with dynamic size is larger than varsize-limit"));
7455 if (constrained_packed_array_p
)
7457 /* So far, the resulting type has been created as if the original
7458 type was a regular (non-packed) array type. As a result, the
7459 bitsize of the array elements needs to be set again, and the array
7460 length needs to be recomputed based on that bitsize. */
7461 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
7462 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
7464 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
7465 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
7466 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
7467 TYPE_LENGTH (result
)++;
7470 TYPE_FIXED_INSTANCE (result
) = 1;
7475 /* A standard type (containing no dynamically sized components)
7476 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7477 DVAL describes a record containing any discriminants used in TYPE0,
7478 and may be NULL if there are none, or if the object of type TYPE at
7479 ADDRESS or in VALADDR contains these discriminants.
7481 If CHECK_TAG is not null, in the case of tagged types, this function
7482 attempts to locate the object's tag and use it to compute the actual
7483 type. However, when ADDRESS is null, we cannot use it to determine the
7484 location of the tag, and therefore compute the tagged type's actual type.
7485 So we return the tagged type without consulting the tag. */
7487 static struct type
*
7488 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
7489 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7491 type
= ada_check_typedef (type
);
7492 switch (TYPE_CODE (type
))
7496 case TYPE_CODE_STRUCT
:
7498 struct type
*static_type
= to_static_fixed_type (type
);
7499 struct type
*fixed_record_type
=
7500 to_fixed_record_type (type
, valaddr
, address
, NULL
);
7502 /* If STATIC_TYPE is a tagged type and we know the object's address,
7503 then we can determine its tag, and compute the object's actual
7504 type from there. Note that we have to use the fixed record
7505 type (the parent part of the record may have dynamic fields
7506 and the way the location of _tag is expressed may depend on
7509 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
7511 struct type
*real_type
=
7512 type_from_tag (value_tag_from_contents_and_address
7517 if (real_type
!= NULL
)
7518 return to_fixed_record_type (real_type
, valaddr
, address
, NULL
);
7521 /* Check to see if there is a parallel ___XVZ variable.
7522 If there is, then it provides the actual size of our type. */
7523 else if (ada_type_name (fixed_record_type
) != NULL
)
7525 char *name
= ada_type_name (fixed_record_type
);
7526 char *xvz_name
= alloca (strlen (name
) + 7 /* "___XVZ\0" */);
7530 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
7531 size
= get_int_var_value (xvz_name
, &xvz_found
);
7532 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
7534 fixed_record_type
= copy_type (fixed_record_type
);
7535 TYPE_LENGTH (fixed_record_type
) = size
;
7537 /* The FIXED_RECORD_TYPE may have be a stub. We have
7538 observed this when the debugging info is STABS, and
7539 apparently it is something that is hard to fix.
7541 In practice, we don't need the actual type definition
7542 at all, because the presence of the XVZ variable allows us
7543 to assume that there must be a XVS type as well, which we
7544 should be able to use later, when we need the actual type
7547 In the meantime, pretend that the "fixed" type we are
7548 returning is NOT a stub, because this can cause trouble
7549 when using this type to create new types targeting it.
7550 Indeed, the associated creation routines often check
7551 whether the target type is a stub and will try to replace
7552 it, thus using a type with the wrong size. This, in turn,
7553 might cause the new type to have the wrong size too.
7554 Consider the case of an array, for instance, where the size
7555 of the array is computed from the number of elements in
7556 our array multiplied by the size of its element. */
7557 TYPE_STUB (fixed_record_type
) = 0;
7560 return fixed_record_type
;
7562 case TYPE_CODE_ARRAY
:
7563 return to_fixed_array_type (type
, dval
, 1);
7564 case TYPE_CODE_UNION
:
7568 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
7572 /* The same as ada_to_fixed_type_1, except that it preserves the type
7573 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7574 ada_to_fixed_type_1 would return the type referenced by TYPE. */
7577 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
7578 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7581 struct type
*fixed_type
=
7582 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
7584 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
7585 && TYPE_TARGET_TYPE (type
) == fixed_type
)
7591 /* A standard (static-sized) type corresponding as well as possible to
7592 TYPE0, but based on no runtime data. */
7594 static struct type
*
7595 to_static_fixed_type (struct type
*type0
)
7602 if (TYPE_FIXED_INSTANCE (type0
))
7605 type0
= ada_check_typedef (type0
);
7607 switch (TYPE_CODE (type0
))
7611 case TYPE_CODE_STRUCT
:
7612 type
= dynamic_template_type (type0
);
7614 return template_to_static_fixed_type (type
);
7616 return template_to_static_fixed_type (type0
);
7617 case TYPE_CODE_UNION
:
7618 type
= ada_find_parallel_type (type0
, "___XVU");
7620 return template_to_static_fixed_type (type
);
7622 return template_to_static_fixed_type (type0
);
7626 /* A static approximation of TYPE with all type wrappers removed. */
7628 static struct type
*
7629 static_unwrap_type (struct type
*type
)
7631 if (ada_is_aligner_type (type
))
7633 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
7634 if (ada_type_name (type1
) == NULL
)
7635 TYPE_NAME (type1
) = ada_type_name (type
);
7637 return static_unwrap_type (type1
);
7641 struct type
*raw_real_type
= ada_get_base_type (type
);
7643 if (raw_real_type
== type
)
7646 return to_static_fixed_type (raw_real_type
);
7650 /* In some cases, incomplete and private types require
7651 cross-references that are not resolved as records (for example,
7653 type FooP is access Foo;
7655 type Foo is array ...;
7656 ). In these cases, since there is no mechanism for producing
7657 cross-references to such types, we instead substitute for FooP a
7658 stub enumeration type that is nowhere resolved, and whose tag is
7659 the name of the actual type. Call these types "non-record stubs". */
7661 /* A type equivalent to TYPE that is not a non-record stub, if one
7662 exists, otherwise TYPE. */
7665 ada_check_typedef (struct type
*type
)
7670 CHECK_TYPEDEF (type
);
7671 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
7672 || !TYPE_STUB (type
)
7673 || TYPE_TAG_NAME (type
) == NULL
)
7677 char *name
= TYPE_TAG_NAME (type
);
7678 struct type
*type1
= ada_find_any_type (name
);
7683 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
7684 stubs pointing to arrays, as we don't create symbols for array
7685 types, only for the typedef-to-array types). This is why
7686 we process TYPE1 with ada_check_typedef before returning
7688 return ada_check_typedef (type1
);
7692 /* A value representing the data at VALADDR/ADDRESS as described by
7693 type TYPE0, but with a standard (static-sized) type that correctly
7694 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7695 type, then return VAL0 [this feature is simply to avoid redundant
7696 creation of struct values]. */
7698 static struct value
*
7699 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
7702 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
7704 if (type
== type0
&& val0
!= NULL
)
7707 return value_from_contents_and_address (type
, 0, address
);
7710 /* A value representing VAL, but with a standard (static-sized) type
7711 that correctly describes it. Does not necessarily create a new
7715 ada_to_fixed_value (struct value
*val
)
7717 return ada_to_fixed_value_create (value_type (val
),
7718 value_address (val
),
7725 /* Table mapping attribute numbers to names.
7726 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7728 static const char *attribute_names
[] = {
7746 ada_attribute_name (enum exp_opcode n
)
7748 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
7749 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
7751 return attribute_names
[0];
7754 /* Evaluate the 'POS attribute applied to ARG. */
7757 pos_atr (struct value
*arg
)
7759 struct value
*val
= coerce_ref (arg
);
7760 struct type
*type
= value_type (val
);
7762 if (!discrete_type_p (type
))
7763 error (_("'POS only defined on discrete types"));
7765 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7768 LONGEST v
= value_as_long (val
);
7770 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7772 if (v
== TYPE_FIELD_BITPOS (type
, i
))
7775 error (_("enumeration value is invalid: can't find 'POS"));
7778 return value_as_long (val
);
7781 static struct value
*
7782 value_pos_atr (struct type
*type
, struct value
*arg
)
7784 return value_from_longest (type
, pos_atr (arg
));
7787 /* Evaluate the TYPE'VAL attribute applied to ARG. */
7789 static struct value
*
7790 value_val_atr (struct type
*type
, struct value
*arg
)
7792 if (!discrete_type_p (type
))
7793 error (_("'VAL only defined on discrete types"));
7794 if (!integer_type_p (value_type (arg
)))
7795 error (_("'VAL requires integral argument"));
7797 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7799 long pos
= value_as_long (arg
);
7801 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
7802 error (_("argument to 'VAL out of range"));
7803 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
7806 return value_from_longest (type
, value_as_long (arg
));
7812 /* True if TYPE appears to be an Ada character type.
7813 [At the moment, this is true only for Character and Wide_Character;
7814 It is a heuristic test that could stand improvement]. */
7817 ada_is_character_type (struct type
*type
)
7821 /* If the type code says it's a character, then assume it really is,
7822 and don't check any further. */
7823 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
7826 /* Otherwise, assume it's a character type iff it is a discrete type
7827 with a known character type name. */
7828 name
= ada_type_name (type
);
7829 return (name
!= NULL
7830 && (TYPE_CODE (type
) == TYPE_CODE_INT
7831 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7832 && (strcmp (name
, "character") == 0
7833 || strcmp (name
, "wide_character") == 0
7834 || strcmp (name
, "wide_wide_character") == 0
7835 || strcmp (name
, "unsigned char") == 0));
7838 /* True if TYPE appears to be an Ada string type. */
7841 ada_is_string_type (struct type
*type
)
7843 type
= ada_check_typedef (type
);
7845 && TYPE_CODE (type
) != TYPE_CODE_PTR
7846 && (ada_is_simple_array_type (type
)
7847 || ada_is_array_descriptor_type (type
))
7848 && ada_array_arity (type
) == 1)
7850 struct type
*elttype
= ada_array_element_type (type
, 1);
7852 return ada_is_character_type (elttype
);
7858 /* The compiler sometimes provides a parallel XVS type for a given
7859 PAD type. Normally, it is safe to follow the PAD type directly,
7860 but older versions of the compiler have a bug that causes the offset
7861 of its "F" field to be wrong. Following that field in that case
7862 would lead to incorrect results, but this can be worked around
7863 by ignoring the PAD type and using the associated XVS type instead.
7865 Set to True if the debugger should trust the contents of PAD types.
7866 Otherwise, ignore the PAD type if there is a parallel XVS type. */
7867 static int trust_pad_over_xvs
= 1;
7869 /* True if TYPE is a struct type introduced by the compiler to force the
7870 alignment of a value. Such types have a single field with a
7871 distinctive name. */
7874 ada_is_aligner_type (struct type
*type
)
7876 type
= ada_check_typedef (type
);
7878 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
7881 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
7882 && TYPE_NFIELDS (type
) == 1
7883 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
7886 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7887 the parallel type. */
7890 ada_get_base_type (struct type
*raw_type
)
7892 struct type
*real_type_namer
;
7893 struct type
*raw_real_type
;
7895 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
7898 if (ada_is_aligner_type (raw_type
))
7899 /* The encoding specifies that we should always use the aligner type.
7900 So, even if this aligner type has an associated XVS type, we should
7903 According to the compiler gurus, an XVS type parallel to an aligner
7904 type may exist because of a stabs limitation. In stabs, aligner
7905 types are empty because the field has a variable-sized type, and
7906 thus cannot actually be used as an aligner type. As a result,
7907 we need the associated parallel XVS type to decode the type.
7908 Since the policy in the compiler is to not change the internal
7909 representation based on the debugging info format, we sometimes
7910 end up having a redundant XVS type parallel to the aligner type. */
7913 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
7914 if (real_type_namer
== NULL
7915 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
7916 || TYPE_NFIELDS (real_type_namer
) != 1)
7919 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer
, 0)) != TYPE_CODE_REF
)
7921 /* This is an older encoding form where the base type needs to be
7922 looked up by name. We prefer the newer enconding because it is
7924 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
7925 if (raw_real_type
== NULL
)
7928 return raw_real_type
;
7931 /* The field in our XVS type is a reference to the base type. */
7932 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer
, 0));
7935 /* The type of value designated by TYPE, with all aligners removed. */
7938 ada_aligned_type (struct type
*type
)
7940 if (ada_is_aligner_type (type
))
7941 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
7943 return ada_get_base_type (type
);
7947 /* The address of the aligned value in an object at address VALADDR
7948 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7951 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
7953 if (ada_is_aligner_type (type
))
7954 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
7956 TYPE_FIELD_BITPOS (type
,
7957 0) / TARGET_CHAR_BIT
);
7964 /* The printed representation of an enumeration literal with encoded
7965 name NAME. The value is good to the next call of ada_enum_name. */
7967 ada_enum_name (const char *name
)
7969 static char *result
;
7970 static size_t result_len
= 0;
7973 /* First, unqualify the enumeration name:
7974 1. Search for the last '.' character. If we find one, then skip
7975 all the preceeding characters, the unqualified name starts
7976 right after that dot.
7977 2. Otherwise, we may be debugging on a target where the compiler
7978 translates dots into "__". Search forward for double underscores,
7979 but stop searching when we hit an overloading suffix, which is
7980 of the form "__" followed by digits. */
7982 tmp
= strrchr (name
, '.');
7987 while ((tmp
= strstr (name
, "__")) != NULL
)
7989 if (isdigit (tmp
[2]))
8000 if (name
[1] == 'U' || name
[1] == 'W')
8002 if (sscanf (name
+ 2, "%x", &v
) != 1)
8008 GROW_VECT (result
, result_len
, 16);
8009 if (isascii (v
) && isprint (v
))
8010 xsnprintf (result
, result_len
, "'%c'", v
);
8011 else if (name
[1] == 'U')
8012 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
8014 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
8020 tmp
= strstr (name
, "__");
8022 tmp
= strstr (name
, "$");
8025 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
8026 strncpy (result
, name
, tmp
- name
);
8027 result
[tmp
- name
] = '\0';
8035 /* Evaluate the subexpression of EXP starting at *POS as for
8036 evaluate_type, updating *POS to point just past the evaluated
8039 static struct value
*
8040 evaluate_subexp_type (struct expression
*exp
, int *pos
)
8042 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8045 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8048 static struct value
*
8049 unwrap_value (struct value
*val
)
8051 struct type
*type
= ada_check_typedef (value_type (val
));
8053 if (ada_is_aligner_type (type
))
8055 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
8056 struct type
*val_type
= ada_check_typedef (value_type (v
));
8058 if (ada_type_name (val_type
) == NULL
)
8059 TYPE_NAME (val_type
) = ada_type_name (type
);
8061 return unwrap_value (v
);
8065 struct type
*raw_real_type
=
8066 ada_check_typedef (ada_get_base_type (type
));
8068 /* If there is no parallel XVS or XVE type, then the value is
8069 already unwrapped. Return it without further modification. */
8070 if ((type
== raw_real_type
)
8071 && ada_find_parallel_type (type
, "___XVE") == NULL
)
8075 coerce_unspec_val_to_type
8076 (val
, ada_to_fixed_type (raw_real_type
, 0,
8077 value_address (val
),
8082 static struct value
*
8083 cast_to_fixed (struct type
*type
, struct value
*arg
)
8087 if (type
== value_type (arg
))
8089 else if (ada_is_fixed_point_type (value_type (arg
)))
8090 val
= ada_float_to_fixed (type
,
8091 ada_fixed_to_float (value_type (arg
),
8092 value_as_long (arg
)));
8095 DOUBLEST argd
= value_as_double (arg
);
8097 val
= ada_float_to_fixed (type
, argd
);
8100 return value_from_longest (type
, val
);
8103 static struct value
*
8104 cast_from_fixed (struct type
*type
, struct value
*arg
)
8106 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
8107 value_as_long (arg
));
8109 return value_from_double (type
, val
);
8112 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8113 return the converted value. */
8115 static struct value
*
8116 coerce_for_assign (struct type
*type
, struct value
*val
)
8118 struct type
*type2
= value_type (val
);
8123 type2
= ada_check_typedef (type2
);
8124 type
= ada_check_typedef (type
);
8126 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
8127 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8129 val
= ada_value_ind (val
);
8130 type2
= value_type (val
);
8133 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
8134 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8136 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
8137 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
8138 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
8139 error (_("Incompatible types in assignment"));
8140 deprecated_set_value_type (val
, type
);
8145 static struct value
*
8146 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
8149 struct type
*type1
, *type2
;
8152 arg1
= coerce_ref (arg1
);
8153 arg2
= coerce_ref (arg2
);
8154 type1
= base_type (ada_check_typedef (value_type (arg1
)));
8155 type2
= base_type (ada_check_typedef (value_type (arg2
)));
8157 if (TYPE_CODE (type1
) != TYPE_CODE_INT
8158 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
8159 return value_binop (arg1
, arg2
, op
);
8168 return value_binop (arg1
, arg2
, op
);
8171 v2
= value_as_long (arg2
);
8173 error (_("second operand of %s must not be zero."), op_string (op
));
8175 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
8176 return value_binop (arg1
, arg2
, op
);
8178 v1
= value_as_long (arg1
);
8183 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
8184 v
+= v
> 0 ? -1 : 1;
8192 /* Should not reach this point. */
8196 val
= allocate_value (type1
);
8197 store_unsigned_integer (value_contents_raw (val
),
8198 TYPE_LENGTH (value_type (val
)),
8199 gdbarch_byte_order (get_type_arch (type1
)), v
);
8204 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
8206 if (ada_is_direct_array_type (value_type (arg1
))
8207 || ada_is_direct_array_type (value_type (arg2
)))
8209 /* Automatically dereference any array reference before
8210 we attempt to perform the comparison. */
8211 arg1
= ada_coerce_ref (arg1
);
8212 arg2
= ada_coerce_ref (arg2
);
8214 arg1
= ada_coerce_to_simple_array (arg1
);
8215 arg2
= ada_coerce_to_simple_array (arg2
);
8216 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
8217 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
8218 error (_("Attempt to compare array with non-array"));
8219 /* FIXME: The following works only for types whose
8220 representations use all bits (no padding or undefined bits)
8221 and do not have user-defined equality. */
8223 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
8224 && memcmp (value_contents (arg1
), value_contents (arg2
),
8225 TYPE_LENGTH (value_type (arg1
))) == 0;
8227 return value_equal (arg1
, arg2
);
8230 /* Total number of component associations in the aggregate starting at
8231 index PC in EXP. Assumes that index PC is the start of an
8235 num_component_specs (struct expression
*exp
, int pc
)
8239 m
= exp
->elts
[pc
+ 1].longconst
;
8242 for (i
= 0; i
< m
; i
+= 1)
8244 switch (exp
->elts
[pc
].opcode
)
8250 n
+= exp
->elts
[pc
+ 1].longconst
;
8253 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
8258 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
8259 component of LHS (a simple array or a record), updating *POS past
8260 the expression, assuming that LHS is contained in CONTAINER. Does
8261 not modify the inferior's memory, nor does it modify LHS (unless
8262 LHS == CONTAINER). */
8265 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
8266 struct expression
*exp
, int *pos
)
8268 struct value
*mark
= value_mark ();
8271 if (TYPE_CODE (value_type (lhs
)) == TYPE_CODE_ARRAY
)
8273 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
8274 struct value
*index_val
= value_from_longest (index_type
, index
);
8276 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
8280 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
8281 elt
= ada_to_fixed_value (unwrap_value (elt
));
8284 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8285 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
8287 value_assign_to_component (container
, elt
,
8288 ada_evaluate_subexp (NULL
, exp
, pos
,
8291 value_free_to_mark (mark
);
8294 /* Assuming that LHS represents an lvalue having a record or array
8295 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8296 of that aggregate's value to LHS, advancing *POS past the
8297 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8298 lvalue containing LHS (possibly LHS itself). Does not modify
8299 the inferior's memory, nor does it modify the contents of
8300 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
8302 static struct value
*
8303 assign_aggregate (struct value
*container
,
8304 struct value
*lhs
, struct expression
*exp
,
8305 int *pos
, enum noside noside
)
8307 struct type
*lhs_type
;
8308 int n
= exp
->elts
[*pos
+1].longconst
;
8309 LONGEST low_index
, high_index
;
8312 int max_indices
, num_indices
;
8313 int is_array_aggregate
;
8317 if (noside
!= EVAL_NORMAL
)
8321 for (i
= 0; i
< n
; i
+= 1)
8322 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
8326 container
= ada_coerce_ref (container
);
8327 if (ada_is_direct_array_type (value_type (container
)))
8328 container
= ada_coerce_to_simple_array (container
);
8329 lhs
= ada_coerce_ref (lhs
);
8330 if (!deprecated_value_modifiable (lhs
))
8331 error (_("Left operand of assignment is not a modifiable lvalue."));
8333 lhs_type
= value_type (lhs
);
8334 if (ada_is_direct_array_type (lhs_type
))
8336 lhs
= ada_coerce_to_simple_array (lhs
);
8337 lhs_type
= value_type (lhs
);
8338 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
8339 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
8340 is_array_aggregate
= 1;
8342 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
8345 high_index
= num_visible_fields (lhs_type
) - 1;
8346 is_array_aggregate
= 0;
8349 error (_("Left-hand side must be array or record."));
8351 num_specs
= num_component_specs (exp
, *pos
- 3);
8352 max_indices
= 4 * num_specs
+ 4;
8353 indices
= alloca (max_indices
* sizeof (indices
[0]));
8354 indices
[0] = indices
[1] = low_index
- 1;
8355 indices
[2] = indices
[3] = high_index
+ 1;
8358 for (i
= 0; i
< n
; i
+= 1)
8360 switch (exp
->elts
[*pos
].opcode
)
8363 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
8364 &num_indices
, max_indices
,
8365 low_index
, high_index
);
8368 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
8369 &num_indices
, max_indices
,
8370 low_index
, high_index
);
8374 error (_("Misplaced 'others' clause"));
8375 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
8376 num_indices
, low_index
, high_index
);
8379 error (_("Internal error: bad aggregate clause"));
8386 /* Assign into the component of LHS indexed by the OP_POSITIONAL
8387 construct at *POS, updating *POS past the construct, given that
8388 the positions are relative to lower bound LOW, where HIGH is the
8389 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8390 updating *NUM_INDICES as needed. CONTAINER is as for
8391 assign_aggregate. */
8393 aggregate_assign_positional (struct value
*container
,
8394 struct value
*lhs
, struct expression
*exp
,
8395 int *pos
, LONGEST
*indices
, int *num_indices
,
8396 int max_indices
, LONGEST low
, LONGEST high
)
8398 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
8400 if (ind
- 1 == high
)
8401 warning (_("Extra components in aggregate ignored."));
8404 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
8406 assign_component (container
, lhs
, ind
, exp
, pos
);
8409 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8412 /* Assign into the components of LHS indexed by the OP_CHOICES
8413 construct at *POS, updating *POS past the construct, given that
8414 the allowable indices are LOW..HIGH. Record the indices assigned
8415 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8416 needed. CONTAINER is as for assign_aggregate. */
8418 aggregate_assign_from_choices (struct value
*container
,
8419 struct value
*lhs
, struct expression
*exp
,
8420 int *pos
, LONGEST
*indices
, int *num_indices
,
8421 int max_indices
, LONGEST low
, LONGEST high
)
8424 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
8425 int choice_pos
, expr_pc
;
8426 int is_array
= ada_is_direct_array_type (value_type (lhs
));
8428 choice_pos
= *pos
+= 3;
8430 for (j
= 0; j
< n_choices
; j
+= 1)
8431 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8433 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8435 for (j
= 0; j
< n_choices
; j
+= 1)
8437 LONGEST lower
, upper
;
8438 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
8440 if (op
== OP_DISCRETE_RANGE
)
8443 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8445 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8450 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
8462 name
= &exp
->elts
[choice_pos
+ 2].string
;
8465 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
8468 error (_("Invalid record component association."));
8470 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
8472 if (! find_struct_field (name
, value_type (lhs
), 0,
8473 NULL
, NULL
, NULL
, NULL
, &ind
))
8474 error (_("Unknown component name: %s."), name
);
8475 lower
= upper
= ind
;
8478 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
8479 error (_("Index in component association out of bounds."));
8481 add_component_interval (lower
, upper
, indices
, num_indices
,
8483 while (lower
<= upper
)
8488 assign_component (container
, lhs
, lower
, exp
, &pos1
);
8494 /* Assign the value of the expression in the OP_OTHERS construct in
8495 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8496 have not been previously assigned. The index intervals already assigned
8497 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8498 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
8500 aggregate_assign_others (struct value
*container
,
8501 struct value
*lhs
, struct expression
*exp
,
8502 int *pos
, LONGEST
*indices
, int num_indices
,
8503 LONGEST low
, LONGEST high
)
8506 int expr_pc
= *pos
+1;
8508 for (i
= 0; i
< num_indices
- 2; i
+= 2)
8512 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
8517 assign_component (container
, lhs
, ind
, exp
, &pos
);
8520 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8523 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
8524 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8525 modifying *SIZE as needed. It is an error if *SIZE exceeds
8526 MAX_SIZE. The resulting intervals do not overlap. */
8528 add_component_interval (LONGEST low
, LONGEST high
,
8529 LONGEST
* indices
, int *size
, int max_size
)
8533 for (i
= 0; i
< *size
; i
+= 2) {
8534 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
8538 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
8539 if (high
< indices
[kh
])
8541 if (low
< indices
[i
])
8543 indices
[i
+ 1] = indices
[kh
- 1];
8544 if (high
> indices
[i
+ 1])
8545 indices
[i
+ 1] = high
;
8546 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
8547 *size
-= kh
- i
- 2;
8550 else if (high
< indices
[i
])
8554 if (*size
== max_size
)
8555 error (_("Internal error: miscounted aggregate components."));
8557 for (j
= *size
-1; j
>= i
+2; j
-= 1)
8558 indices
[j
] = indices
[j
- 2];
8560 indices
[i
+ 1] = high
;
8563 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8566 static struct value
*
8567 ada_value_cast (struct type
*type
, struct value
*arg2
, enum noside noside
)
8569 if (type
== ada_check_typedef (value_type (arg2
)))
8572 if (ada_is_fixed_point_type (type
))
8573 return (cast_to_fixed (type
, arg2
));
8575 if (ada_is_fixed_point_type (value_type (arg2
)))
8576 return cast_from_fixed (type
, arg2
);
8578 return value_cast (type
, arg2
);
8581 /* Evaluating Ada expressions, and printing their result.
8582 ------------------------------------------------------
8587 We usually evaluate an Ada expression in order to print its value.
8588 We also evaluate an expression in order to print its type, which
8589 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
8590 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
8591 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
8592 the evaluation compared to the EVAL_NORMAL, but is otherwise very
8595 Evaluating expressions is a little more complicated for Ada entities
8596 than it is for entities in languages such as C. The main reason for
8597 this is that Ada provides types whose definition might be dynamic.
8598 One example of such types is variant records. Or another example
8599 would be an array whose bounds can only be known at run time.
8601 The following description is a general guide as to what should be
8602 done (and what should NOT be done) in order to evaluate an expression
8603 involving such types, and when. This does not cover how the semantic
8604 information is encoded by GNAT as this is covered separatly. For the
8605 document used as the reference for the GNAT encoding, see exp_dbug.ads
8606 in the GNAT sources.
8608 Ideally, we should embed each part of this description next to its
8609 associated code. Unfortunately, the amount of code is so vast right
8610 now that it's hard to see whether the code handling a particular
8611 situation might be duplicated or not. One day, when the code is
8612 cleaned up, this guide might become redundant with the comments
8613 inserted in the code, and we might want to remove it.
8615 2. ``Fixing'' an Entity, the Simple Case:
8616 -----------------------------------------
8618 When evaluating Ada expressions, the tricky issue is that they may
8619 reference entities whose type contents and size are not statically
8620 known. Consider for instance a variant record:
8622 type Rec (Empty : Boolean := True) is record
8625 when False => Value : Integer;
8628 Yes : Rec := (Empty => False, Value => 1);
8629 No : Rec := (empty => True);
8631 The size and contents of that record depends on the value of the
8632 descriminant (Rec.Empty). At this point, neither the debugging
8633 information nor the associated type structure in GDB are able to
8634 express such dynamic types. So what the debugger does is to create
8635 "fixed" versions of the type that applies to the specific object.
8636 We also informally refer to this opperation as "fixing" an object,
8637 which means creating its associated fixed type.
8639 Example: when printing the value of variable "Yes" above, its fixed
8640 type would look like this:
8647 On the other hand, if we printed the value of "No", its fixed type
8654 Things become a little more complicated when trying to fix an entity
8655 with a dynamic type that directly contains another dynamic type,
8656 such as an array of variant records, for instance. There are
8657 two possible cases: Arrays, and records.
8659 3. ``Fixing'' Arrays:
8660 ---------------------
8662 The type structure in GDB describes an array in terms of its bounds,
8663 and the type of its elements. By design, all elements in the array
8664 have the same type and we cannot represent an array of variant elements
8665 using the current type structure in GDB. When fixing an array,
8666 we cannot fix the array element, as we would potentially need one
8667 fixed type per element of the array. As a result, the best we can do
8668 when fixing an array is to produce an array whose bounds and size
8669 are correct (allowing us to read it from memory), but without having
8670 touched its element type. Fixing each element will be done later,
8671 when (if) necessary.
8673 Arrays are a little simpler to handle than records, because the same
8674 amount of memory is allocated for each element of the array, even if
8675 the amount of space actually used by each element differs from element
8676 to element. Consider for instance the following array of type Rec:
8678 type Rec_Array is array (1 .. 2) of Rec;
8680 The actual amount of memory occupied by each element might be different
8681 from element to element, depending on the value of their discriminant.
8682 But the amount of space reserved for each element in the array remains
8683 fixed regardless. So we simply need to compute that size using
8684 the debugging information available, from which we can then determine
8685 the array size (we multiply the number of elements of the array by
8686 the size of each element).
8688 The simplest case is when we have an array of a constrained element
8689 type. For instance, consider the following type declarations:
8691 type Bounded_String (Max_Size : Integer) is
8693 Buffer : String (1 .. Max_Size);
8695 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
8697 In this case, the compiler describes the array as an array of
8698 variable-size elements (identified by its XVS suffix) for which
8699 the size can be read in the parallel XVZ variable.
8701 In the case of an array of an unconstrained element type, the compiler
8702 wraps the array element inside a private PAD type. This type should not
8703 be shown to the user, and must be "unwrap"'ed before printing. Note
8704 that we also use the adjective "aligner" in our code to designate
8705 these wrapper types.
8707 In some cases, the size allocated for each element is statically
8708 known. In that case, the PAD type already has the correct size,
8709 and the array element should remain unfixed.
8711 But there are cases when this size is not statically known.
8712 For instance, assuming that "Five" is an integer variable:
8714 type Dynamic is array (1 .. Five) of Integer;
8715 type Wrapper (Has_Length : Boolean := False) is record
8718 when True => Length : Integer;
8722 type Wrapper_Array is array (1 .. 2) of Wrapper;
8724 Hello : Wrapper_Array := (others => (Has_Length => True,
8725 Data => (others => 17),
8729 The debugging info would describe variable Hello as being an
8730 array of a PAD type. The size of that PAD type is not statically
8731 known, but can be determined using a parallel XVZ variable.
8732 In that case, a copy of the PAD type with the correct size should
8733 be used for the fixed array.
8735 3. ``Fixing'' record type objects:
8736 ----------------------------------
8738 Things are slightly different from arrays in the case of dynamic
8739 record types. In this case, in order to compute the associated
8740 fixed type, we need to determine the size and offset of each of
8741 its components. This, in turn, requires us to compute the fixed
8742 type of each of these components.
8744 Consider for instance the example:
8746 type Bounded_String (Max_Size : Natural) is record
8747 Str : String (1 .. Max_Size);
8750 My_String : Bounded_String (Max_Size => 10);
8752 In that case, the position of field "Length" depends on the size
8753 of field Str, which itself depends on the value of the Max_Size
8754 discriminant. In order to fix the type of variable My_String,
8755 we need to fix the type of field Str. Therefore, fixing a variant
8756 record requires us to fix each of its components.
8758 However, if a component does not have a dynamic size, the component
8759 should not be fixed. In particular, fields that use a PAD type
8760 should not fixed. Here is an example where this might happen
8761 (assuming type Rec above):
8763 type Container (Big : Boolean) is record
8767 when True => Another : Integer;
8771 My_Container : Container := (Big => False,
8772 First => (Empty => True),
8775 In that example, the compiler creates a PAD type for component First,
8776 whose size is constant, and then positions the component After just
8777 right after it. The offset of component After is therefore constant
8780 The debugger computes the position of each field based on an algorithm
8781 that uses, among other things, the actual position and size of the field
8782 preceding it. Let's now imagine that the user is trying to print
8783 the value of My_Container. If the type fixing was recursive, we would
8784 end up computing the offset of field After based on the size of the
8785 fixed version of field First. And since in our example First has
8786 only one actual field, the size of the fixed type is actually smaller
8787 than the amount of space allocated to that field, and thus we would
8788 compute the wrong offset of field After.
8790 To make things more complicated, we need to watch out for dynamic
8791 components of variant records (identified by the ___XVL suffix in
8792 the component name). Even if the target type is a PAD type, the size
8793 of that type might not be statically known. So the PAD type needs
8794 to be unwrapped and the resulting type needs to be fixed. Otherwise,
8795 we might end up with the wrong size for our component. This can be
8796 observed with the following type declarations:
8798 type Octal is new Integer range 0 .. 7;
8799 type Octal_Array is array (Positive range <>) of Octal;
8800 pragma Pack (Octal_Array);
8802 type Octal_Buffer (Size : Positive) is record
8803 Buffer : Octal_Array (1 .. Size);
8807 In that case, Buffer is a PAD type whose size is unset and needs
8808 to be computed by fixing the unwrapped type.
8810 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
8811 ----------------------------------------------------------
8813 Lastly, when should the sub-elements of an entity that remained unfixed
8814 thus far, be actually fixed?
8816 The answer is: Only when referencing that element. For instance
8817 when selecting one component of a record, this specific component
8818 should be fixed at that point in time. Or when printing the value
8819 of a record, each component should be fixed before its value gets
8820 printed. Similarly for arrays, the element of the array should be
8821 fixed when printing each element of the array, or when extracting
8822 one element out of that array. On the other hand, fixing should
8823 not be performed on the elements when taking a slice of an array!
8825 Note that one of the side-effects of miscomputing the offset and
8826 size of each field is that we end up also miscomputing the size
8827 of the containing type. This can have adverse results when computing
8828 the value of an entity. GDB fetches the value of an entity based
8829 on the size of its type, and thus a wrong size causes GDB to fetch
8830 the wrong amount of memory. In the case where the computed size is
8831 too small, GDB fetches too little data to print the value of our
8832 entiry. Results in this case as unpredicatble, as we usually read
8833 past the buffer containing the data =:-o. */
8835 /* Implement the evaluate_exp routine in the exp_descriptor structure
8836 for the Ada language. */
8838 static struct value
*
8839 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
8840 int *pos
, enum noside noside
)
8845 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
8848 struct value
**argvec
;
8852 op
= exp
->elts
[pc
].opcode
;
8858 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8859 arg1
= unwrap_value (arg1
);
8861 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8862 then we need to perform the conversion manually, because
8863 evaluate_subexp_standard doesn't do it. This conversion is
8864 necessary in Ada because the different kinds of float/fixed
8865 types in Ada have different representations.
8867 Similarly, we need to perform the conversion from OP_LONG
8869 if ((op
== OP_DOUBLE
|| op
== OP_LONG
) && expect_type
!= NULL
)
8870 arg1
= ada_value_cast (expect_type
, arg1
, noside
);
8876 struct value
*result
;
8879 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8880 /* The result type will have code OP_STRING, bashed there from
8881 OP_ARRAY. Bash it back. */
8882 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
8883 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
8889 type
= exp
->elts
[pc
+ 1].type
;
8890 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
8891 if (noside
== EVAL_SKIP
)
8893 arg1
= ada_value_cast (type
, arg1
, noside
);
8898 type
= exp
->elts
[pc
+ 1].type
;
8899 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
8902 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8903 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8905 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
8906 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8908 return ada_value_assign (arg1
, arg1
);
8910 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8911 except if the lhs of our assignment is a convenience variable.
8912 In the case of assigning to a convenience variable, the lhs
8913 should be exactly the result of the evaluation of the rhs. */
8914 type
= value_type (arg1
);
8915 if (VALUE_LVAL (arg1
) == lval_internalvar
)
8917 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
8918 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8920 if (ada_is_fixed_point_type (value_type (arg1
)))
8921 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
8922 else if (ada_is_fixed_point_type (value_type (arg2
)))
8924 (_("Fixed-point values must be assigned to fixed-point variables"));
8926 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
8927 return ada_value_assign (arg1
, arg2
);
8930 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8931 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8932 if (noside
== EVAL_SKIP
)
8934 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8935 return (value_from_longest
8937 value_as_long (arg1
) + value_as_long (arg2
)));
8938 if ((ada_is_fixed_point_type (value_type (arg1
))
8939 || ada_is_fixed_point_type (value_type (arg2
)))
8940 && value_type (arg1
) != value_type (arg2
))
8941 error (_("Operands of fixed-point addition must have the same type"));
8942 /* Do the addition, and cast the result to the type of the first
8943 argument. We cannot cast the result to a reference type, so if
8944 ARG1 is a reference type, find its underlying type. */
8945 type
= value_type (arg1
);
8946 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8947 type
= TYPE_TARGET_TYPE (type
);
8948 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8949 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
8952 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8953 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8954 if (noside
== EVAL_SKIP
)
8956 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8957 return (value_from_longest
8959 value_as_long (arg1
) - value_as_long (arg2
)));
8960 if ((ada_is_fixed_point_type (value_type (arg1
))
8961 || ada_is_fixed_point_type (value_type (arg2
)))
8962 && value_type (arg1
) != value_type (arg2
))
8963 error (_("Operands of fixed-point subtraction must have the same type"));
8964 /* Do the substraction, and cast the result to the type of the first
8965 argument. We cannot cast the result to a reference type, so if
8966 ARG1 is a reference type, find its underlying type. */
8967 type
= value_type (arg1
);
8968 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8969 type
= TYPE_TARGET_TYPE (type
);
8970 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8971 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
8977 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8978 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8979 if (noside
== EVAL_SKIP
)
8981 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8983 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8984 return value_zero (value_type (arg1
), not_lval
);
8988 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
8989 if (ada_is_fixed_point_type (value_type (arg1
)))
8990 arg1
= cast_from_fixed (type
, arg1
);
8991 if (ada_is_fixed_point_type (value_type (arg2
)))
8992 arg2
= cast_from_fixed (type
, arg2
);
8993 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8994 return ada_value_binop (arg1
, arg2
, op
);
8998 case BINOP_NOTEQUAL
:
8999 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9000 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
9001 if (noside
== EVAL_SKIP
)
9003 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9007 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9008 tem
= ada_value_equal (arg1
, arg2
);
9010 if (op
== BINOP_NOTEQUAL
)
9012 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9013 return value_from_longest (type
, (LONGEST
) tem
);
9016 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9017 if (noside
== EVAL_SKIP
)
9019 else if (ada_is_fixed_point_type (value_type (arg1
)))
9020 return value_cast (value_type (arg1
), value_neg (arg1
));
9023 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9024 return value_neg (arg1
);
9027 case BINOP_LOGICAL_AND
:
9028 case BINOP_LOGICAL_OR
:
9029 case UNOP_LOGICAL_NOT
:
9034 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9035 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9036 return value_cast (type
, val
);
9039 case BINOP_BITWISE_AND
:
9040 case BINOP_BITWISE_IOR
:
9041 case BINOP_BITWISE_XOR
:
9045 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9047 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9049 return value_cast (value_type (arg1
), val
);
9055 if (noside
== EVAL_SKIP
)
9060 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
9061 /* Only encountered when an unresolved symbol occurs in a
9062 context other than a function call, in which case, it is
9064 error (_("Unexpected unresolved symbol, %s, during evaluation"),
9065 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
9066 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9068 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
9069 /* Check to see if this is a tagged type. We also need to handle
9070 the case where the type is a reference to a tagged type, but
9071 we have to be careful to exclude pointers to tagged types.
9072 The latter should be shown as usual (as a pointer), whereas
9073 a reference should mostly be transparent to the user. */
9074 if (ada_is_tagged_type (type
, 0)
9075 || (TYPE_CODE(type
) == TYPE_CODE_REF
9076 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
9078 /* Tagged types are a little special in the fact that the real
9079 type is dynamic and can only be determined by inspecting the
9080 object's tag. This means that we need to get the object's
9081 value first (EVAL_NORMAL) and then extract the actual object
9084 Note that we cannot skip the final step where we extract
9085 the object type from its tag, because the EVAL_NORMAL phase
9086 results in dynamic components being resolved into fixed ones.
9087 This can cause problems when trying to print the type
9088 description of tagged types whose parent has a dynamic size:
9089 We use the type name of the "_parent" component in order
9090 to print the name of the ancestor type in the type description.
9091 If that component had a dynamic size, the resolution into
9092 a fixed type would result in the loss of that type name,
9093 thus preventing us from printing the name of the ancestor
9094 type in the type description. */
9095 struct type
*actual_type
;
9097 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
9098 actual_type
= type_from_tag (ada_value_tag (arg1
));
9099 if (actual_type
== NULL
)
9100 /* If, for some reason, we were unable to determine
9101 the actual type from the tag, then use the static
9102 approximation that we just computed as a fallback.
9103 This can happen if the debugging information is
9104 incomplete, for instance. */
9107 return value_zero (actual_type
, not_lval
);
9112 (to_static_fixed_type
9113 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
9118 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9119 arg1
= unwrap_value (arg1
);
9120 return ada_to_fixed_value (arg1
);
9126 /* Allocate arg vector, including space for the function to be
9127 called in argvec[0] and a terminating NULL. */
9128 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9130 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
9132 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
9133 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
9134 error (_("Unexpected unresolved symbol, %s, during evaluation"),
9135 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
9138 for (tem
= 0; tem
<= nargs
; tem
+= 1)
9139 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9142 if (noside
== EVAL_SKIP
)
9146 if (ada_is_constrained_packed_array_type
9147 (desc_base_type (value_type (argvec
[0]))))
9148 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
9149 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
9150 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
9151 /* This is a packed array that has already been fixed, and
9152 therefore already coerced to a simple array. Nothing further
9155 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
9156 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
9157 && VALUE_LVAL (argvec
[0]) == lval_memory
))
9158 argvec
[0] = value_addr (argvec
[0]);
9160 type
= ada_check_typedef (value_type (argvec
[0]));
9161 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
9163 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
9165 case TYPE_CODE_FUNC
:
9166 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
9168 case TYPE_CODE_ARRAY
:
9170 case TYPE_CODE_STRUCT
:
9171 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
9172 argvec
[0] = ada_value_ind (argvec
[0]);
9173 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
9176 error (_("cannot subscript or call something of type `%s'"),
9177 ada_type_name (value_type (argvec
[0])));
9182 switch (TYPE_CODE (type
))
9184 case TYPE_CODE_FUNC
:
9185 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9186 return allocate_value (TYPE_TARGET_TYPE (type
));
9187 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
9188 case TYPE_CODE_STRUCT
:
9192 arity
= ada_array_arity (type
);
9193 type
= ada_array_element_type (type
, nargs
);
9195 error (_("cannot subscript or call a record"));
9197 error (_("wrong number of subscripts; expecting %d"), arity
);
9198 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9199 return value_zero (ada_aligned_type (type
), lval_memory
);
9201 unwrap_value (ada_value_subscript
9202 (argvec
[0], nargs
, argvec
+ 1));
9204 case TYPE_CODE_ARRAY
:
9205 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9207 type
= ada_array_element_type (type
, nargs
);
9209 error (_("element type of array unknown"));
9211 return value_zero (ada_aligned_type (type
), lval_memory
);
9214 unwrap_value (ada_value_subscript
9215 (ada_coerce_to_simple_array (argvec
[0]),
9216 nargs
, argvec
+ 1));
9217 case TYPE_CODE_PTR
: /* Pointer to array */
9218 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
9219 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9221 type
= ada_array_element_type (type
, nargs
);
9223 error (_("element type of array unknown"));
9225 return value_zero (ada_aligned_type (type
), lval_memory
);
9228 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
9229 nargs
, argvec
+ 1));
9232 error (_("Attempt to index or call something other than an "
9233 "array or function"));
9238 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9239 struct value
*low_bound_val
=
9240 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9241 struct value
*high_bound_val
=
9242 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9246 low_bound_val
= coerce_ref (low_bound_val
);
9247 high_bound_val
= coerce_ref (high_bound_val
);
9248 low_bound
= pos_atr (low_bound_val
);
9249 high_bound
= pos_atr (high_bound_val
);
9251 if (noside
== EVAL_SKIP
)
9254 /* If this is a reference to an aligner type, then remove all
9256 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
9257 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
9258 TYPE_TARGET_TYPE (value_type (array
)) =
9259 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
9261 if (ada_is_constrained_packed_array_type (value_type (array
)))
9262 error (_("cannot slice a packed array"));
9264 /* If this is a reference to an array or an array lvalue,
9265 convert to a pointer. */
9266 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
9267 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
9268 && VALUE_LVAL (array
) == lval_memory
))
9269 array
= value_addr (array
);
9271 if (noside
== EVAL_AVOID_SIDE_EFFECTS
9272 && ada_is_array_descriptor_type (ada_check_typedef
9273 (value_type (array
))))
9274 return empty_array (ada_type_of_array (array
, 0), low_bound
);
9276 array
= ada_coerce_to_simple_array_ptr (array
);
9278 /* If we have more than one level of pointer indirection,
9279 dereference the value until we get only one level. */
9280 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
9281 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
9283 array
= value_ind (array
);
9285 /* Make sure we really do have an array type before going further,
9286 to avoid a SEGV when trying to get the index type or the target
9287 type later down the road if the debug info generated by
9288 the compiler is incorrect or incomplete. */
9289 if (!ada_is_simple_array_type (value_type (array
)))
9290 error (_("cannot take slice of non-array"));
9292 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
9294 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
9295 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
9299 struct type
*arr_type0
=
9300 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
9303 return ada_value_slice_from_ptr (array
, arr_type0
,
9304 longest_to_int (low_bound
),
9305 longest_to_int (high_bound
));
9308 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9310 else if (high_bound
< low_bound
)
9311 return empty_array (value_type (array
), low_bound
);
9313 return ada_value_slice (array
, longest_to_int (low_bound
),
9314 longest_to_int (high_bound
));
9319 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9320 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
9322 if (noside
== EVAL_SKIP
)
9325 switch (TYPE_CODE (type
))
9328 lim_warning (_("Membership test incompletely implemented; "
9329 "always returns true"));
9330 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9331 return value_from_longest (type
, (LONGEST
) 1);
9333 case TYPE_CODE_RANGE
:
9334 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
9335 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
9336 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9337 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
9338 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9340 value_from_longest (type
,
9341 (value_less (arg1
, arg3
)
9342 || value_equal (arg1
, arg3
))
9343 && (value_less (arg2
, arg1
)
9344 || value_equal (arg2
, arg1
)));
9347 case BINOP_IN_BOUNDS
:
9349 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9350 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9352 if (noside
== EVAL_SKIP
)
9355 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9357 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9358 return value_zero (type
, not_lval
);
9361 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9363 type
= ada_index_type (value_type (arg2
), tem
, "range");
9365 type
= value_type (arg1
);
9367 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
9368 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
9370 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9371 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
9372 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9374 value_from_longest (type
,
9375 (value_less (arg1
, arg3
)
9376 || value_equal (arg1
, arg3
))
9377 && (value_less (arg2
, arg1
)
9378 || value_equal (arg2
, arg1
)));
9380 case TERNOP_IN_RANGE
:
9381 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9382 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9383 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9385 if (noside
== EVAL_SKIP
)
9388 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9389 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
9390 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9392 value_from_longest (type
,
9393 (value_less (arg1
, arg3
)
9394 || value_equal (arg1
, arg3
))
9395 && (value_less (arg2
, arg1
)
9396 || value_equal (arg2
, arg1
)));
9402 struct type
*type_arg
;
9404 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
9406 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9408 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
9412 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9416 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
9417 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
9418 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
9421 if (noside
== EVAL_SKIP
)
9424 if (type_arg
== NULL
)
9426 arg1
= ada_coerce_ref (arg1
);
9428 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
9429 arg1
= ada_coerce_to_simple_array (arg1
);
9431 type
= ada_index_type (value_type (arg1
), tem
,
9432 ada_attribute_name (op
));
9434 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9436 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9437 return allocate_value (type
);
9441 default: /* Should never happen. */
9442 error (_("unexpected attribute encountered"));
9444 return value_from_longest
9445 (type
, ada_array_bound (arg1
, tem
, 0));
9447 return value_from_longest
9448 (type
, ada_array_bound (arg1
, tem
, 1));
9450 return value_from_longest
9451 (type
, ada_array_length (arg1
, tem
));
9454 else if (discrete_type_p (type_arg
))
9456 struct type
*range_type
;
9457 char *name
= ada_type_name (type_arg
);
9460 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
9461 range_type
= to_fixed_range_type (type_arg
, NULL
);
9462 if (range_type
== NULL
)
9463 range_type
= type_arg
;
9467 error (_("unexpected attribute encountered"));
9469 return value_from_longest
9470 (range_type
, ada_discrete_type_low_bound (range_type
));
9472 return value_from_longest
9473 (range_type
, ada_discrete_type_high_bound (range_type
));
9475 error (_("the 'length attribute applies only to array types"));
9478 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
9479 error (_("unimplemented type attribute"));
9484 if (ada_is_constrained_packed_array_type (type_arg
))
9485 type_arg
= decode_constrained_packed_array_type (type_arg
);
9487 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
9489 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9491 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9492 return allocate_value (type
);
9497 error (_("unexpected attribute encountered"));
9499 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
9500 return value_from_longest (type
, low
);
9502 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
9503 return value_from_longest (type
, high
);
9505 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
9506 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
9507 return value_from_longest (type
, high
- low
+ 1);
9513 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9514 if (noside
== EVAL_SKIP
)
9517 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9518 return value_zero (ada_tag_type (arg1
), not_lval
);
9520 return ada_value_tag (arg1
);
9524 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9525 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9526 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9527 if (noside
== EVAL_SKIP
)
9529 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9530 return value_zero (value_type (arg1
), not_lval
);
9533 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9534 return value_binop (arg1
, arg2
,
9535 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
9538 case OP_ATR_MODULUS
:
9540 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
9542 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9543 if (noside
== EVAL_SKIP
)
9546 if (!ada_is_modular_type (type_arg
))
9547 error (_("'modulus must be applied to modular type"));
9549 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
9550 ada_modulus (type_arg
));
9555 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9556 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9557 if (noside
== EVAL_SKIP
)
9559 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9560 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9561 return value_zero (type
, not_lval
);
9563 return value_pos_atr (type
, arg1
);
9566 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9567 type
= value_type (arg1
);
9569 /* If the argument is a reference, then dereference its type, since
9570 the user is really asking for the size of the actual object,
9571 not the size of the pointer. */
9572 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
9573 type
= TYPE_TARGET_TYPE (type
);
9575 if (noside
== EVAL_SKIP
)
9577 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9578 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
9580 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
9581 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
9584 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9585 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9586 type
= exp
->elts
[pc
+ 2].type
;
9587 if (noside
== EVAL_SKIP
)
9589 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9590 return value_zero (type
, not_lval
);
9592 return value_val_atr (type
, arg1
);
9595 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9596 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9597 if (noside
== EVAL_SKIP
)
9599 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9600 return value_zero (value_type (arg1
), not_lval
);
9603 /* For integer exponentiation operations,
9604 only promote the first argument. */
9605 if (is_integral_type (value_type (arg2
)))
9606 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9608 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9610 return value_binop (arg1
, arg2
, op
);
9614 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9615 if (noside
== EVAL_SKIP
)
9621 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9622 if (noside
== EVAL_SKIP
)
9624 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9625 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
9626 return value_neg (arg1
);
9631 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9632 if (noside
== EVAL_SKIP
)
9634 type
= ada_check_typedef (value_type (arg1
));
9635 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9637 if (ada_is_array_descriptor_type (type
))
9638 /* GDB allows dereferencing GNAT array descriptors. */
9640 struct type
*arrType
= ada_type_of_array (arg1
, 0);
9642 if (arrType
== NULL
)
9643 error (_("Attempt to dereference null array pointer."));
9644 return value_at_lazy (arrType
, 0);
9646 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
9647 || TYPE_CODE (type
) == TYPE_CODE_REF
9648 /* In C you can dereference an array to get the 1st elt. */
9649 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9651 type
= to_static_fixed_type
9653 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
9655 return value_zero (type
, lval_memory
);
9657 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9659 /* GDB allows dereferencing an int. */
9660 if (expect_type
== NULL
)
9661 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
9666 to_static_fixed_type (ada_aligned_type (expect_type
));
9667 return value_zero (expect_type
, lval_memory
);
9671 error (_("Attempt to take contents of a non-pointer value."));
9673 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
9674 type
= ada_check_typedef (value_type (arg1
));
9676 if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9677 /* GDB allows dereferencing an int. If we were given
9678 the expect_type, then use that as the target type.
9679 Otherwise, assume that the target type is an int. */
9681 if (expect_type
!= NULL
)
9682 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
9685 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
9686 (CORE_ADDR
) value_as_address (arg1
));
9689 if (ada_is_array_descriptor_type (type
))
9690 /* GDB allows dereferencing GNAT array descriptors. */
9691 return ada_coerce_to_simple_array (arg1
);
9693 return ada_value_ind (arg1
);
9695 case STRUCTOP_STRUCT
:
9696 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9697 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
9698 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9699 if (noside
== EVAL_SKIP
)
9701 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9703 struct type
*type1
= value_type (arg1
);
9705 if (ada_is_tagged_type (type1
, 1))
9707 type
= ada_lookup_struct_elt_type (type1
,
9708 &exp
->elts
[pc
+ 2].string
,
9711 /* In this case, we assume that the field COULD exist
9712 in some extension of the type. Return an object of
9713 "type" void, which will match any formal
9714 (see ada_type_match). */
9715 return value_zero (builtin_type (exp
->gdbarch
)->builtin_void
,
9720 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
9723 return value_zero (ada_aligned_type (type
), lval_memory
);
9726 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
9727 arg1
= unwrap_value (arg1
);
9728 return ada_to_fixed_value (arg1
);
9731 /* The value is not supposed to be used. This is here to make it
9732 easier to accommodate expressions that contain types. */
9734 if (noside
== EVAL_SKIP
)
9736 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9737 return allocate_value (exp
->elts
[pc
+ 1].type
);
9739 error (_("Attempt to use a type name as an expression"));
9744 case OP_DISCRETE_RANGE
:
9747 if (noside
== EVAL_NORMAL
)
9751 error (_("Undefined name, ambiguous name, or renaming used in "
9752 "component association: %s."), &exp
->elts
[pc
+2].string
);
9754 error (_("Aggregates only allowed on the right of an assignment"));
9756 internal_error (__FILE__
, __LINE__
, _("aggregate apparently mangled"));
9759 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
9761 for (tem
= 0; tem
< nargs
; tem
+= 1)
9762 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9767 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
, 1);
9773 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9774 type name that encodes the 'small and 'delta information.
9775 Otherwise, return NULL. */
9778 fixed_type_info (struct type
*type
)
9780 const char *name
= ada_type_name (type
);
9781 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
9783 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
9785 const char *tail
= strstr (name
, "___XF_");
9792 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
9793 return fixed_type_info (TYPE_TARGET_TYPE (type
));
9798 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9801 ada_is_fixed_point_type (struct type
*type
)
9803 return fixed_type_info (type
) != NULL
;
9806 /* Return non-zero iff TYPE represents a System.Address type. */
9809 ada_is_system_address_type (struct type
*type
)
9811 return (TYPE_NAME (type
)
9812 && strcmp (TYPE_NAME (type
), "system__address") == 0);
9815 /* Assuming that TYPE is the representation of an Ada fixed-point
9816 type, return its delta, or -1 if the type is malformed and the
9817 delta cannot be determined. */
9820 ada_delta (struct type
*type
)
9822 const char *encoding
= fixed_type_info (type
);
9825 /* Strictly speaking, num and den are encoded as integer. However,
9826 they may not fit into a long, and they will have to be converted
9827 to DOUBLEST anyway. So scan them as DOUBLEST. */
9828 if (sscanf (encoding
, "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
,
9835 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9836 factor ('SMALL value) associated with the type. */
9839 scaling_factor (struct type
*type
)
9841 const char *encoding
= fixed_type_info (type
);
9842 DOUBLEST num0
, den0
, num1
, den1
;
9845 /* Strictly speaking, num's and den's are encoded as integer. However,
9846 they may not fit into a long, and they will have to be converted
9847 to DOUBLEST anyway. So scan them as DOUBLEST. */
9848 n
= sscanf (encoding
,
9849 "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
9850 "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
,
9851 &num0
, &den0
, &num1
, &den1
);
9862 /* Assuming that X is the representation of a value of fixed-point
9863 type TYPE, return its floating-point equivalent. */
9866 ada_fixed_to_float (struct type
*type
, LONGEST x
)
9868 return (DOUBLEST
) x
*scaling_factor (type
);
9871 /* The representation of a fixed-point value of type TYPE
9872 corresponding to the value X. */
9875 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
9877 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
9884 /* Scan STR beginning at position K for a discriminant name, and
9885 return the value of that discriminant field of DVAL in *PX. If
9886 PNEW_K is not null, put the position of the character beyond the
9887 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9888 not alter *PX and *PNEW_K if unsuccessful. */
9891 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
9894 static char *bound_buffer
= NULL
;
9895 static size_t bound_buffer_len
= 0;
9898 struct value
*bound_val
;
9900 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9903 pend
= strstr (str
+ k
, "__");
9907 k
+= strlen (bound
);
9911 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9912 bound
= bound_buffer
;
9913 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9914 bound
[pend
- (str
+ k
)] = '\0';
9918 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
9919 if (bound_val
== NULL
)
9922 *px
= value_as_long (bound_val
);
9928 /* Value of variable named NAME in the current environment. If
9929 no such variable found, then if ERR_MSG is null, returns 0, and
9930 otherwise causes an error with message ERR_MSG. */
9932 static struct value
*
9933 get_var_value (char *name
, char *err_msg
)
9935 struct ada_symbol_info
*syms
;
9938 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9943 if (err_msg
== NULL
)
9946 error (("%s"), err_msg
);
9949 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9952 /* Value of integer variable named NAME in the current environment. If
9953 no such variable found, returns 0, and sets *FLAG to 0. If
9954 successful, sets *FLAG to 1. */
9957 get_int_var_value (char *name
, int *flag
)
9959 struct value
*var_val
= get_var_value (name
, 0);
9971 return value_as_long (var_val
);
9976 /* Return a range type whose base type is that of the range type named
9977 NAME in the current environment, and whose bounds are calculated
9978 from NAME according to the GNAT range encoding conventions.
9979 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
9980 corresponding range type from debug information; fall back to using it
9981 if symbol lookup fails. If a new type must be created, allocate it
9982 like ORIG_TYPE was. The bounds information, in general, is encoded
9983 in NAME, the base type given in the named range type. */
9985 static struct type
*
9986 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
9989 struct type
*base_type
;
9992 gdb_assert (raw_type
!= NULL
);
9993 gdb_assert (TYPE_NAME (raw_type
) != NULL
);
9995 if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9996 base_type
= TYPE_TARGET_TYPE (raw_type
);
9998 base_type
= raw_type
;
10000 name
= TYPE_NAME (raw_type
);
10001 subtype_info
= strstr (name
, "___XD");
10002 if (subtype_info
== NULL
)
10004 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
10005 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
10007 if (L
< INT_MIN
|| U
> INT_MAX
)
10010 return create_range_type (alloc_type_copy (raw_type
), raw_type
,
10011 ada_discrete_type_low_bound (raw_type
),
10012 ada_discrete_type_high_bound (raw_type
));
10016 static char *name_buf
= NULL
;
10017 static size_t name_len
= 0;
10018 int prefix_len
= subtype_info
- name
;
10024 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
10025 strncpy (name_buf
, name
, prefix_len
);
10026 name_buf
[prefix_len
] = '\0';
10029 bounds_str
= strchr (subtype_info
, '_');
10032 if (*subtype_info
== 'L')
10034 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
10035 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
10037 if (bounds_str
[n
] == '_')
10039 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
10047 strcpy (name_buf
+ prefix_len
, "___L");
10048 L
= get_int_var_value (name_buf
, &ok
);
10051 lim_warning (_("Unknown lower bound, using 1."));
10056 if (*subtype_info
== 'U')
10058 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
10059 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
10066 strcpy (name_buf
+ prefix_len
, "___U");
10067 U
= get_int_var_value (name_buf
, &ok
);
10070 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
10075 type
= create_range_type (alloc_type_copy (raw_type
), base_type
, L
, U
);
10076 TYPE_NAME (type
) = name
;
10081 /* True iff NAME is the name of a range type. */
10084 ada_is_range_type_name (const char *name
)
10086 return (name
!= NULL
&& strstr (name
, "___XD"));
10090 /* Modular types */
10092 /* True iff TYPE is an Ada modular type. */
10095 ada_is_modular_type (struct type
*type
)
10097 struct type
*subranged_type
= base_type (type
);
10099 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
10100 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
10101 && TYPE_UNSIGNED (subranged_type
));
10104 /* Try to determine the lower and upper bounds of the given modular type
10105 using the type name only. Return non-zero and set L and U as the lower
10106 and upper bounds (respectively) if successful. */
10109 ada_modulus_from_name (struct type
*type
, ULONGEST
*modulus
)
10111 char *name
= ada_type_name (type
);
10119 /* Discrete type bounds are encoded using an __XD suffix. In our case,
10120 we are looking for static bounds, which means an __XDLU suffix.
10121 Moreover, we know that the lower bound of modular types is always
10122 zero, so the actual suffix should start with "__XDLU_0__", and
10123 then be followed by the upper bound value. */
10124 suffix
= strstr (name
, "__XDLU_0__");
10125 if (suffix
== NULL
)
10128 if (!ada_scan_number (suffix
, k
, &U
, NULL
))
10131 *modulus
= (ULONGEST
) U
+ 1;
10135 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
10138 ada_modulus (struct type
*type
)
10140 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
10144 /* Ada exception catchpoint support:
10145 ---------------------------------
10147 We support 3 kinds of exception catchpoints:
10148 . catchpoints on Ada exceptions
10149 . catchpoints on unhandled Ada exceptions
10150 . catchpoints on failed assertions
10152 Exceptions raised during failed assertions, or unhandled exceptions
10153 could perfectly be caught with the general catchpoint on Ada exceptions.
10154 However, we can easily differentiate these two special cases, and having
10155 the option to distinguish these two cases from the rest can be useful
10156 to zero-in on certain situations.
10158 Exception catchpoints are a specialized form of breakpoint,
10159 since they rely on inserting breakpoints inside known routines
10160 of the GNAT runtime. The implementation therefore uses a standard
10161 breakpoint structure of the BP_BREAKPOINT type, but with its own set
10164 Support in the runtime for exception catchpoints have been changed
10165 a few times already, and these changes affect the implementation
10166 of these catchpoints. In order to be able to support several
10167 variants of the runtime, we use a sniffer that will determine
10168 the runtime variant used by the program being debugged.
10170 At this time, we do not support the use of conditions on Ada exception
10171 catchpoints. The COND and COND_STRING fields are therefore set
10172 to NULL (most of the time, see below).
10174 Conditions where EXP_STRING, COND, and COND_STRING are used:
10176 When a user specifies the name of a specific exception in the case
10177 of catchpoints on Ada exceptions, we store the name of that exception
10178 in the EXP_STRING. We then translate this request into an actual
10179 condition stored in COND_STRING, and then parse it into an expression
10182 /* The different types of catchpoints that we introduced for catching
10185 enum exception_catchpoint_kind
10187 ex_catch_exception
,
10188 ex_catch_exception_unhandled
,
10192 /* Ada's standard exceptions. */
10194 static char *standard_exc
[] = {
10195 "constraint_error",
10201 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
10203 /* A structure that describes how to support exception catchpoints
10204 for a given executable. */
10206 struct exception_support_info
10208 /* The name of the symbol to break on in order to insert
10209 a catchpoint on exceptions. */
10210 const char *catch_exception_sym
;
10212 /* The name of the symbol to break on in order to insert
10213 a catchpoint on unhandled exceptions. */
10214 const char *catch_exception_unhandled_sym
;
10216 /* The name of the symbol to break on in order to insert
10217 a catchpoint on failed assertions. */
10218 const char *catch_assert_sym
;
10220 /* Assuming that the inferior just triggered an unhandled exception
10221 catchpoint, this function is responsible for returning the address
10222 in inferior memory where the name of that exception is stored.
10223 Return zero if the address could not be computed. */
10224 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
10227 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
10228 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
10230 /* The following exception support info structure describes how to
10231 implement exception catchpoints with the latest version of the
10232 Ada runtime (as of 2007-03-06). */
10234 static const struct exception_support_info default_exception_support_info
=
10236 "__gnat_debug_raise_exception", /* catch_exception_sym */
10237 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10238 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
10239 ada_unhandled_exception_name_addr
10242 /* The following exception support info structure describes how to
10243 implement exception catchpoints with a slightly older version
10244 of the Ada runtime. */
10246 static const struct exception_support_info exception_support_info_fallback
=
10248 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
10249 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10250 "system__assertions__raise_assert_failure", /* catch_assert_sym */
10251 ada_unhandled_exception_name_addr_from_raise
10254 /* For each executable, we sniff which exception info structure to use
10255 and cache it in the following global variable. */
10257 static const struct exception_support_info
*exception_info
= NULL
;
10259 /* Inspect the Ada runtime and determine which exception info structure
10260 should be used to provide support for exception catchpoints.
10262 This function will always set exception_info, or raise an error. */
10265 ada_exception_support_info_sniffer (void)
10267 struct symbol
*sym
;
10269 /* If the exception info is already known, then no need to recompute it. */
10270 if (exception_info
!= NULL
)
10273 /* Check the latest (default) exception support info. */
10274 sym
= standard_lookup (default_exception_support_info
.catch_exception_sym
,
10278 exception_info
= &default_exception_support_info
;
10282 /* Try our fallback exception suport info. */
10283 sym
= standard_lookup (exception_support_info_fallback
.catch_exception_sym
,
10287 exception_info
= &exception_support_info_fallback
;
10291 /* Sometimes, it is normal for us to not be able to find the routine
10292 we are looking for. This happens when the program is linked with
10293 the shared version of the GNAT runtime, and the program has not been
10294 started yet. Inform the user of these two possible causes if
10297 if (ada_update_initial_language (language_unknown
) != language_ada
)
10298 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
10300 /* If the symbol does not exist, then check that the program is
10301 already started, to make sure that shared libraries have been
10302 loaded. If it is not started, this may mean that the symbol is
10303 in a shared library. */
10305 if (ptid_get_pid (inferior_ptid
) == 0)
10306 error (_("Unable to insert catchpoint. Try to start the program first."));
10308 /* At this point, we know that we are debugging an Ada program and
10309 that the inferior has been started, but we still are not able to
10310 find the run-time symbols. That can mean that we are in
10311 configurable run time mode, or that a-except as been optimized
10312 out by the linker... In any case, at this point it is not worth
10313 supporting this feature. */
10315 error (_("Cannot insert catchpoints in this configuration."));
10318 /* An observer of "executable_changed" events.
10319 Its role is to clear certain cached values that need to be recomputed
10320 each time a new executable is loaded by GDB. */
10323 ada_executable_changed_observer (void)
10325 /* If the executable changed, then it is possible that the Ada runtime
10326 is different. So we need to invalidate the exception support info
10328 exception_info
= NULL
;
10331 /* True iff FRAME is very likely to be that of a function that is
10332 part of the runtime system. This is all very heuristic, but is
10333 intended to be used as advice as to what frames are uninteresting
10337 is_known_support_routine (struct frame_info
*frame
)
10339 struct symtab_and_line sal
;
10341 enum language func_lang
;
10344 /* If this code does not have any debugging information (no symtab),
10345 This cannot be any user code. */
10347 find_frame_sal (frame
, &sal
);
10348 if (sal
.symtab
== NULL
)
10351 /* If there is a symtab, but the associated source file cannot be
10352 located, then assume this is not user code: Selecting a frame
10353 for which we cannot display the code would not be very helpful
10354 for the user. This should also take care of case such as VxWorks
10355 where the kernel has some debugging info provided for a few units. */
10357 if (symtab_to_fullname (sal
.symtab
) == NULL
)
10360 /* Check the unit filename againt the Ada runtime file naming.
10361 We also check the name of the objfile against the name of some
10362 known system libraries that sometimes come with debugging info
10365 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
10367 re_comp (known_runtime_file_name_patterns
[i
]);
10368 if (re_exec (sal
.symtab
->filename
))
10370 if (sal
.symtab
->objfile
!= NULL
10371 && re_exec (sal
.symtab
->objfile
->name
))
10375 /* Check whether the function is a GNAT-generated entity. */
10377 find_frame_funname (frame
, &func_name
, &func_lang
, NULL
);
10378 if (func_name
== NULL
)
10381 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
10383 re_comp (known_auxiliary_function_name_patterns
[i
]);
10384 if (re_exec (func_name
))
10391 /* Find the first frame that contains debugging information and that is not
10392 part of the Ada run-time, starting from FI and moving upward. */
10395 ada_find_printable_frame (struct frame_info
*fi
)
10397 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
10399 if (!is_known_support_routine (fi
))
10408 /* Assuming that the inferior just triggered an unhandled exception
10409 catchpoint, return the address in inferior memory where the name
10410 of the exception is stored.
10412 Return zero if the address could not be computed. */
10415 ada_unhandled_exception_name_addr (void)
10417 return parse_and_eval_address ("e.full_name");
10420 /* Same as ada_unhandled_exception_name_addr, except that this function
10421 should be used when the inferior uses an older version of the runtime,
10422 where the exception name needs to be extracted from a specific frame
10423 several frames up in the callstack. */
10426 ada_unhandled_exception_name_addr_from_raise (void)
10429 struct frame_info
*fi
;
10431 /* To determine the name of this exception, we need to select
10432 the frame corresponding to RAISE_SYM_NAME. This frame is
10433 at least 3 levels up, so we simply skip the first 3 frames
10434 without checking the name of their associated function. */
10435 fi
= get_current_frame ();
10436 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
10438 fi
= get_prev_frame (fi
);
10443 enum language func_lang
;
10445 find_frame_funname (fi
, &func_name
, &func_lang
, NULL
);
10446 if (func_name
!= NULL
10447 && strcmp (func_name
, exception_info
->catch_exception_sym
) == 0)
10448 break; /* We found the frame we were looking for... */
10449 fi
= get_prev_frame (fi
);
10456 return parse_and_eval_address ("id.full_name");
10459 /* Assuming the inferior just triggered an Ada exception catchpoint
10460 (of any type), return the address in inferior memory where the name
10461 of the exception is stored, if applicable.
10463 Return zero if the address could not be computed, or if not relevant. */
10466 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex
,
10467 struct breakpoint
*b
)
10471 case ex_catch_exception
:
10472 return (parse_and_eval_address ("e.full_name"));
10475 case ex_catch_exception_unhandled
:
10476 return exception_info
->unhandled_exception_name_addr ();
10479 case ex_catch_assert
:
10480 return 0; /* Exception name is not relevant in this case. */
10484 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10488 return 0; /* Should never be reached. */
10491 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
10492 any error that ada_exception_name_addr_1 might cause to be thrown.
10493 When an error is intercepted, a warning with the error message is printed,
10494 and zero is returned. */
10497 ada_exception_name_addr (enum exception_catchpoint_kind ex
,
10498 struct breakpoint
*b
)
10500 struct gdb_exception e
;
10501 CORE_ADDR result
= 0;
10503 TRY_CATCH (e
, RETURN_MASK_ERROR
)
10505 result
= ada_exception_name_addr_1 (ex
, b
);
10510 warning (_("failed to get exception name: %s"), e
.message
);
10517 /* Implement the PRINT_IT method in the breakpoint_ops structure
10518 for all exception catchpoint kinds. */
10520 static enum print_stop_action
10521 print_it_exception (enum exception_catchpoint_kind ex
, struct breakpoint
*b
)
10523 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
10524 char exception_name
[256];
10528 read_memory (addr
, exception_name
, sizeof (exception_name
) - 1);
10529 exception_name
[sizeof (exception_name
) - 1] = '\0';
10532 ada_find_printable_frame (get_current_frame ());
10534 annotate_catchpoint (b
->number
);
10537 case ex_catch_exception
:
10539 printf_filtered (_("\nCatchpoint %d, %s at "),
10540 b
->number
, exception_name
);
10542 printf_filtered (_("\nCatchpoint %d, exception at "), b
->number
);
10544 case ex_catch_exception_unhandled
:
10546 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10547 b
->number
, exception_name
);
10549 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10552 case ex_catch_assert
:
10553 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10558 return PRINT_SRC_AND_LOC
;
10561 /* Implement the PRINT_ONE method in the breakpoint_ops structure
10562 for all exception catchpoint kinds. */
10565 print_one_exception (enum exception_catchpoint_kind ex
,
10566 struct breakpoint
*b
, struct bp_location
**last_loc
)
10568 struct value_print_options opts
;
10570 get_user_print_options (&opts
);
10571 if (opts
.addressprint
)
10573 annotate_field (4);
10574 ui_out_field_core_addr (uiout
, "addr", b
->loc
->gdbarch
, b
->loc
->address
);
10577 annotate_field (5);
10578 *last_loc
= b
->loc
;
10581 case ex_catch_exception
:
10582 if (b
->exp_string
!= NULL
)
10584 char *msg
= xstrprintf (_("`%s' Ada exception"), b
->exp_string
);
10586 ui_out_field_string (uiout
, "what", msg
);
10590 ui_out_field_string (uiout
, "what", "all Ada exceptions");
10594 case ex_catch_exception_unhandled
:
10595 ui_out_field_string (uiout
, "what", "unhandled Ada exceptions");
10598 case ex_catch_assert
:
10599 ui_out_field_string (uiout
, "what", "failed Ada assertions");
10603 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10608 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
10609 for all exception catchpoint kinds. */
10612 print_mention_exception (enum exception_catchpoint_kind ex
,
10613 struct breakpoint
*b
)
10617 case ex_catch_exception
:
10618 if (b
->exp_string
!= NULL
)
10619 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10620 b
->number
, b
->exp_string
);
10622 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b
->number
);
10626 case ex_catch_exception_unhandled
:
10627 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10631 case ex_catch_assert
:
10632 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b
->number
);
10636 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10641 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
10642 for all exception catchpoint kinds. */
10645 print_recreate_exception (enum exception_catchpoint_kind ex
,
10646 struct breakpoint
*b
, struct ui_file
*fp
)
10650 case ex_catch_exception
:
10651 fprintf_filtered (fp
, "catch exception");
10652 if (b
->exp_string
!= NULL
)
10653 fprintf_filtered (fp
, " %s", b
->exp_string
);
10656 case ex_catch_exception_unhandled
:
10657 fprintf_filtered (fp
, "catch exception unhandled");
10660 case ex_catch_assert
:
10661 fprintf_filtered (fp
, "catch assert");
10665 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10669 /* Virtual table for "catch exception" breakpoints. */
10671 static enum print_stop_action
10672 print_it_catch_exception (struct breakpoint
*b
)
10674 return print_it_exception (ex_catch_exception
, b
);
10678 print_one_catch_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
10680 print_one_exception (ex_catch_exception
, b
, last_loc
);
10684 print_mention_catch_exception (struct breakpoint
*b
)
10686 print_mention_exception (ex_catch_exception
, b
);
10690 print_recreate_catch_exception (struct breakpoint
*b
, struct ui_file
*fp
)
10692 print_recreate_exception (ex_catch_exception
, b
, fp
);
10695 static struct breakpoint_ops catch_exception_breakpoint_ops
=
10699 NULL
, /* breakpoint_hit */
10700 print_it_catch_exception
,
10701 print_one_catch_exception
,
10702 print_mention_catch_exception
,
10703 print_recreate_catch_exception
10706 /* Virtual table for "catch exception unhandled" breakpoints. */
10708 static enum print_stop_action
10709 print_it_catch_exception_unhandled (struct breakpoint
*b
)
10711 return print_it_exception (ex_catch_exception_unhandled
, b
);
10715 print_one_catch_exception_unhandled (struct breakpoint
*b
,
10716 struct bp_location
**last_loc
)
10718 print_one_exception (ex_catch_exception_unhandled
, b
, last_loc
);
10722 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
10724 print_mention_exception (ex_catch_exception_unhandled
, b
);
10728 print_recreate_catch_exception_unhandled (struct breakpoint
*b
,
10729 struct ui_file
*fp
)
10731 print_recreate_exception (ex_catch_exception_unhandled
, b
, fp
);
10734 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
= {
10737 NULL
, /* breakpoint_hit */
10738 print_it_catch_exception_unhandled
,
10739 print_one_catch_exception_unhandled
,
10740 print_mention_catch_exception_unhandled
,
10741 print_recreate_catch_exception_unhandled
10744 /* Virtual table for "catch assert" breakpoints. */
10746 static enum print_stop_action
10747 print_it_catch_assert (struct breakpoint
*b
)
10749 return print_it_exception (ex_catch_assert
, b
);
10753 print_one_catch_assert (struct breakpoint
*b
, struct bp_location
**last_loc
)
10755 print_one_exception (ex_catch_assert
, b
, last_loc
);
10759 print_mention_catch_assert (struct breakpoint
*b
)
10761 print_mention_exception (ex_catch_assert
, b
);
10765 print_recreate_catch_assert (struct breakpoint
*b
, struct ui_file
*fp
)
10767 print_recreate_exception (ex_catch_assert
, b
, fp
);
10770 static struct breakpoint_ops catch_assert_breakpoint_ops
= {
10773 NULL
, /* breakpoint_hit */
10774 print_it_catch_assert
,
10775 print_one_catch_assert
,
10776 print_mention_catch_assert
,
10777 print_recreate_catch_assert
10780 /* Return non-zero if B is an Ada exception catchpoint. */
10783 ada_exception_catchpoint_p (struct breakpoint
*b
)
10785 return (b
->ops
== &catch_exception_breakpoint_ops
10786 || b
->ops
== &catch_exception_unhandled_breakpoint_ops
10787 || b
->ops
== &catch_assert_breakpoint_ops
);
10790 /* Return a newly allocated copy of the first space-separated token
10791 in ARGSP, and then adjust ARGSP to point immediately after that
10794 Return NULL if ARGPS does not contain any more tokens. */
10797 ada_get_next_arg (char **argsp
)
10799 char *args
= *argsp
;
10803 /* Skip any leading white space. */
10805 while (isspace (*args
))
10808 if (args
[0] == '\0')
10809 return NULL
; /* No more arguments. */
10811 /* Find the end of the current argument. */
10814 while (*end
!= '\0' && !isspace (*end
))
10817 /* Adjust ARGSP to point to the start of the next argument. */
10821 /* Make a copy of the current argument and return it. */
10823 result
= xmalloc (end
- args
+ 1);
10824 strncpy (result
, args
, end
- args
);
10825 result
[end
- args
] = '\0';
10830 /* Split the arguments specified in a "catch exception" command.
10831 Set EX to the appropriate catchpoint type.
10832 Set EXP_STRING to the name of the specific exception if
10833 specified by the user. */
10836 catch_ada_exception_command_split (char *args
,
10837 enum exception_catchpoint_kind
*ex
,
10840 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
10841 char *exception_name
;
10843 exception_name
= ada_get_next_arg (&args
);
10844 make_cleanup (xfree
, exception_name
);
10846 /* Check that we do not have any more arguments. Anything else
10849 while (isspace (*args
))
10852 if (args
[0] != '\0')
10853 error (_("Junk at end of expression"));
10855 discard_cleanups (old_chain
);
10857 if (exception_name
== NULL
)
10859 /* Catch all exceptions. */
10860 *ex
= ex_catch_exception
;
10861 *exp_string
= NULL
;
10863 else if (strcmp (exception_name
, "unhandled") == 0)
10865 /* Catch unhandled exceptions. */
10866 *ex
= ex_catch_exception_unhandled
;
10867 *exp_string
= NULL
;
10871 /* Catch a specific exception. */
10872 *ex
= ex_catch_exception
;
10873 *exp_string
= exception_name
;
10877 /* Return the name of the symbol on which we should break in order to
10878 implement a catchpoint of the EX kind. */
10880 static const char *
10881 ada_exception_sym_name (enum exception_catchpoint_kind ex
)
10883 gdb_assert (exception_info
!= NULL
);
10887 case ex_catch_exception
:
10888 return (exception_info
->catch_exception_sym
);
10890 case ex_catch_exception_unhandled
:
10891 return (exception_info
->catch_exception_unhandled_sym
);
10893 case ex_catch_assert
:
10894 return (exception_info
->catch_assert_sym
);
10897 internal_error (__FILE__
, __LINE__
,
10898 _("unexpected catchpoint kind (%d)"), ex
);
10902 /* Return the breakpoint ops "virtual table" used for catchpoints
10905 static struct breakpoint_ops
*
10906 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex
)
10910 case ex_catch_exception
:
10911 return (&catch_exception_breakpoint_ops
);
10913 case ex_catch_exception_unhandled
:
10914 return (&catch_exception_unhandled_breakpoint_ops
);
10916 case ex_catch_assert
:
10917 return (&catch_assert_breakpoint_ops
);
10920 internal_error (__FILE__
, __LINE__
,
10921 _("unexpected catchpoint kind (%d)"), ex
);
10925 /* Return the condition that will be used to match the current exception
10926 being raised with the exception that the user wants to catch. This
10927 assumes that this condition is used when the inferior just triggered
10928 an exception catchpoint.
10930 The string returned is a newly allocated string that needs to be
10931 deallocated later. */
10934 ada_exception_catchpoint_cond_string (const char *exp_string
)
10938 /* The standard exceptions are a special case. They are defined in
10939 runtime units that have been compiled without debugging info; if
10940 EXP_STRING is the not-fully-qualified name of a standard
10941 exception (e.g. "constraint_error") then, during the evaluation
10942 of the condition expression, the symbol lookup on this name would
10943 *not* return this standard exception. The catchpoint condition
10944 may then be set only on user-defined exceptions which have the
10945 same not-fully-qualified name (e.g. my_package.constraint_error).
10947 To avoid this unexcepted behavior, these standard exceptions are
10948 systematically prefixed by "standard". This means that "catch
10949 exception constraint_error" is rewritten into "catch exception
10950 standard.constraint_error".
10952 If an exception named contraint_error is defined in another package of
10953 the inferior program, then the only way to specify this exception as a
10954 breakpoint condition is to use its fully-qualified named:
10955 e.g. my_package.constraint_error. */
10957 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
10959 if (strcmp (standard_exc
[i
], exp_string
) == 0)
10961 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
10965 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string
);
10968 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
10970 static struct expression
*
10971 ada_parse_catchpoint_condition (char *cond_string
,
10972 struct symtab_and_line sal
)
10974 return (parse_exp_1 (&cond_string
, block_for_pc (sal
.pc
), 0));
10977 /* Return the symtab_and_line that should be used to insert an exception
10978 catchpoint of the TYPE kind.
10980 EX_STRING should contain the name of a specific exception
10981 that the catchpoint should catch, or NULL otherwise.
10983 The idea behind all the remaining parameters is that their names match
10984 the name of certain fields in the breakpoint structure that are used to
10985 handle exception catchpoints. This function returns the value to which
10986 these fields should be set, depending on the type of catchpoint we need
10989 If COND and COND_STRING are both non-NULL, any value they might
10990 hold will be free'ed, and then replaced by newly allocated ones.
10991 These parameters are left untouched otherwise. */
10993 static struct symtab_and_line
10994 ada_exception_sal (enum exception_catchpoint_kind ex
, char *exp_string
,
10995 char **addr_string
, char **cond_string
,
10996 struct expression
**cond
, struct breakpoint_ops
**ops
)
10998 const char *sym_name
;
10999 struct symbol
*sym
;
11000 struct symtab_and_line sal
;
11002 /* First, find out which exception support info to use. */
11003 ada_exception_support_info_sniffer ();
11005 /* Then lookup the function on which we will break in order to catch
11006 the Ada exceptions requested by the user. */
11008 sym_name
= ada_exception_sym_name (ex
);
11009 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
11011 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11012 that should be compiled with debugging information. As a result, we
11013 expect to find that symbol in the symtabs. If we don't find it, then
11014 the target most likely does not support Ada exceptions, or we cannot
11015 insert exception breakpoints yet, because the GNAT runtime hasn't been
11018 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
11019 in such a way that no debugging information is produced for the symbol
11020 we are looking for. In this case, we could search the minimal symbols
11021 as a fall-back mechanism. This would still be operating in degraded
11022 mode, however, as we would still be missing the debugging information
11023 that is needed in order to extract the name of the exception being
11024 raised (this name is printed in the catchpoint message, and is also
11025 used when trying to catch a specific exception). We do not handle
11026 this case for now. */
11029 error (_("Unable to break on '%s' in this configuration."), sym_name
);
11031 /* Make sure that the symbol we found corresponds to a function. */
11032 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11033 error (_("Symbol \"%s\" is not a function (class = %d)"),
11034 sym_name
, SYMBOL_CLASS (sym
));
11036 sal
= find_function_start_sal (sym
, 1);
11038 /* Set ADDR_STRING. */
11040 *addr_string
= xstrdup (sym_name
);
11042 /* Set the COND and COND_STRING (if not NULL). */
11044 if (cond_string
!= NULL
&& cond
!= NULL
)
11046 if (*cond_string
!= NULL
)
11048 xfree (*cond_string
);
11049 *cond_string
= NULL
;
11056 if (exp_string
!= NULL
)
11058 *cond_string
= ada_exception_catchpoint_cond_string (exp_string
);
11059 *cond
= ada_parse_catchpoint_condition (*cond_string
, sal
);
11064 *ops
= ada_exception_breakpoint_ops (ex
);
11069 /* Parse the arguments (ARGS) of the "catch exception" command.
11071 Set TYPE to the appropriate exception catchpoint type.
11072 If the user asked the catchpoint to catch only a specific
11073 exception, then save the exception name in ADDR_STRING.
11075 See ada_exception_sal for a description of all the remaining
11076 function arguments of this function. */
11078 struct symtab_and_line
11079 ada_decode_exception_location (char *args
, char **addr_string
,
11080 char **exp_string
, char **cond_string
,
11081 struct expression
**cond
,
11082 struct breakpoint_ops
**ops
)
11084 enum exception_catchpoint_kind ex
;
11086 catch_ada_exception_command_split (args
, &ex
, exp_string
);
11087 return ada_exception_sal (ex
, *exp_string
, addr_string
, cond_string
,
11091 struct symtab_and_line
11092 ada_decode_assert_location (char *args
, char **addr_string
,
11093 struct breakpoint_ops
**ops
)
11095 /* Check that no argument where provided at the end of the command. */
11099 while (isspace (*args
))
11102 error (_("Junk at end of arguments."));
11105 return ada_exception_sal (ex_catch_assert
, NULL
, addr_string
, NULL
, NULL
,
11110 /* Information about operators given special treatment in functions
11112 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
11114 #define ADA_OPERATORS \
11115 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
11116 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
11117 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
11118 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
11119 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
11120 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
11121 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
11122 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
11123 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
11124 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
11125 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
11126 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
11127 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
11128 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
11129 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
11130 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
11131 OP_DEFN (OP_OTHERS, 1, 1, 0) \
11132 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
11133 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
11136 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
11139 switch (exp
->elts
[pc
- 1].opcode
)
11142 operator_length_standard (exp
, pc
, oplenp
, argsp
);
11145 #define OP_DEFN(op, len, args, binop) \
11146 case op: *oplenp = len; *argsp = args; break;
11152 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
11157 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
11162 /* Implementation of the exp_descriptor method operator_check. */
11165 ada_operator_check (struct expression
*exp
, int pos
,
11166 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
11169 const union exp_element
*const elts
= exp
->elts
;
11170 struct type
*type
= NULL
;
11172 switch (elts
[pos
].opcode
)
11174 case UNOP_IN_RANGE
:
11176 type
= elts
[pos
+ 1].type
;
11180 return operator_check_standard (exp
, pos
, objfile_func
, data
);
11183 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
11185 if (type
&& TYPE_OBJFILE (type
)
11186 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
11193 ada_op_name (enum exp_opcode opcode
)
11198 return op_name_standard (opcode
);
11200 #define OP_DEFN(op, len, args, binop) case op: return #op;
11205 return "OP_AGGREGATE";
11207 return "OP_CHOICES";
11213 /* As for operator_length, but assumes PC is pointing at the first
11214 element of the operator, and gives meaningful results only for the
11215 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
11218 ada_forward_operator_length (struct expression
*exp
, int pc
,
11219 int *oplenp
, int *argsp
)
11221 switch (exp
->elts
[pc
].opcode
)
11224 *oplenp
= *argsp
= 0;
11227 #define OP_DEFN(op, len, args, binop) \
11228 case op: *oplenp = len; *argsp = args; break;
11234 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11239 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
11245 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11247 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
11255 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
11257 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
11262 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
11266 /* Ada attributes ('Foo). */
11269 case OP_ATR_LENGTH
:
11273 case OP_ATR_MODULUS
:
11280 case UNOP_IN_RANGE
:
11282 /* XXX: gdb_sprint_host_address, type_sprint */
11283 fprintf_filtered (stream
, _("Type @"));
11284 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
11285 fprintf_filtered (stream
, " (");
11286 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
11287 fprintf_filtered (stream
, ")");
11289 case BINOP_IN_BOUNDS
:
11290 fprintf_filtered (stream
, " (%d)",
11291 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
11293 case TERNOP_IN_RANGE
:
11298 case OP_DISCRETE_RANGE
:
11299 case OP_POSITIONAL
:
11306 char *name
= &exp
->elts
[elt
+ 2].string
;
11307 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
11309 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
11314 return dump_subexp_body_standard (exp
, stream
, elt
);
11318 for (i
= 0; i
< nargs
; i
+= 1)
11319 elt
= dump_subexp (exp
, stream
, elt
);
11324 /* The Ada extension of print_subexp (q.v.). */
11327 ada_print_subexp (struct expression
*exp
, int *pos
,
11328 struct ui_file
*stream
, enum precedence prec
)
11330 int oplen
, nargs
, i
;
11332 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
11334 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11341 print_subexp_standard (exp
, pos
, stream
, prec
);
11345 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
11348 case BINOP_IN_BOUNDS
:
11349 /* XXX: sprint_subexp */
11350 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11351 fputs_filtered (" in ", stream
);
11352 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11353 fputs_filtered ("'range", stream
);
11354 if (exp
->elts
[pc
+ 1].longconst
> 1)
11355 fprintf_filtered (stream
, "(%ld)",
11356 (long) exp
->elts
[pc
+ 1].longconst
);
11359 case TERNOP_IN_RANGE
:
11360 if (prec
>= PREC_EQUAL
)
11361 fputs_filtered ("(", stream
);
11362 /* XXX: sprint_subexp */
11363 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11364 fputs_filtered (" in ", stream
);
11365 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
11366 fputs_filtered (" .. ", stream
);
11367 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
11368 if (prec
>= PREC_EQUAL
)
11369 fputs_filtered (")", stream
);
11374 case OP_ATR_LENGTH
:
11378 case OP_ATR_MODULUS
:
11383 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
11385 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
11386 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
11390 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11391 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
11396 for (tem
= 1; tem
< nargs
; tem
+= 1)
11398 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
11399 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
11401 fputs_filtered (")", stream
);
11406 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
11407 fputs_filtered ("'(", stream
);
11408 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
11409 fputs_filtered (")", stream
);
11412 case UNOP_IN_RANGE
:
11413 /* XXX: sprint_subexp */
11414 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11415 fputs_filtered (" in ", stream
);
11416 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
11419 case OP_DISCRETE_RANGE
:
11420 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11421 fputs_filtered ("..", stream
);
11422 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11426 fputs_filtered ("others => ", stream
);
11427 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11431 for (i
= 0; i
< nargs
-1; i
+= 1)
11434 fputs_filtered ("|", stream
);
11435 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11437 fputs_filtered (" => ", stream
);
11438 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11441 case OP_POSITIONAL
:
11442 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11446 fputs_filtered ("(", stream
);
11447 for (i
= 0; i
< nargs
; i
+= 1)
11450 fputs_filtered (", ", stream
);
11451 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11453 fputs_filtered (")", stream
);
11458 /* Table mapping opcodes into strings for printing operators
11459 and precedences of the operators. */
11461 static const struct op_print ada_op_print_tab
[] = {
11462 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
11463 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
11464 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
11465 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
11466 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
11467 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
11468 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
11469 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
11470 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
11471 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
11472 {">", BINOP_GTR
, PREC_ORDER
, 0},
11473 {"<", BINOP_LESS
, PREC_ORDER
, 0},
11474 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
11475 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
11476 {"+", BINOP_ADD
, PREC_ADD
, 0},
11477 {"-", BINOP_SUB
, PREC_ADD
, 0},
11478 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
11479 {"*", BINOP_MUL
, PREC_MUL
, 0},
11480 {"/", BINOP_DIV
, PREC_MUL
, 0},
11481 {"rem", BINOP_REM
, PREC_MUL
, 0},
11482 {"mod", BINOP_MOD
, PREC_MUL
, 0},
11483 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
11484 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
11485 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
11486 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
11487 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
11488 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
11489 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
11490 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
11491 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
11492 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
11496 enum ada_primitive_types
{
11497 ada_primitive_type_int
,
11498 ada_primitive_type_long
,
11499 ada_primitive_type_short
,
11500 ada_primitive_type_char
,
11501 ada_primitive_type_float
,
11502 ada_primitive_type_double
,
11503 ada_primitive_type_void
,
11504 ada_primitive_type_long_long
,
11505 ada_primitive_type_long_double
,
11506 ada_primitive_type_natural
,
11507 ada_primitive_type_positive
,
11508 ada_primitive_type_system_address
,
11509 nr_ada_primitive_types
11513 ada_language_arch_info (struct gdbarch
*gdbarch
,
11514 struct language_arch_info
*lai
)
11516 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
11518 lai
->primitive_type_vector
11519 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
11522 lai
->primitive_type_vector
[ada_primitive_type_int
]
11523 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
11525 lai
->primitive_type_vector
[ada_primitive_type_long
]
11526 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
11527 0, "long_integer");
11528 lai
->primitive_type_vector
[ada_primitive_type_short
]
11529 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
11530 0, "short_integer");
11531 lai
->string_char_type
11532 = lai
->primitive_type_vector
[ada_primitive_type_char
]
11533 = arch_integer_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
11534 lai
->primitive_type_vector
[ada_primitive_type_float
]
11535 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
11537 lai
->primitive_type_vector
[ada_primitive_type_double
]
11538 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
11539 "long_float", NULL
);
11540 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
11541 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
11542 0, "long_long_integer");
11543 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
11544 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
11545 "long_long_float", NULL
);
11546 lai
->primitive_type_vector
[ada_primitive_type_natural
]
11547 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
11549 lai
->primitive_type_vector
[ada_primitive_type_positive
]
11550 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
11552 lai
->primitive_type_vector
[ada_primitive_type_void
]
11553 = builtin
->builtin_void
;
11555 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
11556 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, 1, "void"));
11557 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
11558 = "system__address";
11560 lai
->bool_type_symbol
= NULL
;
11561 lai
->bool_type_default
= builtin
->builtin_bool
;
11564 /* Language vector */
11566 /* Not really used, but needed in the ada_language_defn. */
11569 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
11571 ada_emit_char (c
, type
, stream
, quoter
, 1);
11577 warnings_issued
= 0;
11578 return ada_parse ();
11581 static const struct exp_descriptor ada_exp_descriptor
= {
11583 ada_operator_length
,
11584 ada_operator_check
,
11586 ada_dump_subexp_body
,
11587 ada_evaluate_subexp
11590 const struct language_defn ada_language_defn
= {
11591 "ada", /* Language name */
11595 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
11596 that's not quite what this means. */
11598 macro_expansion_no
,
11599 &ada_exp_descriptor
,
11603 ada_printchar
, /* Print a character constant */
11604 ada_printstr
, /* Function to print string constant */
11605 emit_char
, /* Function to print single char (not used) */
11606 ada_print_type
, /* Print a type using appropriate syntax */
11607 ada_print_typedef
, /* Print a typedef using appropriate syntax */
11608 ada_val_print
, /* Print a value using appropriate syntax */
11609 ada_value_print
, /* Print a top-level value */
11610 NULL
, /* Language specific skip_trampoline */
11611 NULL
, /* name_of_this */
11612 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
11613 basic_lookup_transparent_type
, /* lookup_transparent_type */
11614 ada_la_decode
, /* Language specific symbol demangler */
11615 NULL
, /* Language specific class_name_from_physname */
11616 ada_op_print_tab
, /* expression operators for printing */
11617 0, /* c-style arrays */
11618 1, /* String lower bound */
11619 ada_get_gdb_completer_word_break_characters
,
11620 ada_make_symbol_completion_list
,
11621 ada_language_arch_info
,
11622 ada_print_array_index
,
11623 default_pass_by_reference
,
11628 /* Provide a prototype to silence -Wmissing-prototypes. */
11629 extern initialize_file_ftype _initialize_ada_language
;
11631 /* Command-list for the "set/show ada" prefix command. */
11632 static struct cmd_list_element
*set_ada_list
;
11633 static struct cmd_list_element
*show_ada_list
;
11635 /* Implement the "set ada" prefix command. */
11638 set_ada_command (char *arg
, int from_tty
)
11640 printf_unfiltered (_(\
11641 "\"set ada\" must be followed by the name of a setting.\n"));
11642 help_list (set_ada_list
, "set ada ", -1, gdb_stdout
);
11645 /* Implement the "show ada" prefix command. */
11648 show_ada_command (char *args
, int from_tty
)
11650 cmd_show_list (show_ada_list
, from_tty
, "");
11654 _initialize_ada_language (void)
11656 add_language (&ada_language_defn
);
11658 add_prefix_cmd ("ada", no_class
, set_ada_command
,
11659 _("Prefix command for changing Ada-specfic settings"),
11660 &set_ada_list
, "set ada ", 0, &setlist
);
11662 add_prefix_cmd ("ada", no_class
, show_ada_command
,
11663 _("Generic command for showing Ada-specific settings."),
11664 &show_ada_list
, "show ada ", 0, &showlist
);
11666 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
11667 &trust_pad_over_xvs
, _("\
11668 Enable or disable an optimization trusting PAD types over XVS types"), _("\
11669 Show whether an optimization trusting PAD types over XVS types is activated"),
11671 This is related to the encoding used by the GNAT compiler. The debugger\n\
11672 should normally trust the contents of PAD types, but certain older versions\n\
11673 of GNAT have a bug that sometimes causes the information in the PAD type\n\
11674 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
11675 work around this bug. It is always safe to turn this option \"off\", but\n\
11676 this incurs a slight performance penalty, so it is recommended to NOT change\n\
11677 this option to \"off\" unless necessary."),
11678 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
11680 varsize_limit
= 65536;
11682 obstack_init (&symbol_list_obstack
);
11684 decoded_names_store
= htab_create_alloc
11685 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
11686 NULL
, xcalloc
, xfree
);
11688 observer_attach_executable_changed (ada_executable_changed_observer
);
11690 /* Setup per-inferior data. */
11691 observer_attach_inferior_exit (ada_inferior_exit
);
11693 = register_inferior_data_with_cleanup (ada_inferior_data_cleanup
);