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"
63 #include "mi/mi-common.h"
64 #include "arch-utils.h"
65 #include "exceptions.h"
67 /* Define whether or not the C operator '/' truncates towards zero for
68 differently signed operands (truncation direction is undefined in C).
69 Copied from valarith.c. */
71 #ifndef TRUNCATION_TOWARDS_ZERO
72 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
75 static struct type
*desc_base_type (struct type
*);
77 static struct type
*desc_bounds_type (struct type
*);
79 static struct value
*desc_bounds (struct value
*);
81 static int fat_pntr_bounds_bitpos (struct type
*);
83 static int fat_pntr_bounds_bitsize (struct type
*);
85 static struct type
*desc_data_target_type (struct type
*);
87 static struct value
*desc_data (struct value
*);
89 static int fat_pntr_data_bitpos (struct type
*);
91 static int fat_pntr_data_bitsize (struct type
*);
93 static struct value
*desc_one_bound (struct value
*, int, int);
95 static int desc_bound_bitpos (struct type
*, int, int);
97 static int desc_bound_bitsize (struct type
*, int, int);
99 static struct type
*desc_index_type (struct type
*, int);
101 static int desc_arity (struct type
*);
103 static int ada_type_match (struct type
*, struct type
*, int);
105 static int ada_args_match (struct symbol
*, struct value
**, int);
107 static int full_match (const char *, const char *);
109 static struct value
*make_array_descriptor (struct type
*, struct value
*);
111 static void ada_add_block_symbols (struct obstack
*,
112 struct block
*, const char *,
113 domain_enum
, struct objfile
*, int);
115 static int is_nonfunction (struct ada_symbol_info
*, int);
117 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
120 static int num_defns_collected (struct obstack
*);
122 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
124 static struct value
*resolve_subexp (struct expression
**, int *, int,
127 static void replace_operator_with_call (struct expression
**, int, int, int,
128 struct symbol
*, struct block
*);
130 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
132 static char *ada_op_name (enum exp_opcode
);
134 static const char *ada_decoded_op_name (enum exp_opcode
);
136 static int numeric_type_p (struct type
*);
138 static int integer_type_p (struct type
*);
140 static int scalar_type_p (struct type
*);
142 static int discrete_type_p (struct type
*);
144 static enum ada_renaming_category
parse_old_style_renaming (struct type
*,
149 static struct symbol
*find_old_style_renaming_symbol (const char *,
152 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
155 static struct value
*evaluate_subexp_type (struct expression
*, int *);
157 static struct type
*ada_find_parallel_type_with_name (struct type
*,
160 static int is_dynamic_field (struct type
*, int);
162 static struct type
*to_fixed_variant_branch_type (struct type
*,
164 CORE_ADDR
, struct value
*);
166 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
168 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
170 static struct type
*to_static_fixed_type (struct type
*);
171 static struct type
*static_unwrap_type (struct type
*type
);
173 static struct value
*unwrap_value (struct value
*);
175 static struct type
*constrained_packed_array_type (struct type
*, long *);
177 static struct type
*decode_constrained_packed_array_type (struct type
*);
179 static long decode_packed_array_bitsize (struct type
*);
181 static struct value
*decode_constrained_packed_array (struct value
*);
183 static int ada_is_packed_array_type (struct type
*);
185 static int ada_is_unconstrained_packed_array_type (struct type
*);
187 static struct value
*value_subscript_packed (struct value
*, int,
190 static void move_bits (gdb_byte
*, int, const gdb_byte
*, int, int, int);
192 static struct value
*coerce_unspec_val_to_type (struct value
*,
195 static struct value
*get_var_value (char *, char *);
197 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
199 static int equiv_types (struct type
*, struct type
*);
201 static int is_name_suffix (const char *);
203 static int advance_wild_match (const char **, const char *, int);
205 static int wild_match (const char *, const char *);
207 static struct value
*ada_coerce_ref (struct value
*);
209 static LONGEST
pos_atr (struct value
*);
211 static struct value
*value_pos_atr (struct type
*, struct value
*);
213 static struct value
*value_val_atr (struct type
*, struct value
*);
215 static struct symbol
*standard_lookup (const char *, const struct block
*,
218 static struct value
*ada_search_struct_field (char *, struct value
*, int,
221 static struct value
*ada_value_primitive_field (struct value
*, int, int,
224 static int find_struct_field (char *, struct type
*, int,
225 struct type
**, int *, int *, int *, int *);
227 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
230 static int ada_resolve_function (struct ada_symbol_info
*, int,
231 struct value
**, int, const char *,
234 static int ada_is_direct_array_type (struct type
*);
236 static void ada_language_arch_info (struct gdbarch
*,
237 struct language_arch_info
*);
239 static void check_size (const struct type
*);
241 static struct value
*ada_index_struct_field (int, struct value
*, int,
244 static struct value
*assign_aggregate (struct value
*, struct value
*,
248 static void aggregate_assign_from_choices (struct value
*, struct value
*,
250 int *, LONGEST
*, int *,
251 int, LONGEST
, LONGEST
);
253 static void aggregate_assign_positional (struct value
*, struct value
*,
255 int *, LONGEST
*, int *, int,
259 static void aggregate_assign_others (struct value
*, struct value
*,
261 int *, LONGEST
*, int, LONGEST
, LONGEST
);
264 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
267 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
270 static void ada_forward_operator_length (struct expression
*, int, int *,
275 /* Maximum-sized dynamic type. */
276 static unsigned int varsize_limit
;
278 /* FIXME: brobecker/2003-09-17: No longer a const because it is
279 returned by a function that does not return a const char *. */
280 static char *ada_completer_word_break_characters
=
282 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
284 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
287 /* The name of the symbol to use to get the name of the main subprogram. */
288 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
289 = "__gnat_ada_main_program_name";
291 /* Limit on the number of warnings to raise per expression evaluation. */
292 static int warning_limit
= 2;
294 /* Number of warning messages issued; reset to 0 by cleanups after
295 expression evaluation. */
296 static int warnings_issued
= 0;
298 static const char *known_runtime_file_name_patterns
[] = {
299 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
302 static const char *known_auxiliary_function_name_patterns
[] = {
303 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
306 /* Space for allocating results of ada_lookup_symbol_list. */
307 static struct obstack symbol_list_obstack
;
309 /* Inferior-specific data. */
311 /* Per-inferior data for this module. */
313 struct ada_inferior_data
315 /* The ada__tags__type_specific_data type, which is used when decoding
316 tagged types. With older versions of GNAT, this type was directly
317 accessible through a component ("tsd") in the object tag. But this
318 is no longer the case, so we cache it for each inferior. */
319 struct type
*tsd_type
;
322 /* Our key to this module's inferior data. */
323 static const struct inferior_data
*ada_inferior_data
;
325 /* A cleanup routine for our inferior data. */
327 ada_inferior_data_cleanup (struct inferior
*inf
, void *arg
)
329 struct ada_inferior_data
*data
;
331 data
= inferior_data (inf
, ada_inferior_data
);
336 /* Return our inferior data for the given inferior (INF).
338 This function always returns a valid pointer to an allocated
339 ada_inferior_data structure. If INF's inferior data has not
340 been previously set, this functions creates a new one with all
341 fields set to zero, sets INF's inferior to it, and then returns
342 a pointer to that newly allocated ada_inferior_data. */
344 static struct ada_inferior_data
*
345 get_ada_inferior_data (struct inferior
*inf
)
347 struct ada_inferior_data
*data
;
349 data
= inferior_data (inf
, ada_inferior_data
);
352 data
= XZALLOC (struct ada_inferior_data
);
353 set_inferior_data (inf
, ada_inferior_data
, data
);
359 /* Perform all necessary cleanups regarding our module's inferior data
360 that is required after the inferior INF just exited. */
363 ada_inferior_exit (struct inferior
*inf
)
365 ada_inferior_data_cleanup (inf
, NULL
);
366 set_inferior_data (inf
, ada_inferior_data
, NULL
);
371 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
372 all typedef layers have been peeled. Otherwise, return TYPE.
374 Normally, we really expect a typedef type to only have 1 typedef layer.
375 In other words, we really expect the target type of a typedef type to be
376 a non-typedef type. This is particularly true for Ada units, because
377 the language does not have a typedef vs not-typedef distinction.
378 In that respect, the Ada compiler has been trying to eliminate as many
379 typedef definitions in the debugging information, since they generally
380 do not bring any extra information (we still use typedef under certain
381 circumstances related mostly to the GNAT encoding).
383 Unfortunately, we have seen situations where the debugging information
384 generated by the compiler leads to such multiple typedef layers. For
385 instance, consider the following example with stabs:
387 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
388 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
390 This is an error in the debugging information which causes type
391 pck__float_array___XUP to be defined twice, and the second time,
392 it is defined as a typedef of a typedef.
394 This is on the fringe of legality as far as debugging information is
395 concerned, and certainly unexpected. But it is easy to handle these
396 situations correctly, so we can afford to be lenient in this case. */
399 ada_typedef_target_type (struct type
*type
)
401 while (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
402 type
= TYPE_TARGET_TYPE (type
);
406 /* Given DECODED_NAME a string holding a symbol name in its
407 decoded form (ie using the Ada dotted notation), returns
408 its unqualified name. */
411 ada_unqualified_name (const char *decoded_name
)
413 const char *result
= strrchr (decoded_name
, '.');
416 result
++; /* Skip the dot... */
418 result
= decoded_name
;
423 /* Return a string starting with '<', followed by STR, and '>'.
424 The result is good until the next call. */
427 add_angle_brackets (const char *str
)
429 static char *result
= NULL
;
432 result
= xstrprintf ("<%s>", str
);
437 ada_get_gdb_completer_word_break_characters (void)
439 return ada_completer_word_break_characters
;
442 /* Print an array element index using the Ada syntax. */
445 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
446 const struct value_print_options
*options
)
448 LA_VALUE_PRINT (index_value
, stream
, options
);
449 fprintf_filtered (stream
, " => ");
452 /* Assuming VECT points to an array of *SIZE objects of size
453 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
454 updating *SIZE as necessary and returning the (new) array. */
457 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
459 if (*size
< min_size
)
462 if (*size
< min_size
)
464 vect
= xrealloc (vect
, *size
* element_size
);
469 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
470 suffix of FIELD_NAME beginning "___". */
473 field_name_match (const char *field_name
, const char *target
)
475 int len
= strlen (target
);
478 (strncmp (field_name
, target
, len
) == 0
479 && (field_name
[len
] == '\0'
480 || (strncmp (field_name
+ len
, "___", 3) == 0
481 && strcmp (field_name
+ strlen (field_name
) - 6,
486 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
487 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
488 and return its index. This function also handles fields whose name
489 have ___ suffixes because the compiler sometimes alters their name
490 by adding such a suffix to represent fields with certain constraints.
491 If the field could not be found, return a negative number if
492 MAYBE_MISSING is set. Otherwise raise an error. */
495 ada_get_field_index (const struct type
*type
, const char *field_name
,
499 struct type
*struct_type
= check_typedef ((struct type
*) type
);
501 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (struct_type
); fieldno
++)
502 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
506 error (_("Unable to find field %s in struct %s. Aborting"),
507 field_name
, TYPE_NAME (struct_type
));
512 /* The length of the prefix of NAME prior to any "___" suffix. */
515 ada_name_prefix_len (const char *name
)
521 const char *p
= strstr (name
, "___");
524 return strlen (name
);
530 /* Return non-zero if SUFFIX is a suffix of STR.
531 Return zero if STR is null. */
534 is_suffix (const char *str
, const char *suffix
)
541 len2
= strlen (suffix
);
542 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
545 /* The contents of value VAL, treated as a value of type TYPE. The
546 result is an lval in memory if VAL is. */
548 static struct value
*
549 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
551 type
= ada_check_typedef (type
);
552 if (value_type (val
) == type
)
556 struct value
*result
;
558 /* Make sure that the object size is not unreasonable before
559 trying to allocate some memory for it. */
563 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
564 result
= allocate_value_lazy (type
);
567 result
= allocate_value (type
);
568 memcpy (value_contents_raw (result
), value_contents (val
),
571 set_value_component_location (result
, val
);
572 set_value_bitsize (result
, value_bitsize (val
));
573 set_value_bitpos (result
, value_bitpos (val
));
574 set_value_address (result
, value_address (val
));
579 static const gdb_byte
*
580 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
585 return valaddr
+ offset
;
589 cond_offset_target (CORE_ADDR address
, long offset
)
594 return address
+ offset
;
597 /* Issue a warning (as for the definition of warning in utils.c, but
598 with exactly one argument rather than ...), unless the limit on the
599 number of warnings has passed during the evaluation of the current
602 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
603 provided by "complaint". */
604 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
607 lim_warning (const char *format
, ...)
611 va_start (args
, format
);
612 warnings_issued
+= 1;
613 if (warnings_issued
<= warning_limit
)
614 vwarning (format
, args
);
619 /* Issue an error if the size of an object of type T is unreasonable,
620 i.e. if it would be a bad idea to allocate a value of this type in
624 check_size (const struct type
*type
)
626 if (TYPE_LENGTH (type
) > varsize_limit
)
627 error (_("object size is larger than varsize-limit"));
630 /* Maximum value of a SIZE-byte signed integer type. */
632 max_of_size (int size
)
634 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
636 return top_bit
| (top_bit
- 1);
639 /* Minimum value of a SIZE-byte signed integer type. */
641 min_of_size (int size
)
643 return -max_of_size (size
) - 1;
646 /* Maximum value of a SIZE-byte unsigned integer type. */
648 umax_of_size (int size
)
650 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
652 return top_bit
| (top_bit
- 1);
655 /* Maximum value of integral type T, as a signed quantity. */
657 max_of_type (struct type
*t
)
659 if (TYPE_UNSIGNED (t
))
660 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
662 return max_of_size (TYPE_LENGTH (t
));
665 /* Minimum value of integral type T, as a signed quantity. */
667 min_of_type (struct type
*t
)
669 if (TYPE_UNSIGNED (t
))
672 return min_of_size (TYPE_LENGTH (t
));
675 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
677 ada_discrete_type_high_bound (struct type
*type
)
679 switch (TYPE_CODE (type
))
681 case TYPE_CODE_RANGE
:
682 return TYPE_HIGH_BOUND (type
);
684 return TYPE_FIELD_BITPOS (type
, TYPE_NFIELDS (type
) - 1);
689 return max_of_type (type
);
691 error (_("Unexpected type in ada_discrete_type_high_bound."));
695 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
697 ada_discrete_type_low_bound (struct type
*type
)
699 switch (TYPE_CODE (type
))
701 case TYPE_CODE_RANGE
:
702 return TYPE_LOW_BOUND (type
);
704 return TYPE_FIELD_BITPOS (type
, 0);
709 return min_of_type (type
);
711 error (_("Unexpected type in ada_discrete_type_low_bound."));
715 /* The identity on non-range types. For range types, the underlying
716 non-range scalar type. */
719 base_type (struct type
*type
)
721 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
723 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
725 type
= TYPE_TARGET_TYPE (type
);
731 /* Language Selection */
733 /* If the main program is in Ada, return language_ada, otherwise return LANG
734 (the main program is in Ada iif the adainit symbol is found). */
737 ada_update_initial_language (enum language lang
)
739 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
740 (struct objfile
*) NULL
) != NULL
)
746 /* If the main procedure is written in Ada, then return its name.
747 The result is good until the next call. Return NULL if the main
748 procedure doesn't appear to be in Ada. */
753 struct minimal_symbol
*msym
;
754 static char *main_program_name
= NULL
;
756 /* For Ada, the name of the main procedure is stored in a specific
757 string constant, generated by the binder. Look for that symbol,
758 extract its address, and then read that string. If we didn't find
759 that string, then most probably the main procedure is not written
761 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
765 CORE_ADDR main_program_name_addr
;
768 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
769 if (main_program_name_addr
== 0)
770 error (_("Invalid address for Ada main program name."));
772 xfree (main_program_name
);
773 target_read_string (main_program_name_addr
, &main_program_name
,
778 return main_program_name
;
781 /* The main procedure doesn't seem to be in Ada. */
787 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
790 const struct ada_opname_map ada_opname_table
[] = {
791 {"Oadd", "\"+\"", BINOP_ADD
},
792 {"Osubtract", "\"-\"", BINOP_SUB
},
793 {"Omultiply", "\"*\"", BINOP_MUL
},
794 {"Odivide", "\"/\"", BINOP_DIV
},
795 {"Omod", "\"mod\"", BINOP_MOD
},
796 {"Orem", "\"rem\"", BINOP_REM
},
797 {"Oexpon", "\"**\"", BINOP_EXP
},
798 {"Olt", "\"<\"", BINOP_LESS
},
799 {"Ole", "\"<=\"", BINOP_LEQ
},
800 {"Ogt", "\">\"", BINOP_GTR
},
801 {"Oge", "\">=\"", BINOP_GEQ
},
802 {"Oeq", "\"=\"", BINOP_EQUAL
},
803 {"One", "\"/=\"", BINOP_NOTEQUAL
},
804 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
805 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
806 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
807 {"Oconcat", "\"&\"", BINOP_CONCAT
},
808 {"Oabs", "\"abs\"", UNOP_ABS
},
809 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
810 {"Oadd", "\"+\"", UNOP_PLUS
},
811 {"Osubtract", "\"-\"", UNOP_NEG
},
815 /* The "encoded" form of DECODED, according to GNAT conventions.
816 The result is valid until the next call to ada_encode. */
819 ada_encode (const char *decoded
)
821 static char *encoding_buffer
= NULL
;
822 static size_t encoding_buffer_size
= 0;
829 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
830 2 * strlen (decoded
) + 10);
833 for (p
= decoded
; *p
!= '\0'; p
+= 1)
837 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
842 const struct ada_opname_map
*mapping
;
844 for (mapping
= ada_opname_table
;
845 mapping
->encoded
!= NULL
846 && strncmp (mapping
->decoded
, p
,
847 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
849 if (mapping
->encoded
== NULL
)
850 error (_("invalid Ada operator name: %s"), p
);
851 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
852 k
+= strlen (mapping
->encoded
);
857 encoding_buffer
[k
] = *p
;
862 encoding_buffer
[k
] = '\0';
863 return encoding_buffer
;
866 /* Return NAME folded to lower case, or, if surrounded by single
867 quotes, unfolded, but with the quotes stripped away. Result good
871 ada_fold_name (const char *name
)
873 static char *fold_buffer
= NULL
;
874 static size_t fold_buffer_size
= 0;
876 int len
= strlen (name
);
877 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
881 strncpy (fold_buffer
, name
+ 1, len
- 2);
882 fold_buffer
[len
- 2] = '\000';
888 for (i
= 0; i
<= len
; i
+= 1)
889 fold_buffer
[i
] = tolower (name
[i
]);
895 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
898 is_lower_alphanum (const char c
)
900 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
903 /* Remove either of these suffixes:
908 These are suffixes introduced by the compiler for entities such as
909 nested subprogram for instance, in order to avoid name clashes.
910 They do not serve any purpose for the debugger. */
913 ada_remove_trailing_digits (const char *encoded
, int *len
)
915 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
919 while (i
> 0 && isdigit (encoded
[i
]))
921 if (i
>= 0 && encoded
[i
] == '.')
923 else if (i
>= 0 && encoded
[i
] == '$')
925 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
927 else if (i
>= 1 && strncmp (encoded
+ i
- 1, "__", 2) == 0)
932 /* Remove the suffix introduced by the compiler for protected object
936 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
938 /* Remove trailing N. */
940 /* Protected entry subprograms are broken into two
941 separate subprograms: The first one is unprotected, and has
942 a 'N' suffix; the second is the protected version, and has
943 the 'P' suffix. The second calls the first one after handling
944 the protection. Since the P subprograms are internally generated,
945 we leave these names undecoded, giving the user a clue that this
946 entity is internal. */
949 && encoded
[*len
- 1] == 'N'
950 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
954 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
957 ada_remove_Xbn_suffix (const char *encoded
, int *len
)
961 while (i
> 0 && (encoded
[i
] == 'b' || encoded
[i
] == 'n'))
964 if (encoded
[i
] != 'X')
970 if (isalnum (encoded
[i
-1]))
974 /* If ENCODED follows the GNAT entity encoding conventions, then return
975 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
978 The resulting string is valid until the next call of ada_decode.
979 If the string is unchanged by decoding, the original string pointer
983 ada_decode (const char *encoded
)
990 static char *decoding_buffer
= NULL
;
991 static size_t decoding_buffer_size
= 0;
993 /* The name of the Ada main procedure starts with "_ada_".
994 This prefix is not part of the decoded name, so skip this part
995 if we see this prefix. */
996 if (strncmp (encoded
, "_ada_", 5) == 0)
999 /* If the name starts with '_', then it is not a properly encoded
1000 name, so do not attempt to decode it. Similarly, if the name
1001 starts with '<', the name should not be decoded. */
1002 if (encoded
[0] == '_' || encoded
[0] == '<')
1005 len0
= strlen (encoded
);
1007 ada_remove_trailing_digits (encoded
, &len0
);
1008 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1010 /* Remove the ___X.* suffix if present. Do not forget to verify that
1011 the suffix is located before the current "end" of ENCODED. We want
1012 to avoid re-matching parts of ENCODED that have previously been
1013 marked as discarded (by decrementing LEN0). */
1014 p
= strstr (encoded
, "___");
1015 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1023 /* Remove any trailing TKB suffix. It tells us that this symbol
1024 is for the body of a task, but that information does not actually
1025 appear in the decoded name. */
1027 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
1030 /* Remove any trailing TB suffix. The TB suffix is slightly different
1031 from the TKB suffix because it is used for non-anonymous task
1034 if (len0
> 2 && strncmp (encoded
+ len0
- 2, "TB", 2) == 0)
1037 /* Remove trailing "B" suffixes. */
1038 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1040 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
1043 /* Make decoded big enough for possible expansion by operator name. */
1045 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
1046 decoded
= decoding_buffer
;
1048 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1050 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1053 while ((i
>= 0 && isdigit (encoded
[i
]))
1054 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1056 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1058 else if (encoded
[i
] == '$')
1062 /* The first few characters that are not alphabetic are not part
1063 of any encoding we use, so we can copy them over verbatim. */
1065 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1066 decoded
[j
] = encoded
[i
];
1071 /* Is this a symbol function? */
1072 if (at_start_name
&& encoded
[i
] == 'O')
1076 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1078 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1079 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1081 && !isalnum (encoded
[i
+ op_len
]))
1083 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1086 j
+= strlen (ada_opname_table
[k
].decoded
);
1090 if (ada_opname_table
[k
].encoded
!= NULL
)
1095 /* Replace "TK__" with "__", which will eventually be translated
1096 into "." (just below). */
1098 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
1101 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1102 be translated into "." (just below). These are internal names
1103 generated for anonymous blocks inside which our symbol is nested. */
1105 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1106 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1107 && isdigit (encoded
[i
+4]))
1111 while (k
< len0
&& isdigit (encoded
[k
]))
1112 k
++; /* Skip any extra digit. */
1114 /* Double-check that the "__B_{DIGITS}+" sequence we found
1115 is indeed followed by "__". */
1116 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1120 /* Remove _E{DIGITS}+[sb] */
1122 /* Just as for protected object subprograms, there are 2 categories
1123 of subprograms created by the compiler for each entry. The first
1124 one implements the actual entry code, and has a suffix following
1125 the convention above; the second one implements the barrier and
1126 uses the same convention as above, except that the 'E' is replaced
1129 Just as above, we do not decode the name of barrier functions
1130 to give the user a clue that the code he is debugging has been
1131 internally generated. */
1133 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1134 && isdigit (encoded
[i
+2]))
1138 while (k
< len0
&& isdigit (encoded
[k
]))
1142 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1145 /* Just as an extra precaution, make sure that if this
1146 suffix is followed by anything else, it is a '_'.
1147 Otherwise, we matched this sequence by accident. */
1149 || (k
< len0
&& encoded
[k
] == '_'))
1154 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1155 the GNAT front-end in protected object subprograms. */
1158 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1160 /* Backtrack a bit up until we reach either the begining of
1161 the encoded name, or "__". Make sure that we only find
1162 digits or lowercase characters. */
1163 const char *ptr
= encoded
+ i
- 1;
1165 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1168 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1172 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1174 /* This is a X[bn]* sequence not separated from the previous
1175 part of the name with a non-alpha-numeric character (in other
1176 words, immediately following an alpha-numeric character), then
1177 verify that it is placed at the end of the encoded name. If
1178 not, then the encoding is not valid and we should abort the
1179 decoding. Otherwise, just skip it, it is used in body-nested
1183 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1187 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1189 /* Replace '__' by '.'. */
1197 /* It's a character part of the decoded name, so just copy it
1199 decoded
[j
] = encoded
[i
];
1204 decoded
[j
] = '\000';
1206 /* Decoded names should never contain any uppercase character.
1207 Double-check this, and abort the decoding if we find one. */
1209 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1210 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1213 if (strcmp (decoded
, encoded
) == 0)
1219 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1220 decoded
= decoding_buffer
;
1221 if (encoded
[0] == '<')
1222 strcpy (decoded
, encoded
);
1224 xsnprintf (decoded
, decoding_buffer_size
, "<%s>", encoded
);
1229 /* Table for keeping permanent unique copies of decoded names. Once
1230 allocated, names in this table are never released. While this is a
1231 storage leak, it should not be significant unless there are massive
1232 changes in the set of decoded names in successive versions of a
1233 symbol table loaded during a single session. */
1234 static struct htab
*decoded_names_store
;
1236 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1237 in the language-specific part of GSYMBOL, if it has not been
1238 previously computed. Tries to save the decoded name in the same
1239 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1240 in any case, the decoded symbol has a lifetime at least that of
1242 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1243 const, but nevertheless modified to a semantically equivalent form
1244 when a decoded name is cached in it. */
1247 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1250 (char **) &gsymbol
->language_specific
.mangled_lang
.demangled_name
;
1252 if (*resultp
== NULL
)
1254 const char *decoded
= ada_decode (gsymbol
->name
);
1256 if (gsymbol
->obj_section
!= NULL
)
1258 struct objfile
*objf
= gsymbol
->obj_section
->objfile
;
1260 *resultp
= obsavestring (decoded
, strlen (decoded
),
1261 &objf
->objfile_obstack
);
1263 /* Sometimes, we can't find a corresponding objfile, in which
1264 case, we put the result on the heap. Since we only decode
1265 when needed, we hope this usually does not cause a
1266 significant memory leak (FIXME). */
1267 if (*resultp
== NULL
)
1269 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1273 *slot
= xstrdup (decoded
);
1282 ada_la_decode (const char *encoded
, int options
)
1284 return xstrdup (ada_decode (encoded
));
1287 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1288 suffixes that encode debugging information or leading _ada_ on
1289 SYM_NAME (see is_name_suffix commentary for the debugging
1290 information that is ignored). If WILD, then NAME need only match a
1291 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1292 either argument is NULL. */
1295 match_name (const char *sym_name
, const char *name
, int wild
)
1297 if (sym_name
== NULL
|| name
== NULL
)
1300 return wild_match (sym_name
, name
) == 0;
1303 int len_name
= strlen (name
);
1305 return (strncmp (sym_name
, name
, len_name
) == 0
1306 && is_name_suffix (sym_name
+ len_name
))
1307 || (strncmp (sym_name
, "_ada_", 5) == 0
1308 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1309 && is_name_suffix (sym_name
+ len_name
+ 5));
1316 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1317 generated by the GNAT compiler to describe the index type used
1318 for each dimension of an array, check whether it follows the latest
1319 known encoding. If not, fix it up to conform to the latest encoding.
1320 Otherwise, do nothing. This function also does nothing if
1321 INDEX_DESC_TYPE is NULL.
1323 The GNAT encoding used to describle the array index type evolved a bit.
1324 Initially, the information would be provided through the name of each
1325 field of the structure type only, while the type of these fields was
1326 described as unspecified and irrelevant. The debugger was then expected
1327 to perform a global type lookup using the name of that field in order
1328 to get access to the full index type description. Because these global
1329 lookups can be very expensive, the encoding was later enhanced to make
1330 the global lookup unnecessary by defining the field type as being
1331 the full index type description.
1333 The purpose of this routine is to allow us to support older versions
1334 of the compiler by detecting the use of the older encoding, and by
1335 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1336 we essentially replace each field's meaningless type by the associated
1340 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1344 if (index_desc_type
== NULL
)
1346 gdb_assert (TYPE_NFIELDS (index_desc_type
) > 0);
1348 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1349 to check one field only, no need to check them all). If not, return
1352 If our INDEX_DESC_TYPE was generated using the older encoding,
1353 the field type should be a meaningless integer type whose name
1354 is not equal to the field name. */
1355 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)) != NULL
1356 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)),
1357 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1360 /* Fixup each field of INDEX_DESC_TYPE. */
1361 for (i
= 0; i
< TYPE_NFIELDS (index_desc_type
); i
++)
1363 char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1364 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1367 TYPE_FIELD_TYPE (index_desc_type
, i
) = raw_type
;
1371 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1373 static char *bound_name
[] = {
1374 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1375 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1378 /* Maximum number of array dimensions we are prepared to handle. */
1380 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1383 /* The desc_* routines return primitive portions of array descriptors
1386 /* The descriptor or array type, if any, indicated by TYPE; removes
1387 level of indirection, if needed. */
1389 static struct type
*
1390 desc_base_type (struct type
*type
)
1394 type
= ada_check_typedef (type
);
1395 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
1396 type
= ada_typedef_target_type (type
);
1399 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1400 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1401 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1406 /* True iff TYPE indicates a "thin" array pointer type. */
1409 is_thin_pntr (struct type
*type
)
1412 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1413 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1416 /* The descriptor type for thin pointer type TYPE. */
1418 static struct type
*
1419 thin_descriptor_type (struct type
*type
)
1421 struct type
*base_type
= desc_base_type (type
);
1423 if (base_type
== NULL
)
1425 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1429 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1431 if (alt_type
== NULL
)
1438 /* A pointer to the array data for thin-pointer value VAL. */
1440 static struct value
*
1441 thin_data_pntr (struct value
*val
)
1443 struct type
*type
= value_type (val
);
1444 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1446 data_type
= lookup_pointer_type (data_type
);
1448 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1449 return value_cast (data_type
, value_copy (val
));
1451 return value_from_longest (data_type
, value_address (val
));
1454 /* True iff TYPE indicates a "thick" array pointer type. */
1457 is_thick_pntr (struct type
*type
)
1459 type
= desc_base_type (type
);
1460 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1461 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1464 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1465 pointer to one, the type of its bounds data; otherwise, NULL. */
1467 static struct type
*
1468 desc_bounds_type (struct type
*type
)
1472 type
= desc_base_type (type
);
1476 else if (is_thin_pntr (type
))
1478 type
= thin_descriptor_type (type
);
1481 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1483 return ada_check_typedef (r
);
1485 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1487 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1489 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1494 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1495 one, a pointer to its bounds data. Otherwise NULL. */
1497 static struct value
*
1498 desc_bounds (struct value
*arr
)
1500 struct type
*type
= ada_check_typedef (value_type (arr
));
1502 if (is_thin_pntr (type
))
1504 struct type
*bounds_type
=
1505 desc_bounds_type (thin_descriptor_type (type
));
1508 if (bounds_type
== NULL
)
1509 error (_("Bad GNAT array descriptor"));
1511 /* NOTE: The following calculation is not really kosher, but
1512 since desc_type is an XVE-encoded type (and shouldn't be),
1513 the correct calculation is a real pain. FIXME (and fix GCC). */
1514 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1515 addr
= value_as_long (arr
);
1517 addr
= value_address (arr
);
1520 value_from_longest (lookup_pointer_type (bounds_type
),
1521 addr
- TYPE_LENGTH (bounds_type
));
1524 else if (is_thick_pntr (type
))
1526 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1527 _("Bad GNAT array descriptor"));
1528 struct type
*p_bounds_type
= value_type (p_bounds
);
1531 && TYPE_CODE (p_bounds_type
) == TYPE_CODE_PTR
)
1533 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1535 if (TYPE_STUB (target_type
))
1536 p_bounds
= value_cast (lookup_pointer_type
1537 (ada_check_typedef (target_type
)),
1541 error (_("Bad GNAT array descriptor"));
1549 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1550 position of the field containing the address of the bounds data. */
1553 fat_pntr_bounds_bitpos (struct type
*type
)
1555 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1558 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1559 size of the field containing the address of the bounds data. */
1562 fat_pntr_bounds_bitsize (struct type
*type
)
1564 type
= desc_base_type (type
);
1566 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1567 return TYPE_FIELD_BITSIZE (type
, 1);
1569 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1572 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1573 pointer to one, the type of its array data (a array-with-no-bounds type);
1574 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1577 static struct type
*
1578 desc_data_target_type (struct type
*type
)
1580 type
= desc_base_type (type
);
1582 /* NOTE: The following is bogus; see comment in desc_bounds. */
1583 if (is_thin_pntr (type
))
1584 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1));
1585 else if (is_thick_pntr (type
))
1587 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1590 && TYPE_CODE (ada_check_typedef (data_type
)) == TYPE_CODE_PTR
)
1591 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1597 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1600 static struct value
*
1601 desc_data (struct value
*arr
)
1603 struct type
*type
= value_type (arr
);
1605 if (is_thin_pntr (type
))
1606 return thin_data_pntr (arr
);
1607 else if (is_thick_pntr (type
))
1608 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1609 _("Bad GNAT array descriptor"));
1615 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1616 position of the field containing the address of the data. */
1619 fat_pntr_data_bitpos (struct type
*type
)
1621 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1624 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1625 size of the field containing the address of the data. */
1628 fat_pntr_data_bitsize (struct type
*type
)
1630 type
= desc_base_type (type
);
1632 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1633 return TYPE_FIELD_BITSIZE (type
, 0);
1635 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1638 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1639 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1640 bound, if WHICH is 1. The first bound is I=1. */
1642 static struct value
*
1643 desc_one_bound (struct value
*bounds
, int i
, int which
)
1645 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1646 _("Bad GNAT array descriptor bounds"));
1649 /* If BOUNDS is an array-bounds structure type, return the bit position
1650 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1651 bound, if WHICH is 1. The first bound is I=1. */
1654 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1656 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1659 /* If BOUNDS is an array-bounds structure type, return the bit field size
1660 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1661 bound, if WHICH is 1. The first bound is I=1. */
1664 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1666 type
= desc_base_type (type
);
1668 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1669 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1671 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1674 /* If TYPE is the type of an array-bounds structure, the type of its
1675 Ith bound (numbering from 1). Otherwise, NULL. */
1677 static struct type
*
1678 desc_index_type (struct type
*type
, int i
)
1680 type
= desc_base_type (type
);
1682 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1683 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1688 /* The number of index positions in the array-bounds type TYPE.
1689 Return 0 if TYPE is NULL. */
1692 desc_arity (struct type
*type
)
1694 type
= desc_base_type (type
);
1697 return TYPE_NFIELDS (type
) / 2;
1701 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1702 an array descriptor type (representing an unconstrained array
1706 ada_is_direct_array_type (struct type
*type
)
1710 type
= ada_check_typedef (type
);
1711 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1712 || ada_is_array_descriptor_type (type
));
1715 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1719 ada_is_array_type (struct type
*type
)
1722 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1723 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1724 type
= TYPE_TARGET_TYPE (type
);
1725 return ada_is_direct_array_type (type
);
1728 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1731 ada_is_simple_array_type (struct type
*type
)
1735 type
= ada_check_typedef (type
);
1736 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1737 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1738 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
)))
1739 == TYPE_CODE_ARRAY
));
1742 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1745 ada_is_array_descriptor_type (struct type
*type
)
1747 struct type
*data_type
= desc_data_target_type (type
);
1751 type
= ada_check_typedef (type
);
1752 return (data_type
!= NULL
1753 && TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
1754 && desc_arity (desc_bounds_type (type
)) > 0);
1757 /* Non-zero iff type is a partially mal-formed GNAT array
1758 descriptor. FIXME: This is to compensate for some problems with
1759 debugging output from GNAT. Re-examine periodically to see if it
1763 ada_is_bogus_array_descriptor (struct type
*type
)
1767 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1768 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1769 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1770 && !ada_is_array_descriptor_type (type
);
1774 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1775 (fat pointer) returns the type of the array data described---specifically,
1776 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1777 in from the descriptor; otherwise, they are left unspecified. If
1778 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1779 returns NULL. The result is simply the type of ARR if ARR is not
1782 ada_type_of_array (struct value
*arr
, int bounds
)
1784 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1785 return decode_constrained_packed_array_type (value_type (arr
));
1787 if (!ada_is_array_descriptor_type (value_type (arr
)))
1788 return value_type (arr
);
1792 struct type
*array_type
=
1793 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1795 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1796 TYPE_FIELD_BITSIZE (array_type
, 0) =
1797 decode_packed_array_bitsize (value_type (arr
));
1803 struct type
*elt_type
;
1805 struct value
*descriptor
;
1807 elt_type
= ada_array_element_type (value_type (arr
), -1);
1808 arity
= ada_array_arity (value_type (arr
));
1810 if (elt_type
== NULL
|| arity
== 0)
1811 return ada_check_typedef (value_type (arr
));
1813 descriptor
= desc_bounds (arr
);
1814 if (value_as_long (descriptor
) == 0)
1818 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1819 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1820 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1821 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1824 create_range_type (range_type
, value_type (low
),
1825 longest_to_int (value_as_long (low
)),
1826 longest_to_int (value_as_long (high
)));
1827 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1829 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1831 /* We need to store the element packed bitsize, as well as
1832 recompute the array size, because it was previously
1833 computed based on the unpacked element size. */
1834 LONGEST lo
= value_as_long (low
);
1835 LONGEST hi
= value_as_long (high
);
1837 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1838 decode_packed_array_bitsize (value_type (arr
));
1839 /* If the array has no element, then the size is already
1840 zero, and does not need to be recomputed. */
1844 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
1846 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
1851 return lookup_pointer_type (elt_type
);
1855 /* If ARR does not represent an array, returns ARR unchanged.
1856 Otherwise, returns either a standard GDB array with bounds set
1857 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1858 GDB array. Returns NULL if ARR is a null fat pointer. */
1861 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1863 if (ada_is_array_descriptor_type (value_type (arr
)))
1865 struct type
*arrType
= ada_type_of_array (arr
, 1);
1867 if (arrType
== NULL
)
1869 return value_cast (arrType
, value_copy (desc_data (arr
)));
1871 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1872 return decode_constrained_packed_array (arr
);
1877 /* If ARR does not represent an array, returns ARR unchanged.
1878 Otherwise, returns a standard GDB array describing ARR (which may
1879 be ARR itself if it already is in the proper form). */
1882 ada_coerce_to_simple_array (struct value
*arr
)
1884 if (ada_is_array_descriptor_type (value_type (arr
)))
1886 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1889 error (_("Bounds unavailable for null array pointer."));
1890 check_size (TYPE_TARGET_TYPE (value_type (arrVal
)));
1891 return value_ind (arrVal
);
1893 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1894 return decode_constrained_packed_array (arr
);
1899 /* If TYPE represents a GNAT array type, return it translated to an
1900 ordinary GDB array type (possibly with BITSIZE fields indicating
1901 packing). For other types, is the identity. */
1904 ada_coerce_to_simple_array_type (struct type
*type
)
1906 if (ada_is_constrained_packed_array_type (type
))
1907 return decode_constrained_packed_array_type (type
);
1909 if (ada_is_array_descriptor_type (type
))
1910 return ada_check_typedef (desc_data_target_type (type
));
1915 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1918 ada_is_packed_array_type (struct type
*type
)
1922 type
= desc_base_type (type
);
1923 type
= ada_check_typedef (type
);
1925 ada_type_name (type
) != NULL
1926 && strstr (ada_type_name (type
), "___XP") != NULL
;
1929 /* Non-zero iff TYPE represents a standard GNAT constrained
1930 packed-array type. */
1933 ada_is_constrained_packed_array_type (struct type
*type
)
1935 return ada_is_packed_array_type (type
)
1936 && !ada_is_array_descriptor_type (type
);
1939 /* Non-zero iff TYPE represents an array descriptor for a
1940 unconstrained packed-array type. */
1943 ada_is_unconstrained_packed_array_type (struct type
*type
)
1945 return ada_is_packed_array_type (type
)
1946 && ada_is_array_descriptor_type (type
);
1949 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
1950 return the size of its elements in bits. */
1953 decode_packed_array_bitsize (struct type
*type
)
1959 /* Access to arrays implemented as fat pointers are encoded as a typedef
1960 of the fat pointer type. We need the name of the fat pointer type
1961 to do the decoding, so strip the typedef layer. */
1962 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
1963 type
= ada_typedef_target_type (type
);
1965 raw_name
= ada_type_name (ada_check_typedef (type
));
1967 raw_name
= ada_type_name (desc_base_type (type
));
1972 tail
= strstr (raw_name
, "___XP");
1973 gdb_assert (tail
!= NULL
);
1975 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1978 (_("could not understand bit size information on packed array"));
1985 /* Given that TYPE is a standard GDB array type with all bounds filled
1986 in, and that the element size of its ultimate scalar constituents
1987 (that is, either its elements, or, if it is an array of arrays, its
1988 elements' elements, etc.) is *ELT_BITS, return an identical type,
1989 but with the bit sizes of its elements (and those of any
1990 constituent arrays) recorded in the BITSIZE components of its
1991 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1994 static struct type
*
1995 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
1997 struct type
*new_elt_type
;
1998 struct type
*new_type
;
1999 LONGEST low_bound
, high_bound
;
2001 type
= ada_check_typedef (type
);
2002 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2005 new_type
= alloc_type_copy (type
);
2007 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2009 create_array_type (new_type
, new_elt_type
, TYPE_INDEX_TYPE (type
));
2010 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2011 TYPE_NAME (new_type
) = ada_type_name (type
);
2013 if (get_discrete_bounds (TYPE_INDEX_TYPE (type
),
2014 &low_bound
, &high_bound
) < 0)
2015 low_bound
= high_bound
= 0;
2016 if (high_bound
< low_bound
)
2017 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2020 *elt_bits
*= (high_bound
- low_bound
+ 1);
2021 TYPE_LENGTH (new_type
) =
2022 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2025 TYPE_FIXED_INSTANCE (new_type
) = 1;
2029 /* The array type encoded by TYPE, where
2030 ada_is_constrained_packed_array_type (TYPE). */
2032 static struct type
*
2033 decode_constrained_packed_array_type (struct type
*type
)
2035 char *raw_name
= ada_type_name (ada_check_typedef (type
));
2038 struct type
*shadow_type
;
2042 raw_name
= ada_type_name (desc_base_type (type
));
2047 name
= (char *) alloca (strlen (raw_name
) + 1);
2048 tail
= strstr (raw_name
, "___XP");
2049 type
= desc_base_type (type
);
2051 memcpy (name
, raw_name
, tail
- raw_name
);
2052 name
[tail
- raw_name
] = '\000';
2054 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2056 if (shadow_type
== NULL
)
2058 lim_warning (_("could not find bounds information on packed array"));
2061 CHECK_TYPEDEF (shadow_type
);
2063 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
2065 lim_warning (_("could not understand bounds "
2066 "information on packed array"));
2070 bits
= decode_packed_array_bitsize (type
);
2071 return constrained_packed_array_type (shadow_type
, &bits
);
2074 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2075 array, returns a simple array that denotes that array. Its type is a
2076 standard GDB array type except that the BITSIZEs of the array
2077 target types are set to the number of bits in each element, and the
2078 type length is set appropriately. */
2080 static struct value
*
2081 decode_constrained_packed_array (struct value
*arr
)
2085 arr
= ada_coerce_ref (arr
);
2087 /* If our value is a pointer, then dererence it. Make sure that
2088 this operation does not cause the target type to be fixed, as
2089 this would indirectly cause this array to be decoded. The rest
2090 of the routine assumes that the array hasn't been decoded yet,
2091 so we use the basic "value_ind" routine to perform the dereferencing,
2092 as opposed to using "ada_value_ind". */
2093 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
2094 arr
= value_ind (arr
);
2096 type
= decode_constrained_packed_array_type (value_type (arr
));
2099 error (_("can't unpack array"));
2103 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr
)))
2104 && ada_is_modular_type (value_type (arr
)))
2106 /* This is a (right-justified) modular type representing a packed
2107 array with no wrapper. In order to interpret the value through
2108 the (left-justified) packed array type we just built, we must
2109 first left-justify it. */
2110 int bit_size
, bit_pos
;
2113 mod
= ada_modulus (value_type (arr
)) - 1;
2120 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2121 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2122 bit_pos
/ HOST_CHAR_BIT
,
2123 bit_pos
% HOST_CHAR_BIT
,
2128 return coerce_unspec_val_to_type (arr
, type
);
2132 /* The value of the element of packed array ARR at the ARITY indices
2133 given in IND. ARR must be a simple array. */
2135 static struct value
*
2136 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2139 int bits
, elt_off
, bit_off
;
2140 long elt_total_bit_offset
;
2141 struct type
*elt_type
;
2145 elt_total_bit_offset
= 0;
2146 elt_type
= ada_check_typedef (value_type (arr
));
2147 for (i
= 0; i
< arity
; i
+= 1)
2149 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
2150 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2152 (_("attempt to do packed indexing of "
2153 "something other than a packed array"));
2156 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
2157 LONGEST lowerbound
, upperbound
;
2160 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2162 lim_warning (_("don't know bounds of array"));
2163 lowerbound
= upperbound
= 0;
2166 idx
= pos_atr (ind
[i
]);
2167 if (idx
< lowerbound
|| idx
> upperbound
)
2168 lim_warning (_("packed array index %ld out of bounds"),
2170 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2171 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2172 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2175 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2176 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2178 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2183 /* Non-zero iff TYPE includes negative integer values. */
2186 has_negatives (struct type
*type
)
2188 switch (TYPE_CODE (type
))
2193 return !TYPE_UNSIGNED (type
);
2194 case TYPE_CODE_RANGE
:
2195 return TYPE_LOW_BOUND (type
) < 0;
2200 /* Create a new value of type TYPE from the contents of OBJ starting
2201 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2202 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2203 assigning through the result will set the field fetched from.
2204 VALADDR is ignored unless OBJ is NULL, in which case,
2205 VALADDR+OFFSET must address the start of storage containing the
2206 packed value. The value returned in this case is never an lval.
2207 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2210 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2211 long offset
, int bit_offset
, int bit_size
,
2215 int src
, /* Index into the source area */
2216 targ
, /* Index into the target area */
2217 srcBitsLeft
, /* Number of source bits left to move */
2218 nsrc
, ntarg
, /* Number of source and target bytes */
2219 unusedLS
, /* Number of bits in next significant
2220 byte of source that are unused */
2221 accumSize
; /* Number of meaningful bits in accum */
2222 unsigned char *bytes
; /* First byte containing data to unpack */
2223 unsigned char *unpacked
;
2224 unsigned long accum
; /* Staging area for bits being transferred */
2226 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2227 /* Transmit bytes from least to most significant; delta is the direction
2228 the indices move. */
2229 int delta
= gdbarch_bits_big_endian (get_type_arch (type
)) ? -1 : 1;
2231 type
= ada_check_typedef (type
);
2235 v
= allocate_value (type
);
2236 bytes
= (unsigned char *) (valaddr
+ offset
);
2238 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2241 value_address (obj
) + offset
);
2242 bytes
= (unsigned char *) alloca (len
);
2243 read_memory (value_address (v
), bytes
, len
);
2247 v
= allocate_value (type
);
2248 bytes
= (unsigned char *) value_contents (obj
) + offset
;
2255 set_value_component_location (v
, obj
);
2256 new_addr
= value_address (obj
) + offset
;
2257 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2258 set_value_bitsize (v
, bit_size
);
2259 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2262 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2264 set_value_address (v
, new_addr
);
2267 set_value_bitsize (v
, bit_size
);
2268 unpacked
= (unsigned char *) value_contents (v
);
2270 srcBitsLeft
= bit_size
;
2272 ntarg
= TYPE_LENGTH (type
);
2276 memset (unpacked
, 0, TYPE_LENGTH (type
));
2279 else if (gdbarch_bits_big_endian (get_type_arch (type
)))
2282 if (has_negatives (type
)
2283 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2287 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2290 switch (TYPE_CODE (type
))
2292 case TYPE_CODE_ARRAY
:
2293 case TYPE_CODE_UNION
:
2294 case TYPE_CODE_STRUCT
:
2295 /* Non-scalar values must be aligned at a byte boundary... */
2297 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2298 /* ... And are placed at the beginning (most-significant) bytes
2300 targ
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2305 targ
= TYPE_LENGTH (type
) - 1;
2311 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2314 unusedLS
= bit_offset
;
2317 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
2324 /* Mask for removing bits of the next source byte that are not
2325 part of the value. */
2326 unsigned int unusedMSMask
=
2327 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2329 /* Sign-extend bits for this byte. */
2330 unsigned int signMask
= sign
& ~unusedMSMask
;
2333 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2334 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2335 if (accumSize
>= HOST_CHAR_BIT
)
2337 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2338 accumSize
-= HOST_CHAR_BIT
;
2339 accum
>>= HOST_CHAR_BIT
;
2343 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2350 accum
|= sign
<< accumSize
;
2351 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2352 accumSize
-= HOST_CHAR_BIT
;
2353 accum
>>= HOST_CHAR_BIT
;
2361 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2362 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2365 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
2366 int src_offset
, int n
, int bits_big_endian_p
)
2368 unsigned int accum
, mask
;
2369 int accum_bits
, chunk_size
;
2371 target
+= targ_offset
/ HOST_CHAR_BIT
;
2372 targ_offset
%= HOST_CHAR_BIT
;
2373 source
+= src_offset
/ HOST_CHAR_BIT
;
2374 src_offset
%= HOST_CHAR_BIT
;
2375 if (bits_big_endian_p
)
2377 accum
= (unsigned char) *source
;
2379 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2385 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2386 accum_bits
+= HOST_CHAR_BIT
;
2388 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2391 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2392 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2395 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2397 accum_bits
-= chunk_size
;
2404 accum
= (unsigned char) *source
>> src_offset
;
2406 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2410 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2411 accum_bits
+= HOST_CHAR_BIT
;
2413 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2416 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2417 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2419 accum_bits
-= chunk_size
;
2420 accum
>>= chunk_size
;
2427 /* Store the contents of FROMVAL into the location of TOVAL.
2428 Return a new value with the location of TOVAL and contents of
2429 FROMVAL. Handles assignment into packed fields that have
2430 floating-point or non-scalar types. */
2432 static struct value
*
2433 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2435 struct type
*type
= value_type (toval
);
2436 int bits
= value_bitsize (toval
);
2438 toval
= ada_coerce_ref (toval
);
2439 fromval
= ada_coerce_ref (fromval
);
2441 if (ada_is_direct_array_type (value_type (toval
)))
2442 toval
= ada_coerce_to_simple_array (toval
);
2443 if (ada_is_direct_array_type (value_type (fromval
)))
2444 fromval
= ada_coerce_to_simple_array (fromval
);
2446 if (!deprecated_value_modifiable (toval
))
2447 error (_("Left operand of assignment is not a modifiable lvalue."));
2449 if (VALUE_LVAL (toval
) == lval_memory
2451 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2452 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2454 int len
= (value_bitpos (toval
)
2455 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2457 char *buffer
= (char *) alloca (len
);
2459 CORE_ADDR to_addr
= value_address (toval
);
2461 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2462 fromval
= value_cast (type
, fromval
);
2464 read_memory (to_addr
, buffer
, len
);
2465 from_size
= value_bitsize (fromval
);
2467 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2468 if (gdbarch_bits_big_endian (get_type_arch (type
)))
2469 move_bits (buffer
, value_bitpos (toval
),
2470 value_contents (fromval
), from_size
- bits
, bits
, 1);
2472 move_bits (buffer
, value_bitpos (toval
),
2473 value_contents (fromval
), 0, bits
, 0);
2474 write_memory (to_addr
, buffer
, len
);
2475 observer_notify_memory_changed (to_addr
, len
, buffer
);
2477 val
= value_copy (toval
);
2478 memcpy (value_contents_raw (val
), value_contents (fromval
),
2479 TYPE_LENGTH (type
));
2480 deprecated_set_value_type (val
, type
);
2485 return value_assign (toval
, fromval
);
2489 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2490 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2491 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2492 * COMPONENT, and not the inferior's memory. The current contents
2493 * of COMPONENT are ignored. */
2495 value_assign_to_component (struct value
*container
, struct value
*component
,
2498 LONGEST offset_in_container
=
2499 (LONGEST
) (value_address (component
) - value_address (container
));
2500 int bit_offset_in_container
=
2501 value_bitpos (component
) - value_bitpos (container
);
2504 val
= value_cast (value_type (component
), val
);
2506 if (value_bitsize (component
) == 0)
2507 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2509 bits
= value_bitsize (component
);
2511 if (gdbarch_bits_big_endian (get_type_arch (value_type (container
))))
2512 move_bits (value_contents_writeable (container
) + offset_in_container
,
2513 value_bitpos (container
) + bit_offset_in_container
,
2514 value_contents (val
),
2515 TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
,
2518 move_bits (value_contents_writeable (container
) + offset_in_container
,
2519 value_bitpos (container
) + bit_offset_in_container
,
2520 value_contents (val
), 0, bits
, 0);
2523 /* The value of the element of array ARR at the ARITY indices given in IND.
2524 ARR may be either a simple array, GNAT array descriptor, or pointer
2528 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2532 struct type
*elt_type
;
2534 elt
= ada_coerce_to_simple_array (arr
);
2536 elt_type
= ada_check_typedef (value_type (elt
));
2537 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2538 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2539 return value_subscript_packed (elt
, arity
, ind
);
2541 for (k
= 0; k
< arity
; k
+= 1)
2543 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2544 error (_("too many subscripts (%d expected)"), k
);
2545 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2550 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2551 value of the element of *ARR at the ARITY indices given in
2552 IND. Does not read the entire array into memory. */
2554 static struct value
*
2555 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2560 for (k
= 0; k
< arity
; k
+= 1)
2564 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2565 error (_("too many subscripts (%d expected)"), k
);
2566 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2568 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2569 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2570 type
= TYPE_TARGET_TYPE (type
);
2573 return value_ind (arr
);
2576 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2577 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2578 elements starting at index LOW. The lower bound of this array is LOW, as
2580 static struct value
*
2581 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2584 struct type
*type0
= ada_check_typedef (type
);
2585 CORE_ADDR base
= value_as_address (array_ptr
)
2586 + ((low
- ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0
)))
2587 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0
)));
2588 struct type
*index_type
=
2589 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0
)),
2591 struct type
*slice_type
=
2592 create_array_type (NULL
, TYPE_TARGET_TYPE (type0
), index_type
);
2594 return value_at_lazy (slice_type
, base
);
2598 static struct value
*
2599 ada_value_slice (struct value
*array
, int low
, int high
)
2601 struct type
*type
= ada_check_typedef (value_type (array
));
2602 struct type
*index_type
=
2603 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2604 struct type
*slice_type
=
2605 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2607 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2610 /* If type is a record type in the form of a standard GNAT array
2611 descriptor, returns the number of dimensions for type. If arr is a
2612 simple array, returns the number of "array of"s that prefix its
2613 type designation. Otherwise, returns 0. */
2616 ada_array_arity (struct type
*type
)
2623 type
= desc_base_type (type
);
2626 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2627 return desc_arity (desc_bounds_type (type
));
2629 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2632 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2638 /* If TYPE is a record type in the form of a standard GNAT array
2639 descriptor or a simple array type, returns the element type for
2640 TYPE after indexing by NINDICES indices, or by all indices if
2641 NINDICES is -1. Otherwise, returns NULL. */
2644 ada_array_element_type (struct type
*type
, int nindices
)
2646 type
= desc_base_type (type
);
2648 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2651 struct type
*p_array_type
;
2653 p_array_type
= desc_data_target_type (type
);
2655 k
= ada_array_arity (type
);
2659 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2660 if (nindices
>= 0 && k
> nindices
)
2662 while (k
> 0 && p_array_type
!= NULL
)
2664 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2667 return p_array_type
;
2669 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2671 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2673 type
= TYPE_TARGET_TYPE (type
);
2682 /* The type of nth index in arrays of given type (n numbering from 1).
2683 Does not examine memory. Throws an error if N is invalid or TYPE
2684 is not an array type. NAME is the name of the Ada attribute being
2685 evaluated ('range, 'first, 'last, or 'length); it is used in building
2686 the error message. */
2688 static struct type
*
2689 ada_index_type (struct type
*type
, int n
, const char *name
)
2691 struct type
*result_type
;
2693 type
= desc_base_type (type
);
2695 if (n
< 0 || n
> ada_array_arity (type
))
2696 error (_("invalid dimension number to '%s"), name
);
2698 if (ada_is_simple_array_type (type
))
2702 for (i
= 1; i
< n
; i
+= 1)
2703 type
= TYPE_TARGET_TYPE (type
);
2704 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2705 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2706 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2707 perhaps stabsread.c would make more sense. */
2708 if (result_type
&& TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2713 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2714 if (result_type
== NULL
)
2715 error (_("attempt to take bound of something that is not an array"));
2721 /* Given that arr is an array type, returns the lower bound of the
2722 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2723 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2724 array-descriptor type. It works for other arrays with bounds supplied
2725 by run-time quantities other than discriminants. */
2728 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
)
2730 struct type
*type
, *elt_type
, *index_type_desc
, *index_type
;
2733 gdb_assert (which
== 0 || which
== 1);
2735 if (ada_is_constrained_packed_array_type (arr_type
))
2736 arr_type
= decode_constrained_packed_array_type (arr_type
);
2738 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2739 return (LONGEST
) - which
;
2741 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2742 type
= TYPE_TARGET_TYPE (arr_type
);
2747 for (i
= n
; i
> 1; i
--)
2748 elt_type
= TYPE_TARGET_TYPE (type
);
2750 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2751 ada_fixup_array_indexes_type (index_type_desc
);
2752 if (index_type_desc
!= NULL
)
2753 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, n
- 1),
2756 index_type
= TYPE_INDEX_TYPE (elt_type
);
2759 (LONGEST
) (which
== 0
2760 ? ada_discrete_type_low_bound (index_type
)
2761 : ada_discrete_type_high_bound (index_type
));
2764 /* Given that arr is an array value, returns the lower bound of the
2765 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2766 WHICH is 1. This routine will also work for arrays with bounds
2767 supplied by run-time quantities other than discriminants. */
2770 ada_array_bound (struct value
*arr
, int n
, int which
)
2772 struct type
*arr_type
= value_type (arr
);
2774 if (ada_is_constrained_packed_array_type (arr_type
))
2775 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
2776 else if (ada_is_simple_array_type (arr_type
))
2777 return ada_array_bound_from_type (arr_type
, n
, which
);
2779 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
2782 /* Given that arr is an array value, returns the length of the
2783 nth index. This routine will also work for arrays with bounds
2784 supplied by run-time quantities other than discriminants.
2785 Does not work for arrays indexed by enumeration types with representation
2786 clauses at the moment. */
2789 ada_array_length (struct value
*arr
, int n
)
2791 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2793 if (ada_is_constrained_packed_array_type (arr_type
))
2794 return ada_array_length (decode_constrained_packed_array (arr
), n
);
2796 if (ada_is_simple_array_type (arr_type
))
2797 return (ada_array_bound_from_type (arr_type
, n
, 1)
2798 - ada_array_bound_from_type (arr_type
, n
, 0) + 1);
2800 return (value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1))
2801 - value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0)) + 1);
2804 /* An empty array whose type is that of ARR_TYPE (an array type),
2805 with bounds LOW to LOW-1. */
2807 static struct value
*
2808 empty_array (struct type
*arr_type
, int low
)
2810 struct type
*arr_type0
= ada_check_typedef (arr_type
);
2811 struct type
*index_type
=
2812 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0
)),
2814 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
2816 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2820 /* Name resolution */
2822 /* The "decoded" name for the user-definable Ada operator corresponding
2826 ada_decoded_op_name (enum exp_opcode op
)
2830 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2832 if (ada_opname_table
[i
].op
== op
)
2833 return ada_opname_table
[i
].decoded
;
2835 error (_("Could not find operator name for opcode"));
2839 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2840 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2841 undefined namespace) and converts operators that are
2842 user-defined into appropriate function calls. If CONTEXT_TYPE is
2843 non-null, it provides a preferred result type [at the moment, only
2844 type void has any effect---causing procedures to be preferred over
2845 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2846 return type is preferred. May change (expand) *EXP. */
2849 resolve (struct expression
**expp
, int void_context_p
)
2851 struct type
*context_type
= NULL
;
2855 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
2857 resolve_subexp (expp
, &pc
, 1, context_type
);
2860 /* Resolve the operator of the subexpression beginning at
2861 position *POS of *EXPP. "Resolving" consists of replacing
2862 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2863 with their resolutions, replacing built-in operators with
2864 function calls to user-defined operators, where appropriate, and,
2865 when DEPROCEDURE_P is non-zero, converting function-valued variables
2866 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2867 are as in ada_resolve, above. */
2869 static struct value
*
2870 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2871 struct type
*context_type
)
2875 struct expression
*exp
; /* Convenience: == *expp. */
2876 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2877 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2878 int nargs
; /* Number of operands. */
2885 /* Pass one: resolve operands, saving their types and updating *pos,
2890 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2891 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2896 resolve_subexp (expp
, pos
, 0, NULL
);
2898 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2903 resolve_subexp (expp
, pos
, 0, NULL
);
2908 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
));
2911 case OP_ATR_MODULUS
:
2921 case TERNOP_IN_RANGE
:
2922 case BINOP_IN_BOUNDS
:
2928 case OP_DISCRETE_RANGE
:
2930 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
2939 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2941 resolve_subexp (expp
, pos
, 1, NULL
);
2943 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2960 case BINOP_LOGICAL_AND
:
2961 case BINOP_LOGICAL_OR
:
2962 case BINOP_BITWISE_AND
:
2963 case BINOP_BITWISE_IOR
:
2964 case BINOP_BITWISE_XOR
:
2967 case BINOP_NOTEQUAL
:
2974 case BINOP_SUBSCRIPT
:
2982 case UNOP_LOGICAL_NOT
:
2998 case OP_INTERNALVAR
:
3008 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3011 case STRUCTOP_STRUCT
:
3012 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3025 error (_("Unexpected operator during name resolution"));
3028 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
3029 for (i
= 0; i
< nargs
; i
+= 1)
3030 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
3034 /* Pass two: perform any resolution on principal operator. */
3041 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3043 struct ada_symbol_info
*candidates
;
3047 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3048 (exp
->elts
[pc
+ 2].symbol
),
3049 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3052 if (n_candidates
> 1)
3054 /* Types tend to get re-introduced locally, so if there
3055 are any local symbols that are not types, first filter
3058 for (j
= 0; j
< n_candidates
; j
+= 1)
3059 switch (SYMBOL_CLASS (candidates
[j
].sym
))
3064 case LOC_REGPARM_ADDR
:
3072 if (j
< n_candidates
)
3075 while (j
< n_candidates
)
3077 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
3079 candidates
[j
] = candidates
[n_candidates
- 1];
3088 if (n_candidates
== 0)
3089 error (_("No definition found for %s"),
3090 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3091 else if (n_candidates
== 1)
3093 else if (deprocedure_p
3094 && !is_nonfunction (candidates
, n_candidates
))
3096 i
= ada_resolve_function
3097 (candidates
, n_candidates
, NULL
, 0,
3098 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
3101 error (_("Could not find a match for %s"),
3102 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3106 printf_filtered (_("Multiple matches for %s\n"),
3107 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3108 user_select_syms (candidates
, n_candidates
, 1);
3112 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3113 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
3114 if (innermost_block
== NULL
3115 || contained_in (candidates
[i
].block
, innermost_block
))
3116 innermost_block
= candidates
[i
].block
;
3120 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
3123 replace_operator_with_call (expp
, pc
, 0, 0,
3124 exp
->elts
[pc
+ 2].symbol
,
3125 exp
->elts
[pc
+ 1].block
);
3132 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3133 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3135 struct ada_symbol_info
*candidates
;
3139 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3140 (exp
->elts
[pc
+ 5].symbol
),
3141 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3143 if (n_candidates
== 1)
3147 i
= ada_resolve_function
3148 (candidates
, n_candidates
,
3150 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
3153 error (_("Could not find a match for %s"),
3154 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
3157 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3158 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
3159 if (innermost_block
== NULL
3160 || contained_in (candidates
[i
].block
, innermost_block
))
3161 innermost_block
= candidates
[i
].block
;
3172 case BINOP_BITWISE_AND
:
3173 case BINOP_BITWISE_IOR
:
3174 case BINOP_BITWISE_XOR
:
3176 case BINOP_NOTEQUAL
:
3184 case UNOP_LOGICAL_NOT
:
3186 if (possible_user_operator_p (op
, argvec
))
3188 struct ada_symbol_info
*candidates
;
3192 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
3193 (struct block
*) NULL
, VAR_DOMAIN
,
3195 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
3196 ada_decoded_op_name (op
), NULL
);
3200 replace_operator_with_call (expp
, pc
, nargs
, 1,
3201 candidates
[i
].sym
, candidates
[i
].block
);
3212 return evaluate_subexp_type (exp
, pos
);
3215 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3216 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3218 /* The term "match" here is rather loose. The match is heuristic and
3222 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3224 ftype
= ada_check_typedef (ftype
);
3225 atype
= ada_check_typedef (atype
);
3227 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3228 ftype
= TYPE_TARGET_TYPE (ftype
);
3229 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3230 atype
= TYPE_TARGET_TYPE (atype
);
3232 switch (TYPE_CODE (ftype
))
3235 return TYPE_CODE (ftype
) == TYPE_CODE (atype
);
3237 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3238 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3239 TYPE_TARGET_TYPE (atype
), 0);
3242 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3244 case TYPE_CODE_ENUM
:
3245 case TYPE_CODE_RANGE
:
3246 switch (TYPE_CODE (atype
))
3249 case TYPE_CODE_ENUM
:
3250 case TYPE_CODE_RANGE
:
3256 case TYPE_CODE_ARRAY
:
3257 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3258 || ada_is_array_descriptor_type (atype
));
3260 case TYPE_CODE_STRUCT
:
3261 if (ada_is_array_descriptor_type (ftype
))
3262 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3263 || ada_is_array_descriptor_type (atype
));
3265 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3266 && !ada_is_array_descriptor_type (atype
));
3268 case TYPE_CODE_UNION
:
3270 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3274 /* Return non-zero if the formals of FUNC "sufficiently match" the
3275 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3276 may also be an enumeral, in which case it is treated as a 0-
3277 argument function. */
3280 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3283 struct type
*func_type
= SYMBOL_TYPE (func
);
3285 if (SYMBOL_CLASS (func
) == LOC_CONST
3286 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3287 return (n_actuals
== 0);
3288 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3291 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3294 for (i
= 0; i
< n_actuals
; i
+= 1)
3296 if (actuals
[i
] == NULL
)
3300 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
,
3302 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3304 if (!ada_type_match (ftype
, atype
, 1))
3311 /* False iff function type FUNC_TYPE definitely does not produce a value
3312 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3313 FUNC_TYPE is not a valid function type with a non-null return type
3314 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3317 return_match (struct type
*func_type
, struct type
*context_type
)
3319 struct type
*return_type
;
3321 if (func_type
== NULL
)
3324 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3325 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
3327 return_type
= base_type (func_type
);
3328 if (return_type
== NULL
)
3331 context_type
= base_type (context_type
);
3333 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3334 return context_type
== NULL
|| return_type
== context_type
;
3335 else if (context_type
== NULL
)
3336 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3338 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3342 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3343 function (if any) that matches the types of the NARGS arguments in
3344 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3345 that returns that type, then eliminate matches that don't. If
3346 CONTEXT_TYPE is void and there is at least one match that does not
3347 return void, eliminate all matches that do.
3349 Asks the user if there is more than one match remaining. Returns -1
3350 if there is no such symbol or none is selected. NAME is used
3351 solely for messages. May re-arrange and modify SYMS in
3352 the process; the index returned is for the modified vector. */
3355 ada_resolve_function (struct ada_symbol_info syms
[],
3356 int nsyms
, struct value
**args
, int nargs
,
3357 const char *name
, struct type
*context_type
)
3361 int m
; /* Number of hits */
3364 /* In the first pass of the loop, we only accept functions matching
3365 context_type. If none are found, we add a second pass of the loop
3366 where every function is accepted. */
3367 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3369 for (k
= 0; k
< nsyms
; k
+= 1)
3371 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3373 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3374 && (fallback
|| return_match (type
, context_type
)))
3386 printf_filtered (_("Multiple matches for %s\n"), name
);
3387 user_select_syms (syms
, m
, 1);
3393 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3394 in a listing of choices during disambiguation (see sort_choices, below).
3395 The idea is that overloadings of a subprogram name from the
3396 same package should sort in their source order. We settle for ordering
3397 such symbols by their trailing number (__N or $N). */
3400 encoded_ordered_before (char *N0
, char *N1
)
3404 else if (N0
== NULL
)
3410 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3412 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3414 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3415 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3420 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3423 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3425 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3426 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3428 return (strcmp (N0
, N1
) < 0);
3432 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3436 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3440 for (i
= 1; i
< nsyms
; i
+= 1)
3442 struct ada_symbol_info sym
= syms
[i
];
3445 for (j
= i
- 1; j
>= 0; j
-= 1)
3447 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3448 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3450 syms
[j
+ 1] = syms
[j
];
3456 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3457 by asking the user (if necessary), returning the number selected,
3458 and setting the first elements of SYMS items. Error if no symbols
3461 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3462 to be re-integrated one of these days. */
3465 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3468 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3470 int first_choice
= (max_results
== 1) ? 1 : 2;
3471 const char *select_mode
= multiple_symbols_select_mode ();
3473 if (max_results
< 1)
3474 error (_("Request to select 0 symbols!"));
3478 if (select_mode
== multiple_symbols_cancel
)
3480 canceled because the command is ambiguous\n\
3481 See set/show multiple-symbol."));
3483 /* If select_mode is "all", then return all possible symbols.
3484 Only do that if more than one symbol can be selected, of course.
3485 Otherwise, display the menu as usual. */
3486 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3489 printf_unfiltered (_("[0] cancel\n"));
3490 if (max_results
> 1)
3491 printf_unfiltered (_("[1] all\n"));
3493 sort_choices (syms
, nsyms
);
3495 for (i
= 0; i
< nsyms
; i
+= 1)
3497 if (syms
[i
].sym
== NULL
)
3500 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3502 struct symtab_and_line sal
=
3503 find_function_start_sal (syms
[i
].sym
, 1);
3505 if (sal
.symtab
== NULL
)
3506 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3508 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3511 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3512 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3513 sal
.symtab
->filename
, sal
.line
);
3519 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3520 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3521 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3522 struct symtab
*symtab
= syms
[i
].sym
->symtab
;
3524 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3525 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3527 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3528 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3529 else if (is_enumeral
3530 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3532 printf_unfiltered (("[%d] "), i
+ first_choice
);
3533 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3535 printf_unfiltered (_("'(%s) (enumeral)\n"),
3536 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3538 else if (symtab
!= NULL
)
3539 printf_unfiltered (is_enumeral
3540 ? _("[%d] %s in %s (enumeral)\n")
3541 : _("[%d] %s at %s:?\n"),
3543 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3546 printf_unfiltered (is_enumeral
3547 ? _("[%d] %s (enumeral)\n")
3548 : _("[%d] %s at ?\n"),
3550 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3554 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3557 for (i
= 0; i
< n_chosen
; i
+= 1)
3558 syms
[i
] = syms
[chosen
[i
]];
3563 /* Read and validate a set of numeric choices from the user in the
3564 range 0 .. N_CHOICES-1. Place the results in increasing
3565 order in CHOICES[0 .. N-1], and return N.
3567 The user types choices as a sequence of numbers on one line
3568 separated by blanks, encoding them as follows:
3570 + A choice of 0 means to cancel the selection, throwing an error.
3571 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3572 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3574 The user is not allowed to choose more than MAX_RESULTS values.
3576 ANNOTATION_SUFFIX, if present, is used to annotate the input
3577 prompts (for use with the -f switch). */
3580 get_selections (int *choices
, int n_choices
, int max_results
,
3581 int is_all_choice
, char *annotation_suffix
)
3586 int first_choice
= is_all_choice
? 2 : 1;
3588 prompt
= getenv ("PS2");
3592 args
= command_line_input (prompt
, 0, annotation_suffix
);
3595 error_no_arg (_("one or more choice numbers"));
3599 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3600 order, as given in args. Choices are validated. */
3606 while (isspace (*args
))
3608 if (*args
== '\0' && n_chosen
== 0)
3609 error_no_arg (_("one or more choice numbers"));
3610 else if (*args
== '\0')
3613 choice
= strtol (args
, &args2
, 10);
3614 if (args
== args2
|| choice
< 0
3615 || choice
> n_choices
+ first_choice
- 1)
3616 error (_("Argument must be choice number"));
3620 error (_("cancelled"));
3622 if (choice
< first_choice
)
3624 n_chosen
= n_choices
;
3625 for (j
= 0; j
< n_choices
; j
+= 1)
3629 choice
-= first_choice
;
3631 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3635 if (j
< 0 || choice
!= choices
[j
])
3639 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3640 choices
[k
+ 1] = choices
[k
];
3641 choices
[j
+ 1] = choice
;
3646 if (n_chosen
> max_results
)
3647 error (_("Select no more than %d of the above"), max_results
);
3652 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3653 on the function identified by SYM and BLOCK, and taking NARGS
3654 arguments. Update *EXPP as needed to hold more space. */
3657 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3658 int oplen
, struct symbol
*sym
,
3659 struct block
*block
)
3661 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3662 symbol, -oplen for operator being replaced). */
3663 struct expression
*newexp
= (struct expression
*)
3664 xzalloc (sizeof (struct expression
)
3665 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3666 struct expression
*exp
= *expp
;
3668 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3669 newexp
->language_defn
= exp
->language_defn
;
3670 newexp
->gdbarch
= exp
->gdbarch
;
3671 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3672 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3673 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3675 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3676 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3678 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3679 newexp
->elts
[pc
+ 4].block
= block
;
3680 newexp
->elts
[pc
+ 5].symbol
= sym
;
3686 /* Type-class predicates */
3688 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3692 numeric_type_p (struct type
*type
)
3698 switch (TYPE_CODE (type
))
3703 case TYPE_CODE_RANGE
:
3704 return (type
== TYPE_TARGET_TYPE (type
)
3705 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3712 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3715 integer_type_p (struct type
*type
)
3721 switch (TYPE_CODE (type
))
3725 case TYPE_CODE_RANGE
:
3726 return (type
== TYPE_TARGET_TYPE (type
)
3727 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3734 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3737 scalar_type_p (struct type
*type
)
3743 switch (TYPE_CODE (type
))
3746 case TYPE_CODE_RANGE
:
3747 case TYPE_CODE_ENUM
:
3756 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3759 discrete_type_p (struct type
*type
)
3765 switch (TYPE_CODE (type
))
3768 case TYPE_CODE_RANGE
:
3769 case TYPE_CODE_ENUM
:
3770 case TYPE_CODE_BOOL
:
3778 /* Returns non-zero if OP with operands in the vector ARGS could be
3779 a user-defined function. Errs on the side of pre-defined operators
3780 (i.e., result 0). */
3783 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3785 struct type
*type0
=
3786 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3787 struct type
*type1
=
3788 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3802 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3806 case BINOP_BITWISE_AND
:
3807 case BINOP_BITWISE_IOR
:
3808 case BINOP_BITWISE_XOR
:
3809 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3812 case BINOP_NOTEQUAL
:
3817 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3820 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
3823 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3827 case UNOP_LOGICAL_NOT
:
3829 return (!numeric_type_p (type0
));
3838 1. In the following, we assume that a renaming type's name may
3839 have an ___XD suffix. It would be nice if this went away at some
3841 2. We handle both the (old) purely type-based representation of
3842 renamings and the (new) variable-based encoding. At some point,
3843 it is devoutly to be hoped that the former goes away
3844 (FIXME: hilfinger-2007-07-09).
3845 3. Subprogram renamings are not implemented, although the XRS
3846 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3848 /* If SYM encodes a renaming,
3850 <renaming> renames <renamed entity>,
3852 sets *LEN to the length of the renamed entity's name,
3853 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3854 the string describing the subcomponent selected from the renamed
3855 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3856 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3857 are undefined). Otherwise, returns a value indicating the category
3858 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3859 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3860 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3861 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3862 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3863 may be NULL, in which case they are not assigned.
3865 [Currently, however, GCC does not generate subprogram renamings.] */
3867 enum ada_renaming_category
3868 ada_parse_renaming (struct symbol
*sym
,
3869 const char **renamed_entity
, int *len
,
3870 const char **renaming_expr
)
3872 enum ada_renaming_category kind
;
3877 return ADA_NOT_RENAMING
;
3878 switch (SYMBOL_CLASS (sym
))
3881 return ADA_NOT_RENAMING
;
3883 return parse_old_style_renaming (SYMBOL_TYPE (sym
),
3884 renamed_entity
, len
, renaming_expr
);
3888 case LOC_OPTIMIZED_OUT
:
3889 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
3891 return ADA_NOT_RENAMING
;
3895 kind
= ADA_OBJECT_RENAMING
;
3899 kind
= ADA_EXCEPTION_RENAMING
;
3903 kind
= ADA_PACKAGE_RENAMING
;
3907 kind
= ADA_SUBPROGRAM_RENAMING
;
3911 return ADA_NOT_RENAMING
;
3915 if (renamed_entity
!= NULL
)
3916 *renamed_entity
= info
;
3917 suffix
= strstr (info
, "___XE");
3918 if (suffix
== NULL
|| suffix
== info
)
3919 return ADA_NOT_RENAMING
;
3921 *len
= strlen (info
) - strlen (suffix
);
3923 if (renaming_expr
!= NULL
)
3924 *renaming_expr
= suffix
;
3928 /* Assuming TYPE encodes a renaming according to the old encoding in
3929 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3930 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3931 ADA_NOT_RENAMING otherwise. */
3932 static enum ada_renaming_category
3933 parse_old_style_renaming (struct type
*type
,
3934 const char **renamed_entity
, int *len
,
3935 const char **renaming_expr
)
3937 enum ada_renaming_category kind
;
3942 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
3943 || TYPE_NFIELDS (type
) != 1)
3944 return ADA_NOT_RENAMING
;
3946 name
= type_name_no_tag (type
);
3948 return ADA_NOT_RENAMING
;
3950 name
= strstr (name
, "___XR");
3952 return ADA_NOT_RENAMING
;
3957 kind
= ADA_OBJECT_RENAMING
;
3960 kind
= ADA_EXCEPTION_RENAMING
;
3963 kind
= ADA_PACKAGE_RENAMING
;
3966 kind
= ADA_SUBPROGRAM_RENAMING
;
3969 return ADA_NOT_RENAMING
;
3972 info
= TYPE_FIELD_NAME (type
, 0);
3974 return ADA_NOT_RENAMING
;
3975 if (renamed_entity
!= NULL
)
3976 *renamed_entity
= info
;
3977 suffix
= strstr (info
, "___XE");
3978 if (renaming_expr
!= NULL
)
3979 *renaming_expr
= suffix
+ 5;
3980 if (suffix
== NULL
|| suffix
== info
)
3981 return ADA_NOT_RENAMING
;
3983 *len
= suffix
- info
;
3989 /* Evaluation: Function Calls */
3991 /* Return an lvalue containing the value VAL. This is the identity on
3992 lvalues, and otherwise has the side-effect of allocating memory
3993 in the inferior where a copy of the value contents is copied. */
3995 static struct value
*
3996 ensure_lval (struct value
*val
)
3998 if (VALUE_LVAL (val
) == not_lval
3999 || VALUE_LVAL (val
) == lval_internalvar
)
4001 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4002 const CORE_ADDR addr
=
4003 value_as_long (value_allocate_space_in_inferior (len
));
4005 set_value_address (val
, addr
);
4006 VALUE_LVAL (val
) = lval_memory
;
4007 write_memory (addr
, value_contents (val
), len
);
4013 /* Return the value ACTUAL, converted to be an appropriate value for a
4014 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4015 allocating any necessary descriptors (fat pointers), or copies of
4016 values not residing in memory, updating it as needed. */
4019 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4021 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4022 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4023 struct type
*formal_target
=
4024 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4025 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4026 struct type
*actual_target
=
4027 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
4028 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4030 if (ada_is_array_descriptor_type (formal_target
)
4031 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
4032 return make_array_descriptor (formal_type
, actual
);
4033 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4034 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
4036 struct value
*result
;
4038 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
4039 && ada_is_array_descriptor_type (actual_target
))
4040 result
= desc_data (actual
);
4041 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
4043 if (VALUE_LVAL (actual
) != lval_memory
)
4047 actual_type
= ada_check_typedef (value_type (actual
));
4048 val
= allocate_value (actual_type
);
4049 memcpy ((char *) value_contents_raw (val
),
4050 (char *) value_contents (actual
),
4051 TYPE_LENGTH (actual_type
));
4052 actual
= ensure_lval (val
);
4054 result
= value_addr (actual
);
4058 return value_cast_pointers (formal_type
, result
);
4060 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
4061 return ada_value_ind (actual
);
4066 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4067 type TYPE. This is usually an inefficient no-op except on some targets
4068 (such as AVR) where the representation of a pointer and an address
4072 value_pointer (struct value
*value
, struct type
*type
)
4074 struct gdbarch
*gdbarch
= get_type_arch (type
);
4075 unsigned len
= TYPE_LENGTH (type
);
4076 gdb_byte
*buf
= alloca (len
);
4079 addr
= value_address (value
);
4080 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4081 addr
= extract_unsigned_integer (buf
, len
, gdbarch_byte_order (gdbarch
));
4086 /* Push a descriptor of type TYPE for array value ARR on the stack at
4087 *SP, updating *SP to reflect the new descriptor. Return either
4088 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4089 to-descriptor type rather than a descriptor type), a struct value *
4090 representing a pointer to this descriptor. */
4092 static struct value
*
4093 make_array_descriptor (struct type
*type
, struct value
*arr
)
4095 struct type
*bounds_type
= desc_bounds_type (type
);
4096 struct type
*desc_type
= desc_base_type (type
);
4097 struct value
*descriptor
= allocate_value (desc_type
);
4098 struct value
*bounds
= allocate_value (bounds_type
);
4101 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4104 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4105 ada_array_bound (arr
, i
, 0),
4106 desc_bound_bitpos (bounds_type
, i
, 0),
4107 desc_bound_bitsize (bounds_type
, i
, 0));
4108 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4109 ada_array_bound (arr
, i
, 1),
4110 desc_bound_bitpos (bounds_type
, i
, 1),
4111 desc_bound_bitsize (bounds_type
, i
, 1));
4114 bounds
= ensure_lval (bounds
);
4116 modify_field (value_type (descriptor
),
4117 value_contents_writeable (descriptor
),
4118 value_pointer (ensure_lval (arr
),
4119 TYPE_FIELD_TYPE (desc_type
, 0)),
4120 fat_pntr_data_bitpos (desc_type
),
4121 fat_pntr_data_bitsize (desc_type
));
4123 modify_field (value_type (descriptor
),
4124 value_contents_writeable (descriptor
),
4125 value_pointer (bounds
,
4126 TYPE_FIELD_TYPE (desc_type
, 1)),
4127 fat_pntr_bounds_bitpos (desc_type
),
4128 fat_pntr_bounds_bitsize (desc_type
));
4130 descriptor
= ensure_lval (descriptor
);
4132 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
4133 return value_addr (descriptor
);
4138 /* Dummy definitions for an experimental caching module that is not
4139 * used in the public sources. */
4142 lookup_cached_symbol (const char *name
, domain_enum
namespace,
4143 struct symbol
**sym
, struct block
**block
)
4149 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
4150 struct block
*block
)
4156 /* Return the result of a standard (literal, C-like) lookup of NAME in
4157 given DOMAIN, visible from lexical block BLOCK. */
4159 static struct symbol
*
4160 standard_lookup (const char *name
, const struct block
*block
,
4165 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
))
4167 sym
= lookup_symbol_in_language (name
, block
, domain
, language_c
, 0);
4168 cache_symbol (name
, domain
, sym
, block_found
);
4173 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4174 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4175 since they contend in overloading in the same way. */
4177 is_nonfunction (struct ada_symbol_info syms
[], int n
)
4181 for (i
= 0; i
< n
; i
+= 1)
4182 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
4183 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
4184 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
4190 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4191 struct types. Otherwise, they may not. */
4194 equiv_types (struct type
*type0
, struct type
*type1
)
4198 if (type0
== NULL
|| type1
== NULL
4199 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
4201 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
4202 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
4203 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4204 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4210 /* True iff SYM0 represents the same entity as SYM1, or one that is
4211 no more defined than that of SYM1. */
4214 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4218 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4219 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4222 switch (SYMBOL_CLASS (sym0
))
4228 struct type
*type0
= SYMBOL_TYPE (sym0
);
4229 struct type
*type1
= SYMBOL_TYPE (sym1
);
4230 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4231 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4232 int len0
= strlen (name0
);
4235 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4236 && (equiv_types (type0
, type1
)
4237 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4238 && strncmp (name1
+ len0
, "___XV", 5) == 0));
4241 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4242 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4248 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4249 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4252 add_defn_to_vec (struct obstack
*obstackp
,
4254 struct block
*block
)
4257 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
4259 /* Do not try to complete stub types, as the debugger is probably
4260 already scanning all symbols matching a certain name at the
4261 time when this function is called. Trying to replace the stub
4262 type by its associated full type will cause us to restart a scan
4263 which may lead to an infinite recursion. Instead, the client
4264 collecting the matching symbols will end up collecting several
4265 matches, with at least one of them complete. It can then filter
4266 out the stub ones if needed. */
4268 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4270 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
4272 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
4274 prevDefns
[i
].sym
= sym
;
4275 prevDefns
[i
].block
= block
;
4281 struct ada_symbol_info info
;
4285 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
4289 /* Number of ada_symbol_info structures currently collected in
4290 current vector in *OBSTACKP. */
4293 num_defns_collected (struct obstack
*obstackp
)
4295 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
4298 /* Vector of ada_symbol_info structures currently collected in current
4299 vector in *OBSTACKP. If FINISH, close off the vector and return
4300 its final address. */
4302 static struct ada_symbol_info
*
4303 defns_collected (struct obstack
*obstackp
, int finish
)
4306 return obstack_finish (obstackp
);
4308 return (struct ada_symbol_info
*) obstack_base (obstackp
);
4311 /* Return a minimal symbol matching NAME according to Ada decoding
4312 rules. Returns NULL if there is no such minimal symbol. Names
4313 prefixed with "standard__" are handled specially: "standard__" is
4314 first stripped off, and only static and global symbols are searched. */
4316 struct minimal_symbol
*
4317 ada_lookup_simple_minsym (const char *name
)
4319 struct objfile
*objfile
;
4320 struct minimal_symbol
*msymbol
;
4323 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4325 name
+= sizeof ("standard__") - 1;
4329 wild_match
= (strstr (name
, "__") == NULL
);
4331 ALL_MSYMBOLS (objfile
, msymbol
)
4333 if (match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4334 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4341 /* For all subprograms that statically enclose the subprogram of the
4342 selected frame, add symbols matching identifier NAME in DOMAIN
4343 and their blocks to the list of data in OBSTACKP, as for
4344 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4348 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4349 const char *name
, domain_enum
namespace,
4354 /* True if TYPE is definitely an artificial type supplied to a symbol
4355 for which no debugging information was given in the symbol file. */
4358 is_nondebugging_type (struct type
*type
)
4360 char *name
= ada_type_name (type
);
4362 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4365 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4366 duplicate other symbols in the list (The only case I know of where
4367 this happens is when object files containing stabs-in-ecoff are
4368 linked with files containing ordinary ecoff debugging symbols (or no
4369 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4370 Returns the number of items in the modified list. */
4373 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4382 /* If two symbols have the same name and one of them is a stub type,
4383 the get rid of the stub. */
4385 if (TYPE_STUB (SYMBOL_TYPE (syms
[i
].sym
))
4386 && SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
)
4388 for (j
= 0; j
< nsyms
; j
++)
4391 && !TYPE_STUB (SYMBOL_TYPE (syms
[j
].sym
))
4392 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4393 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4394 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0)
4399 /* Two symbols with the same name, same class and same address
4400 should be identical. */
4402 else if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4403 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4404 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4406 for (j
= 0; j
< nsyms
; j
+= 1)
4409 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4410 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4411 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4412 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4413 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4414 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4421 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4422 syms
[j
- 1] = syms
[j
];
4431 /* Given a type that corresponds to a renaming entity, use the type name
4432 to extract the scope (package name or function name, fully qualified,
4433 and following the GNAT encoding convention) where this renaming has been
4434 defined. The string returned needs to be deallocated after use. */
4437 xget_renaming_scope (struct type
*renaming_type
)
4439 /* The renaming types adhere to the following convention:
4440 <scope>__<rename>___<XR extension>.
4441 So, to extract the scope, we search for the "___XR" extension,
4442 and then backtrack until we find the first "__". */
4444 const char *name
= type_name_no_tag (renaming_type
);
4445 char *suffix
= strstr (name
, "___XR");
4450 /* Now, backtrack a bit until we find the first "__". Start looking
4451 at suffix - 3, as the <rename> part is at least one character long. */
4453 for (last
= suffix
- 3; last
> name
; last
--)
4454 if (last
[0] == '_' && last
[1] == '_')
4457 /* Make a copy of scope and return it. */
4459 scope_len
= last
- name
;
4460 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4462 strncpy (scope
, name
, scope_len
);
4463 scope
[scope_len
] = '\0';
4468 /* Return nonzero if NAME corresponds to a package name. */
4471 is_package_name (const char *name
)
4473 /* Here, We take advantage of the fact that no symbols are generated
4474 for packages, while symbols are generated for each function.
4475 So the condition for NAME represent a package becomes equivalent
4476 to NAME not existing in our list of symbols. There is only one
4477 small complication with library-level functions (see below). */
4481 /* If it is a function that has not been defined at library level,
4482 then we should be able to look it up in the symbols. */
4483 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4486 /* Library-level function names start with "_ada_". See if function
4487 "_ada_" followed by NAME can be found. */
4489 /* Do a quick check that NAME does not contain "__", since library-level
4490 functions names cannot contain "__" in them. */
4491 if (strstr (name
, "__") != NULL
)
4494 fun_name
= xstrprintf ("_ada_%s", name
);
4496 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4499 /* Return nonzero if SYM corresponds to a renaming entity that is
4500 not visible from FUNCTION_NAME. */
4503 old_renaming_is_invisible (const struct symbol
*sym
, char *function_name
)
4507 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
4510 scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4512 make_cleanup (xfree
, scope
);
4514 /* If the rename has been defined in a package, then it is visible. */
4515 if (is_package_name (scope
))
4518 /* Check that the rename is in the current function scope by checking
4519 that its name starts with SCOPE. */
4521 /* If the function name starts with "_ada_", it means that it is
4522 a library-level function. Strip this prefix before doing the
4523 comparison, as the encoding for the renaming does not contain
4525 if (strncmp (function_name
, "_ada_", 5) == 0)
4528 return (strncmp (function_name
, scope
, strlen (scope
)) != 0);
4531 /* Remove entries from SYMS that corresponds to a renaming entity that
4532 is not visible from the function associated with CURRENT_BLOCK or
4533 that is superfluous due to the presence of more specific renaming
4534 information. Places surviving symbols in the initial entries of
4535 SYMS and returns the number of surviving symbols.
4538 First, in cases where an object renaming is implemented as a
4539 reference variable, GNAT may produce both the actual reference
4540 variable and the renaming encoding. In this case, we discard the
4543 Second, GNAT emits a type following a specified encoding for each renaming
4544 entity. Unfortunately, STABS currently does not support the definition
4545 of types that are local to a given lexical block, so all renamings types
4546 are emitted at library level. As a consequence, if an application
4547 contains two renaming entities using the same name, and a user tries to
4548 print the value of one of these entities, the result of the ada symbol
4549 lookup will also contain the wrong renaming type.
4551 This function partially covers for this limitation by attempting to
4552 remove from the SYMS list renaming symbols that should be visible
4553 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4554 method with the current information available. The implementation
4555 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4557 - When the user tries to print a rename in a function while there
4558 is another rename entity defined in a package: Normally, the
4559 rename in the function has precedence over the rename in the
4560 package, so the latter should be removed from the list. This is
4561 currently not the case.
4563 - This function will incorrectly remove valid renames if
4564 the CURRENT_BLOCK corresponds to a function which symbol name
4565 has been changed by an "Export" pragma. As a consequence,
4566 the user will be unable to print such rename entities. */
4569 remove_irrelevant_renamings (struct ada_symbol_info
*syms
,
4570 int nsyms
, const struct block
*current_block
)
4572 struct symbol
*current_function
;
4573 char *current_function_name
;
4575 int is_new_style_renaming
;
4577 /* If there is both a renaming foo___XR... encoded as a variable and
4578 a simple variable foo in the same block, discard the latter.
4579 First, zero out such symbols, then compress. */
4580 is_new_style_renaming
= 0;
4581 for (i
= 0; i
< nsyms
; i
+= 1)
4583 struct symbol
*sym
= syms
[i
].sym
;
4584 struct block
*block
= syms
[i
].block
;
4588 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
4590 name
= SYMBOL_LINKAGE_NAME (sym
);
4591 suffix
= strstr (name
, "___XR");
4595 int name_len
= suffix
- name
;
4598 is_new_style_renaming
= 1;
4599 for (j
= 0; j
< nsyms
; j
+= 1)
4600 if (i
!= j
&& syms
[j
].sym
!= NULL
4601 && strncmp (name
, SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
4603 && block
== syms
[j
].block
)
4607 if (is_new_style_renaming
)
4611 for (j
= k
= 0; j
< nsyms
; j
+= 1)
4612 if (syms
[j
].sym
!= NULL
)
4620 /* Extract the function name associated to CURRENT_BLOCK.
4621 Abort if unable to do so. */
4623 if (current_block
== NULL
)
4626 current_function
= block_linkage_function (current_block
);
4627 if (current_function
== NULL
)
4630 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4631 if (current_function_name
== NULL
)
4634 /* Check each of the symbols, and remove it from the list if it is
4635 a type corresponding to a renaming that is out of the scope of
4636 the current block. */
4641 if (ada_parse_renaming (syms
[i
].sym
, NULL
, NULL
, NULL
)
4642 == ADA_OBJECT_RENAMING
4643 && old_renaming_is_invisible (syms
[i
].sym
, current_function_name
))
4647 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4648 syms
[j
- 1] = syms
[j
];
4658 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4659 whose name and domain match NAME and DOMAIN respectively.
4660 If no match was found, then extend the search to "enclosing"
4661 routines (in other words, if we're inside a nested function,
4662 search the symbols defined inside the enclosing functions).
4664 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4667 ada_add_local_symbols (struct obstack
*obstackp
, const char *name
,
4668 struct block
*block
, domain_enum domain
,
4671 int block_depth
= 0;
4673 while (block
!= NULL
)
4676 ada_add_block_symbols (obstackp
, block
, name
, domain
, NULL
, wild_match
);
4678 /* If we found a non-function match, assume that's the one. */
4679 if (is_nonfunction (defns_collected (obstackp
, 0),
4680 num_defns_collected (obstackp
)))
4683 block
= BLOCK_SUPERBLOCK (block
);
4686 /* If no luck so far, try to find NAME as a local symbol in some lexically
4687 enclosing subprogram. */
4688 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
4689 add_symbols_from_enclosing_procs (obstackp
, name
, domain
, wild_match
);
4692 /* An object of this type is used as the user_data argument when
4693 calling the map_matching_symbols method. */
4697 struct objfile
*objfile
;
4698 struct obstack
*obstackp
;
4699 struct symbol
*arg_sym
;
4703 /* A callback for add_matching_symbols that adds SYM, found in BLOCK,
4704 to a list of symbols. DATA0 is a pointer to a struct match_data *
4705 containing the obstack that collects the symbol list, the file that SYM
4706 must come from, a flag indicating whether a non-argument symbol has
4707 been found in the current block, and the last argument symbol
4708 passed in SYM within the current block (if any). When SYM is null,
4709 marking the end of a block, the argument symbol is added if no
4710 other has been found. */
4713 aux_add_nonlocal_symbols (struct block
*block
, struct symbol
*sym
, void *data0
)
4715 struct match_data
*data
= (struct match_data
*) data0
;
4719 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
4720 add_defn_to_vec (data
->obstackp
,
4721 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
4723 data
->found_sym
= 0;
4724 data
->arg_sym
= NULL
;
4728 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
4730 else if (SYMBOL_IS_ARGUMENT (sym
))
4731 data
->arg_sym
= sym
;
4734 data
->found_sym
= 1;
4735 add_defn_to_vec (data
->obstackp
,
4736 fixup_symbol_section (sym
, data
->objfile
),
4743 /* Compare STRING1 to STRING2, with results as for strcmp.
4744 Compatible with strcmp_iw in that strcmp_iw (STRING1, STRING2) <= 0
4745 implies compare_names (STRING1, STRING2) (they may differ as to
4746 what symbols compare equal). */
4749 compare_names (const char *string1
, const char *string2
)
4751 while (*string1
!= '\0' && *string2
!= '\0')
4753 if (isspace (*string1
) || isspace (*string2
))
4754 return strcmp_iw_ordered (string1
, string2
);
4755 if (*string1
!= *string2
)
4763 return strcmp_iw_ordered (string1
, string2
);
4765 if (*string2
== '\0')
4767 if (is_name_suffix (string1
))
4774 if (*string2
== '(')
4775 return strcmp_iw_ordered (string1
, string2
);
4777 return *string1
- *string2
;
4781 /* Add to OBSTACKP all non-local symbols whose name and domain match
4782 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
4783 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
4786 add_nonlocal_symbols (struct obstack
*obstackp
, const char *name
,
4787 domain_enum domain
, int global
,
4790 struct objfile
*objfile
;
4791 struct match_data data
;
4793 data
.obstackp
= obstackp
;
4794 data
.arg_sym
= NULL
;
4796 ALL_OBJFILES (objfile
)
4798 data
.objfile
= objfile
;
4801 objfile
->sf
->qf
->map_matching_symbols (name
, domain
, objfile
, global
,
4802 aux_add_nonlocal_symbols
, &data
,
4805 objfile
->sf
->qf
->map_matching_symbols (name
, domain
, objfile
, global
,
4806 aux_add_nonlocal_symbols
, &data
,
4807 full_match
, compare_names
);
4810 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
4812 ALL_OBJFILES (objfile
)
4814 char *name1
= alloca (strlen (name
) + sizeof ("_ada_"));
4815 strcpy (name1
, "_ada_");
4816 strcpy (name1
+ sizeof ("_ada_") - 1, name
);
4817 data
.objfile
= objfile
;
4818 objfile
->sf
->qf
->map_matching_symbols (name1
, domain
,
4820 aux_add_nonlocal_symbols
,
4822 full_match
, compare_names
);
4827 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4828 scope and in global scopes, returning the number of matches. Sets
4829 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4830 indicating the symbols found and the blocks and symbol tables (if
4831 any) in which they were found. This vector are transient---good only to
4832 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4833 symbol match within the nest of blocks whose innermost member is BLOCK0,
4834 is the one match returned (no other matches in that or
4835 enclosing blocks is returned). If there are any matches in or
4836 surrounding BLOCK0, then these alone are returned. Otherwise, the
4837 search extends to global and file-scope (static) symbol tables.
4838 Names prefixed with "standard__" are handled specially: "standard__"
4839 is first stripped off, and only static and global symbols are searched. */
4842 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4843 domain_enum
namespace,
4844 struct ada_symbol_info
**results
)
4847 struct block
*block
;
4853 obstack_free (&symbol_list_obstack
, NULL
);
4854 obstack_init (&symbol_list_obstack
);
4858 /* Search specified block and its superiors. */
4860 wild_match
= (strstr (name0
, "__") == NULL
);
4862 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4863 needed, but adding const will
4864 have a cascade effect. */
4866 /* Special case: If the user specifies a symbol name inside package
4867 Standard, do a non-wild matching of the symbol name without
4868 the "standard__" prefix. This was primarily introduced in order
4869 to allow the user to specifically access the standard exceptions
4870 using, for instance, Standard.Constraint_Error when Constraint_Error
4871 is ambiguous (due to the user defining its own Constraint_Error
4872 entity inside its program). */
4873 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4877 name
= name0
+ sizeof ("standard__") - 1;
4880 /* Check the non-global symbols. If we have ANY match, then we're done. */
4882 ada_add_local_symbols (&symbol_list_obstack
, name
, block
, namespace,
4884 if (num_defns_collected (&symbol_list_obstack
) > 0)
4887 /* No non-global symbols found. Check our cache to see if we have
4888 already performed this search before. If we have, then return
4892 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
))
4895 add_defn_to_vec (&symbol_list_obstack
, sym
, block
);
4899 /* Search symbols from all global blocks. */
4901 add_nonlocal_symbols (&symbol_list_obstack
, name
, namespace, 1,
4904 /* Now add symbols from all per-file blocks if we've gotten no hits
4905 (not strictly correct, but perhaps better than an error). */
4907 if (num_defns_collected (&symbol_list_obstack
) == 0)
4908 add_nonlocal_symbols (&symbol_list_obstack
, name
, namespace, 0,
4912 ndefns
= num_defns_collected (&symbol_list_obstack
);
4913 *results
= defns_collected (&symbol_list_obstack
, 1);
4915 ndefns
= remove_extra_symbols (*results
, ndefns
);
4918 cache_symbol (name0
, namespace, NULL
, NULL
);
4920 if (ndefns
== 1 && cacheIfUnique
)
4921 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
);
4923 ndefns
= remove_irrelevant_renamings (*results
, ndefns
, block0
);
4929 ada_lookup_encoded_symbol (const char *name
, const struct block
*block0
,
4930 domain_enum
namespace, struct block
**block_found
)
4932 struct ada_symbol_info
*candidates
;
4935 n_candidates
= ada_lookup_symbol_list (name
, block0
, namespace, &candidates
);
4937 if (n_candidates
== 0)
4940 if (block_found
!= NULL
)
4941 *block_found
= candidates
[0].block
;
4943 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4946 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4947 scope and in global scopes, or NULL if none. NAME is folded and
4948 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4949 choosing the first symbol if there are multiple choices.
4950 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4951 table in which the symbol was found (in both cases, these
4952 assignments occur only if the pointers are non-null). */
4954 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4955 domain_enum
namespace, int *is_a_field_of_this
)
4957 if (is_a_field_of_this
!= NULL
)
4958 *is_a_field_of_this
= 0;
4961 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name
)),
4962 block0
, namespace, NULL
);
4965 static struct symbol
*
4966 ada_lookup_symbol_nonlocal (const char *name
,
4967 const struct block
*block
,
4968 const domain_enum domain
)
4970 return ada_lookup_symbol (name
, block_static_block (block
), domain
, NULL
);
4974 /* True iff STR is a possible encoded suffix of a normal Ada name
4975 that is to be ignored for matching purposes. Suffixes of parallel
4976 names (e.g., XVE) are not included here. Currently, the possible suffixes
4977 are given by any of the regular expressions:
4979 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
4980 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4981 _E[0-9]+[bs]$ [protected object entry suffixes]
4982 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4984 Also, any leading "__[0-9]+" sequence is skipped before the suffix
4985 match is performed. This sequence is used to differentiate homonyms,
4986 is an optional part of a valid name suffix. */
4989 is_name_suffix (const char *str
)
4992 const char *matching
;
4993 const int len
= strlen (str
);
4995 /* Skip optional leading __[0-9]+. */
4997 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5000 while (isdigit (str
[0]))
5006 if (str
[0] == '.' || str
[0] == '$')
5009 while (isdigit (matching
[0]))
5011 if (matching
[0] == '\0')
5017 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5020 while (isdigit (matching
[0]))
5022 if (matching
[0] == '\0')
5027 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5028 with a N at the end. Unfortunately, the compiler uses the same
5029 convention for other internal types it creates. So treating
5030 all entity names that end with an "N" as a name suffix causes
5031 some regressions. For instance, consider the case of an enumerated
5032 type. To support the 'Image attribute, it creates an array whose
5034 Having a single character like this as a suffix carrying some
5035 information is a bit risky. Perhaps we should change the encoding
5036 to be something like "_N" instead. In the meantime, do not do
5037 the following check. */
5038 /* Protected Object Subprograms */
5039 if (len
== 1 && str
[0] == 'N')
5044 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5047 while (isdigit (matching
[0]))
5049 if ((matching
[0] == 'b' || matching
[0] == 's')
5050 && matching
[1] == '\0')
5054 /* ??? We should not modify STR directly, as we are doing below. This
5055 is fine in this case, but may become problematic later if we find
5056 that this alternative did not work, and want to try matching
5057 another one from the begining of STR. Since we modified it, we
5058 won't be able to find the begining of the string anymore! */
5062 while (str
[0] != '_' && str
[0] != '\0')
5064 if (str
[0] != 'n' && str
[0] != 'b')
5070 if (str
[0] == '\000')
5075 if (str
[1] != '_' || str
[2] == '\000')
5079 if (strcmp (str
+ 3, "JM") == 0)
5081 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5082 the LJM suffix in favor of the JM one. But we will
5083 still accept LJM as a valid suffix for a reasonable
5084 amount of time, just to allow ourselves to debug programs
5085 compiled using an older version of GNAT. */
5086 if (strcmp (str
+ 3, "LJM") == 0)
5090 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5091 || str
[4] == 'U' || str
[4] == 'P')
5093 if (str
[4] == 'R' && str
[5] != 'T')
5097 if (!isdigit (str
[2]))
5099 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5100 if (!isdigit (str
[k
]) && str
[k
] != '_')
5104 if (str
[0] == '$' && isdigit (str
[1]))
5106 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5107 if (!isdigit (str
[k
]) && str
[k
] != '_')
5114 /* Return non-zero if the string starting at NAME and ending before
5115 NAME_END contains no capital letters. */
5118 is_valid_name_for_wild_match (const char *name0
)
5120 const char *decoded_name
= ada_decode (name0
);
5123 /* If the decoded name starts with an angle bracket, it means that
5124 NAME0 does not follow the GNAT encoding format. It should then
5125 not be allowed as a possible wild match. */
5126 if (decoded_name
[0] == '<')
5129 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5130 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5136 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5137 that could start a simple name. Assumes that *NAMEP points into
5138 the string beginning at NAME0. */
5141 advance_wild_match (const char **namep
, const char *name0
, int target0
)
5143 const char *name
= *namep
;
5153 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
5156 if (name
== name0
+ 5 && strncmp (name0
, "_ada", 4) == 0)
5161 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
5162 || name
[2] == target0
))
5170 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
5180 /* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5181 informational suffixes of NAME (i.e., for which is_name_suffix is
5182 true). Assumes that PATN is a lower-cased Ada simple name. */
5185 wild_match (const char *name
, const char *patn
)
5188 const char *name0
= name
;
5192 const char *match
= name
;
5196 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
5199 if (*p
== '\0' && is_name_suffix (name
))
5200 return match
!= name0
&& !is_valid_name_for_wild_match (name0
);
5202 if (name
[-1] == '_')
5205 if (!advance_wild_match (&name
, name0
, *patn
))
5210 /* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5211 informational suffix. */
5214 full_match (const char *sym_name
, const char *search_name
)
5216 return !match_name (sym_name
, search_name
, 0);
5220 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5221 vector *defn_symbols, updating the list of symbols in OBSTACKP
5222 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5223 OBJFILE is the section containing BLOCK.
5224 SYMTAB is recorded with each symbol added. */
5227 ada_add_block_symbols (struct obstack
*obstackp
,
5228 struct block
*block
, const char *name
,
5229 domain_enum domain
, struct objfile
*objfile
,
5232 struct dict_iterator iter
;
5233 int name_len
= strlen (name
);
5234 /* A matching argument symbol, if any. */
5235 struct symbol
*arg_sym
;
5236 /* Set true when we find a matching non-argument symbol. */
5244 for (sym
= dict_iter_match_first (BLOCK_DICT (block
), name
,
5246 sym
!= NULL
; sym
= dict_iter_match_next (name
, wild_match
, &iter
))
5248 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5249 SYMBOL_DOMAIN (sym
), domain
)
5250 && wild_match (SYMBOL_LINKAGE_NAME (sym
), name
) == 0)
5252 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5254 else if (SYMBOL_IS_ARGUMENT (sym
))
5259 add_defn_to_vec (obstackp
,
5260 fixup_symbol_section (sym
, objfile
),
5268 for (sym
= dict_iter_match_first (BLOCK_DICT (block
), name
,
5270 sym
!= NULL
; sym
= dict_iter_match_next (name
, full_match
, &iter
))
5272 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5273 SYMBOL_DOMAIN (sym
), domain
))
5275 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5277 if (SYMBOL_IS_ARGUMENT (sym
))
5282 add_defn_to_vec (obstackp
,
5283 fixup_symbol_section (sym
, objfile
),
5291 if (!found_sym
&& arg_sym
!= NULL
)
5293 add_defn_to_vec (obstackp
,
5294 fixup_symbol_section (arg_sym
, objfile
),
5303 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5305 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5306 SYMBOL_DOMAIN (sym
), domain
))
5310 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5313 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5315 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5320 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5322 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5324 if (SYMBOL_IS_ARGUMENT (sym
))
5329 add_defn_to_vec (obstackp
,
5330 fixup_symbol_section (sym
, objfile
),
5338 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5339 They aren't parameters, right? */
5340 if (!found_sym
&& arg_sym
!= NULL
)
5342 add_defn_to_vec (obstackp
,
5343 fixup_symbol_section (arg_sym
, objfile
),
5350 /* Symbol Completion */
5352 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5353 name in a form that's appropriate for the completion. The result
5354 does not need to be deallocated, but is only good until the next call.
5356 TEXT_LEN is equal to the length of TEXT.
5357 Perform a wild match if WILD_MATCH is set.
5358 ENCODED should be set if TEXT represents the start of a symbol name
5359 in its encoded form. */
5362 symbol_completion_match (const char *sym_name
,
5363 const char *text
, int text_len
,
5364 int wild_match
, int encoded
)
5366 const int verbatim_match
= (text
[0] == '<');
5371 /* Strip the leading angle bracket. */
5376 /* First, test against the fully qualified name of the symbol. */
5378 if (strncmp (sym_name
, text
, text_len
) == 0)
5381 if (match
&& !encoded
)
5383 /* One needed check before declaring a positive match is to verify
5384 that iff we are doing a verbatim match, the decoded version
5385 of the symbol name starts with '<'. Otherwise, this symbol name
5386 is not a suitable completion. */
5387 const char *sym_name_copy
= sym_name
;
5388 int has_angle_bracket
;
5390 sym_name
= ada_decode (sym_name
);
5391 has_angle_bracket
= (sym_name
[0] == '<');
5392 match
= (has_angle_bracket
== verbatim_match
);
5393 sym_name
= sym_name_copy
;
5396 if (match
&& !verbatim_match
)
5398 /* When doing non-verbatim match, another check that needs to
5399 be done is to verify that the potentially matching symbol name
5400 does not include capital letters, because the ada-mode would
5401 not be able to understand these symbol names without the
5402 angle bracket notation. */
5405 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
5410 /* Second: Try wild matching... */
5412 if (!match
&& wild_match
)
5414 /* Since we are doing wild matching, this means that TEXT
5415 may represent an unqualified symbol name. We therefore must
5416 also compare TEXT against the unqualified name of the symbol. */
5417 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
5419 if (strncmp (sym_name
, text
, text_len
) == 0)
5423 /* Finally: If we found a mach, prepare the result to return. */
5429 sym_name
= add_angle_brackets (sym_name
);
5432 sym_name
= ada_decode (sym_name
);
5437 DEF_VEC_P (char_ptr
);
5439 /* A companion function to ada_make_symbol_completion_list().
5440 Check if SYM_NAME represents a symbol which name would be suitable
5441 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5442 it is appended at the end of the given string vector SV.
5444 ORIG_TEXT is the string original string from the user command
5445 that needs to be completed. WORD is the entire command on which
5446 completion should be performed. These two parameters are used to
5447 determine which part of the symbol name should be added to the
5449 if WILD_MATCH is set, then wild matching is performed.
5450 ENCODED should be set if TEXT represents a symbol name in its
5451 encoded formed (in which case the completion should also be
5455 symbol_completion_add (VEC(char_ptr
) **sv
,
5456 const char *sym_name
,
5457 const char *text
, int text_len
,
5458 const char *orig_text
, const char *word
,
5459 int wild_match
, int encoded
)
5461 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
5462 wild_match
, encoded
);
5468 /* We found a match, so add the appropriate completion to the given
5471 if (word
== orig_text
)
5473 completion
= xmalloc (strlen (match
) + 5);
5474 strcpy (completion
, match
);
5476 else if (word
> orig_text
)
5478 /* Return some portion of sym_name. */
5479 completion
= xmalloc (strlen (match
) + 5);
5480 strcpy (completion
, match
+ (word
- orig_text
));
5484 /* Return some of ORIG_TEXT plus sym_name. */
5485 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
5486 strncpy (completion
, word
, orig_text
- word
);
5487 completion
[orig_text
- word
] = '\0';
5488 strcat (completion
, match
);
5491 VEC_safe_push (char_ptr
, *sv
, completion
);
5494 /* An object of this type is passed as the user_data argument to the
5495 expand_partial_symbol_names method. */
5496 struct add_partial_datum
5498 VEC(char_ptr
) **completions
;
5507 /* A callback for expand_partial_symbol_names. */
5509 ada_expand_partial_symbol_name (const char *name
, void *user_data
)
5511 struct add_partial_datum
*data
= user_data
;
5513 return symbol_completion_match (name
, data
->text
, data
->text_len
,
5514 data
->wild_match
, data
->encoded
) != NULL
;
5517 /* Return a list of possible symbol names completing TEXT0. The list
5518 is NULL terminated. WORD is the entire command on which completion
5522 ada_make_symbol_completion_list (char *text0
, char *word
)
5528 VEC(char_ptr
) *completions
= VEC_alloc (char_ptr
, 128);
5531 struct minimal_symbol
*msymbol
;
5532 struct objfile
*objfile
;
5533 struct block
*b
, *surrounding_static_block
= 0;
5535 struct dict_iterator iter
;
5537 if (text0
[0] == '<')
5539 text
= xstrdup (text0
);
5540 make_cleanup (xfree
, text
);
5541 text_len
= strlen (text
);
5547 text
= xstrdup (ada_encode (text0
));
5548 make_cleanup (xfree
, text
);
5549 text_len
= strlen (text
);
5550 for (i
= 0; i
< text_len
; i
++)
5551 text
[i
] = tolower (text
[i
]);
5553 encoded
= (strstr (text0
, "__") != NULL
);
5554 /* If the name contains a ".", then the user is entering a fully
5555 qualified entity name, and the match must not be done in wild
5556 mode. Similarly, if the user wants to complete what looks like
5557 an encoded name, the match must not be done in wild mode. */
5558 wild_match
= (strchr (text0
, '.') == NULL
&& !encoded
);
5561 /* First, look at the partial symtab symbols. */
5563 struct add_partial_datum data
;
5565 data
.completions
= &completions
;
5567 data
.text_len
= text_len
;
5570 data
.wild_match
= wild_match
;
5571 data
.encoded
= encoded
;
5572 expand_partial_symbol_names (ada_expand_partial_symbol_name
, &data
);
5575 /* At this point scan through the misc symbol vectors and add each
5576 symbol you find to the list. Eventually we want to ignore
5577 anything that isn't a text symbol (everything else will be
5578 handled by the psymtab code above). */
5580 ALL_MSYMBOLS (objfile
, msymbol
)
5583 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (msymbol
),
5584 text
, text_len
, text0
, word
, wild_match
, encoded
);
5587 /* Search upwards from currently selected frame (so that we can
5588 complete on local vars. */
5590 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
5592 if (!BLOCK_SUPERBLOCK (b
))
5593 surrounding_static_block
= b
; /* For elmin of dups */
5595 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5597 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5598 text
, text_len
, text0
, word
,
5599 wild_match
, encoded
);
5603 /* Go through the symtabs and check the externs and statics for
5604 symbols which match. */
5606 ALL_SYMTABS (objfile
, s
)
5609 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
5610 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5612 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5613 text
, text_len
, text0
, word
,
5614 wild_match
, encoded
);
5618 ALL_SYMTABS (objfile
, s
)
5621 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
5622 /* Don't do this block twice. */
5623 if (b
== surrounding_static_block
)
5625 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5627 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5628 text
, text_len
, text0
, word
,
5629 wild_match
, encoded
);
5633 /* Append the closing NULL entry. */
5634 VEC_safe_push (char_ptr
, completions
, NULL
);
5636 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5637 return the copy. It's unfortunate that we have to make a copy
5638 of an array that we're about to destroy, but there is nothing much
5639 we can do about it. Fortunately, it's typically not a very large
5642 const size_t completions_size
=
5643 VEC_length (char_ptr
, completions
) * sizeof (char *);
5644 char **result
= xmalloc (completions_size
);
5646 memcpy (result
, VEC_address (char_ptr
, completions
), completions_size
);
5648 VEC_free (char_ptr
, completions
);
5655 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5656 for tagged types. */
5659 ada_is_dispatch_table_ptr_type (struct type
*type
)
5663 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
5666 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
5670 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
5673 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5674 to be invisible to users. */
5677 ada_is_ignored_field (struct type
*type
, int field_num
)
5679 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5682 /* Check the name of that field. */
5684 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5686 /* Anonymous field names should not be printed.
5687 brobecker/2007-02-20: I don't think this can actually happen
5688 but we don't want to print the value of annonymous fields anyway. */
5692 /* A field named "_parent" is internally generated by GNAT for
5693 tagged types, and should not be printed either. */
5694 if (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0)
5698 /* If this is the dispatch table of a tagged type, then ignore. */
5699 if (ada_is_tagged_type (type
, 1)
5700 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
)))
5703 /* Not a special field, so it should not be ignored. */
5707 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5708 pointer or reference type whose ultimate target has a tag field. */
5711 ada_is_tagged_type (struct type
*type
, int refok
)
5713 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
5716 /* True iff TYPE represents the type of X'Tag */
5719 ada_is_tag_type (struct type
*type
)
5721 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
5725 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
5727 return (name
!= NULL
5728 && strcmp (name
, "ada__tags__dispatch_table") == 0);
5732 /* The type of the tag on VAL. */
5735 ada_tag_type (struct value
*val
)
5737 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
5740 /* The value of the tag on VAL. */
5743 ada_value_tag (struct value
*val
)
5745 return ada_value_struct_elt (val
, "_tag", 0);
5748 /* The value of the tag on the object of type TYPE whose contents are
5749 saved at VALADDR, if it is non-null, or is at memory address
5752 static struct value
*
5753 value_tag_from_contents_and_address (struct type
*type
,
5754 const gdb_byte
*valaddr
,
5757 int tag_byte_offset
;
5758 struct type
*tag_type
;
5760 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5763 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
5765 : valaddr
+ tag_byte_offset
);
5766 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5768 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5773 static struct type
*
5774 type_from_tag (struct value
*tag
)
5776 const char *type_name
= ada_tag_name (tag
);
5778 if (type_name
!= NULL
)
5779 return ada_find_any_type (ada_encode (type_name
));
5790 static int ada_tag_name_1 (void *);
5791 static int ada_tag_name_2 (struct tag_args
*);
5793 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5794 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5795 The value stored in ARGS->name is valid until the next call to
5799 ada_tag_name_1 (void *args0
)
5801 struct tag_args
*args
= (struct tag_args
*) args0
;
5802 static char name
[1024];
5807 val
= ada_value_struct_elt (args
->tag
, "tsd", 1);
5809 return ada_tag_name_2 (args
);
5810 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5813 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5814 for (p
= name
; *p
!= '\0'; p
+= 1)
5821 /* Return the "ada__tags__type_specific_data" type. */
5823 static struct type
*
5824 ada_get_tsd_type (struct inferior
*inf
)
5826 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
5828 if (data
->tsd_type
== 0)
5829 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
5830 return data
->tsd_type
;
5833 /* Utility function for ada_tag_name_1 that tries the second
5834 representation for the dispatch table (in which there is no
5835 explicit 'tsd' field in the referent of the tag pointer, and instead
5836 the tsd pointer is stored just before the dispatch table. */
5839 ada_tag_name_2 (struct tag_args
*args
)
5841 struct type
*info_type
;
5842 static char name
[1024];
5844 struct value
*val
, *valp
;
5847 info_type
= ada_get_tsd_type (current_inferior());
5848 if (info_type
== NULL
)
5850 info_type
= lookup_pointer_type (lookup_pointer_type (info_type
));
5851 valp
= value_cast (info_type
, args
->tag
);
5854 val
= value_ind (value_ptradd (valp
, -1));
5857 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5860 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5861 for (p
= name
; *p
!= '\0'; p
+= 1)
5868 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5872 ada_tag_name (struct value
*tag
)
5874 struct tag_args args
;
5876 if (!ada_is_tag_type (value_type (tag
)))
5880 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5884 /* The parent type of TYPE, or NULL if none. */
5887 ada_parent_type (struct type
*type
)
5891 type
= ada_check_typedef (type
);
5893 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5896 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5897 if (ada_is_parent_field (type
, i
))
5899 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
5901 /* If the _parent field is a pointer, then dereference it. */
5902 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
5903 parent_type
= TYPE_TARGET_TYPE (parent_type
);
5904 /* If there is a parallel XVS type, get the actual base type. */
5905 parent_type
= ada_get_base_type (parent_type
);
5907 return ada_check_typedef (parent_type
);
5913 /* True iff field number FIELD_NUM of structure type TYPE contains the
5914 parent-type (inherited) fields of a derived type. Assumes TYPE is
5915 a structure type with at least FIELD_NUM+1 fields. */
5918 ada_is_parent_field (struct type
*type
, int field_num
)
5920 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5922 return (name
!= NULL
5923 && (strncmp (name
, "PARENT", 6) == 0
5924 || strncmp (name
, "_parent", 7) == 0));
5927 /* True iff field number FIELD_NUM of structure type TYPE is a
5928 transparent wrapper field (which should be silently traversed when doing
5929 field selection and flattened when printing). Assumes TYPE is a
5930 structure type with at least FIELD_NUM+1 fields. Such fields are always
5934 ada_is_wrapper_field (struct type
*type
, int field_num
)
5936 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5938 return (name
!= NULL
5939 && (strncmp (name
, "PARENT", 6) == 0
5940 || strcmp (name
, "REP") == 0
5941 || strncmp (name
, "_parent", 7) == 0
5942 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5945 /* True iff field number FIELD_NUM of structure or union type TYPE
5946 is a variant wrapper. Assumes TYPE is a structure type with at least
5947 FIELD_NUM+1 fields. */
5950 ada_is_variant_part (struct type
*type
, int field_num
)
5952 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5954 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5955 || (is_dynamic_field (type
, field_num
)
5956 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5957 == TYPE_CODE_UNION
)));
5960 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5961 whose discriminants are contained in the record type OUTER_TYPE,
5962 returns the type of the controlling discriminant for the variant.
5963 May return NULL if the type could not be found. */
5966 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5968 char *name
= ada_variant_discrim_name (var_type
);
5970 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5973 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5974 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5975 represents a 'when others' clause; otherwise 0. */
5978 ada_is_others_clause (struct type
*type
, int field_num
)
5980 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5982 return (name
!= NULL
&& name
[0] == 'O');
5985 /* Assuming that TYPE0 is the type of the variant part of a record,
5986 returns the name of the discriminant controlling the variant.
5987 The value is valid until the next call to ada_variant_discrim_name. */
5990 ada_variant_discrim_name (struct type
*type0
)
5992 static char *result
= NULL
;
5993 static size_t result_len
= 0;
5996 const char *discrim_end
;
5997 const char *discrim_start
;
5999 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
6000 type
= TYPE_TARGET_TYPE (type0
);
6004 name
= ada_type_name (type
);
6006 if (name
== NULL
|| name
[0] == '\000')
6009 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6012 if (strncmp (discrim_end
, "___XVN", 6) == 0)
6015 if (discrim_end
== name
)
6018 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6021 if (discrim_start
== name
+ 1)
6023 if ((discrim_start
> name
+ 3
6024 && strncmp (discrim_start
- 3, "___", 3) == 0)
6025 || discrim_start
[-1] == '.')
6029 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6030 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6031 result
[discrim_end
- discrim_start
] = '\0';
6035 /* Scan STR for a subtype-encoded number, beginning at position K.
6036 Put the position of the character just past the number scanned in
6037 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6038 Return 1 if there was a valid number at the given position, and 0
6039 otherwise. A "subtype-encoded" number consists of the absolute value
6040 in decimal, followed by the letter 'm' to indicate a negative number.
6041 Assumes 0m does not occur. */
6044 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6048 if (!isdigit (str
[k
]))
6051 /* Do it the hard way so as not to make any assumption about
6052 the relationship of unsigned long (%lu scan format code) and
6055 while (isdigit (str
[k
]))
6057 RU
= RU
* 10 + (str
[k
] - '0');
6064 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6070 /* NOTE on the above: Technically, C does not say what the results of
6071 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6072 number representable as a LONGEST (although either would probably work
6073 in most implementations). When RU>0, the locution in the then branch
6074 above is always equivalent to the negative of RU. */
6081 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6082 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6083 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6086 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6088 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6102 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6112 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6113 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6115 if (val
>= L
&& val
<= U
)
6127 /* FIXME: Lots of redundancy below. Try to consolidate. */
6129 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6130 ARG_TYPE, extract and return the value of one of its (non-static)
6131 fields. FIELDNO says which field. Differs from value_primitive_field
6132 only in that it can handle packed values of arbitrary type. */
6134 static struct value
*
6135 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6136 struct type
*arg_type
)
6140 arg_type
= ada_check_typedef (arg_type
);
6141 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
6143 /* Handle packed fields. */
6145 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
6147 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6148 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6150 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6151 offset
+ bit_pos
/ 8,
6152 bit_pos
% 8, bit_size
, type
);
6155 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6158 /* Find field with name NAME in object of type TYPE. If found,
6159 set the following for each argument that is non-null:
6160 - *FIELD_TYPE_P to the field's type;
6161 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6162 an object of that type;
6163 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6164 - *BIT_SIZE_P to its size in bits if the field is packed, and
6166 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6167 fields up to but not including the desired field, or by the total
6168 number of fields if not found. A NULL value of NAME never
6169 matches; the function just counts visible fields in this case.
6171 Returns 1 if found, 0 otherwise. */
6174 find_struct_field (char *name
, struct type
*type
, int offset
,
6175 struct type
**field_type_p
,
6176 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
6181 type
= ada_check_typedef (type
);
6183 if (field_type_p
!= NULL
)
6184 *field_type_p
= NULL
;
6185 if (byte_offset_p
!= NULL
)
6187 if (bit_offset_p
!= NULL
)
6189 if (bit_size_p
!= NULL
)
6192 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6194 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6195 int fld_offset
= offset
+ bit_pos
/ 8;
6196 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6198 if (t_field_name
== NULL
)
6201 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
6203 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6205 if (field_type_p
!= NULL
)
6206 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6207 if (byte_offset_p
!= NULL
)
6208 *byte_offset_p
= fld_offset
;
6209 if (bit_offset_p
!= NULL
)
6210 *bit_offset_p
= bit_pos
% 8;
6211 if (bit_size_p
!= NULL
)
6212 *bit_size_p
= bit_size
;
6215 else if (ada_is_wrapper_field (type
, i
))
6217 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6218 field_type_p
, byte_offset_p
, bit_offset_p
,
6219 bit_size_p
, index_p
))
6222 else if (ada_is_variant_part (type
, i
))
6224 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6227 struct type
*field_type
6228 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6230 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6232 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
6234 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6235 field_type_p
, byte_offset_p
,
6236 bit_offset_p
, bit_size_p
, index_p
))
6240 else if (index_p
!= NULL
)
6246 /* Number of user-visible fields in record type TYPE. */
6249 num_visible_fields (struct type
*type
)
6254 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
6258 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6259 and search in it assuming it has (class) type TYPE.
6260 If found, return value, else return NULL.
6262 Searches recursively through wrapper fields (e.g., '_parent'). */
6264 static struct value
*
6265 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
6270 type
= ada_check_typedef (type
);
6271 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6273 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6275 if (t_field_name
== NULL
)
6278 else if (field_name_match (t_field_name
, name
))
6279 return ada_value_primitive_field (arg
, offset
, i
, type
);
6281 else if (ada_is_wrapper_field (type
, i
))
6283 struct value
*v
= /* Do not let indent join lines here. */
6284 ada_search_struct_field (name
, arg
,
6285 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6286 TYPE_FIELD_TYPE (type
, i
));
6292 else if (ada_is_variant_part (type
, i
))
6294 /* PNH: Do we ever get here? See find_struct_field. */
6296 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
6298 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6300 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6302 struct value
*v
= ada_search_struct_field
/* Force line
6305 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6306 TYPE_FIELD_TYPE (field_type
, j
));
6316 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
6317 int, struct type
*);
6320 /* Return field #INDEX in ARG, where the index is that returned by
6321 * find_struct_field through its INDEX_P argument. Adjust the address
6322 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6323 * If found, return value, else return NULL. */
6325 static struct value
*
6326 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
6329 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
6333 /* Auxiliary function for ada_index_struct_field. Like
6334 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6337 static struct value
*
6338 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
6342 type
= ada_check_typedef (type
);
6344 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6346 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
6348 else if (ada_is_wrapper_field (type
, i
))
6350 struct value
*v
= /* Do not let indent join lines here. */
6351 ada_index_struct_field_1 (index_p
, arg
,
6352 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6353 TYPE_FIELD_TYPE (type
, i
));
6359 else if (ada_is_variant_part (type
, i
))
6361 /* PNH: Do we ever get here? See ada_search_struct_field,
6362 find_struct_field. */
6363 error (_("Cannot assign this kind of variant record"));
6365 else if (*index_p
== 0)
6366 return ada_value_primitive_field (arg
, offset
, i
, type
);
6373 /* Given ARG, a value of type (pointer or reference to a)*
6374 structure/union, extract the component named NAME from the ultimate
6375 target structure/union and return it as a value with its
6378 The routine searches for NAME among all members of the structure itself
6379 and (recursively) among all members of any wrapper members
6382 If NO_ERR, then simply return NULL in case of error, rather than
6386 ada_value_struct_elt (struct value
*arg
, char *name
, int no_err
)
6388 struct type
*t
, *t1
;
6392 t1
= t
= ada_check_typedef (value_type (arg
));
6393 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6395 t1
= TYPE_TARGET_TYPE (t
);
6398 t1
= ada_check_typedef (t1
);
6399 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6401 arg
= coerce_ref (arg
);
6406 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6408 t1
= TYPE_TARGET_TYPE (t
);
6411 t1
= ada_check_typedef (t1
);
6412 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6414 arg
= value_ind (arg
);
6421 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
6425 v
= ada_search_struct_field (name
, arg
, 0, t
);
6428 int bit_offset
, bit_size
, byte_offset
;
6429 struct type
*field_type
;
6432 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6433 address
= value_as_address (arg
);
6435 address
= unpack_pointer (t
, value_contents (arg
));
6437 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
, 1);
6438 if (find_struct_field (name
, t1
, 0,
6439 &field_type
, &byte_offset
, &bit_offset
,
6444 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6445 arg
= ada_coerce_ref (arg
);
6447 arg
= ada_value_ind (arg
);
6448 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
6449 bit_offset
, bit_size
,
6453 v
= value_at_lazy (field_type
, address
+ byte_offset
);
6457 if (v
!= NULL
|| no_err
)
6460 error (_("There is no member named %s."), name
);
6466 error (_("Attempt to extract a component of "
6467 "a value that is not a record."));
6470 /* Given a type TYPE, look up the type of the component of type named NAME.
6471 If DISPP is non-null, add its byte displacement from the beginning of a
6472 structure (pointed to by a value) of type TYPE to *DISPP (does not
6473 work for packed fields).
6475 Matches any field whose name has NAME as a prefix, possibly
6478 TYPE can be either a struct or union. If REFOK, TYPE may also
6479 be a (pointer or reference)+ to a struct or union, and the
6480 ultimate target type will be searched.
6482 Looks recursively into variant clauses and parent types.
6484 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6485 TYPE is not a type of the right kind. */
6487 static struct type
*
6488 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
6489 int noerr
, int *dispp
)
6496 if (refok
&& type
!= NULL
)
6499 type
= ada_check_typedef (type
);
6500 if (TYPE_CODE (type
) != TYPE_CODE_PTR
6501 && TYPE_CODE (type
) != TYPE_CODE_REF
)
6503 type
= TYPE_TARGET_TYPE (type
);
6507 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
6508 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
6514 target_terminal_ours ();
6515 gdb_flush (gdb_stdout
);
6517 error (_("Type (null) is not a structure or union type"));
6520 /* XXX: type_sprint */
6521 fprintf_unfiltered (gdb_stderr
, _("Type "));
6522 type_print (type
, "", gdb_stderr
, -1);
6523 error (_(" is not a structure or union type"));
6528 type
= to_static_fixed_type (type
);
6530 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6532 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6536 if (t_field_name
== NULL
)
6539 else if (field_name_match (t_field_name
, name
))
6542 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
6543 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6546 else if (ada_is_wrapper_field (type
, i
))
6549 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
6554 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6559 else if (ada_is_variant_part (type
, i
))
6562 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
6565 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
6567 /* FIXME pnh 2008/01/26: We check for a field that is
6568 NOT wrapped in a struct, since the compiler sometimes
6569 generates these for unchecked variant types. Revisit
6570 if the compiler changes this practice. */
6571 char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
6573 if (v_field_name
!= NULL
6574 && field_name_match (v_field_name
, name
))
6575 t
= ada_check_typedef (TYPE_FIELD_TYPE (field_type
, j
));
6577 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
,
6584 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6595 target_terminal_ours ();
6596 gdb_flush (gdb_stdout
);
6599 /* XXX: type_sprint */
6600 fprintf_unfiltered (gdb_stderr
, _("Type "));
6601 type_print (type
, "", gdb_stderr
, -1);
6602 error (_(" has no component named <null>"));
6606 /* XXX: type_sprint */
6607 fprintf_unfiltered (gdb_stderr
, _("Type "));
6608 type_print (type
, "", gdb_stderr
, -1);
6609 error (_(" has no component named %s"), name
);
6616 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6617 within a value of type OUTER_TYPE, return true iff VAR_TYPE
6618 represents an unchecked union (that is, the variant part of a
6619 record that is named in an Unchecked_Union pragma). */
6622 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
6624 char *discrim_name
= ada_variant_discrim_name (var_type
);
6626 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1, NULL
)
6631 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6632 within a value of type OUTER_TYPE that is stored in GDB at
6633 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6634 numbering from 0) is applicable. Returns -1 if none are. */
6637 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
6638 const gdb_byte
*outer_valaddr
)
6642 char *discrim_name
= ada_variant_discrim_name (var_type
);
6643 struct value
*outer
;
6644 struct value
*discrim
;
6645 LONGEST discrim_val
;
6647 outer
= value_from_contents_and_address (outer_type
, outer_valaddr
, 0);
6648 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
6649 if (discrim
== NULL
)
6651 discrim_val
= value_as_long (discrim
);
6654 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
6656 if (ada_is_others_clause (var_type
, i
))
6658 else if (ada_in_variant (discrim_val
, var_type
, i
))
6662 return others_clause
;
6667 /* Dynamic-Sized Records */
6669 /* Strategy: The type ostensibly attached to a value with dynamic size
6670 (i.e., a size that is not statically recorded in the debugging
6671 data) does not accurately reflect the size or layout of the value.
6672 Our strategy is to convert these values to values with accurate,
6673 conventional types that are constructed on the fly. */
6675 /* There is a subtle and tricky problem here. In general, we cannot
6676 determine the size of dynamic records without its data. However,
6677 the 'struct value' data structure, which GDB uses to represent
6678 quantities in the inferior process (the target), requires the size
6679 of the type at the time of its allocation in order to reserve space
6680 for GDB's internal copy of the data. That's why the
6681 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6682 rather than struct value*s.
6684 However, GDB's internal history variables ($1, $2, etc.) are
6685 struct value*s containing internal copies of the data that are not, in
6686 general, the same as the data at their corresponding addresses in
6687 the target. Fortunately, the types we give to these values are all
6688 conventional, fixed-size types (as per the strategy described
6689 above), so that we don't usually have to perform the
6690 'to_fixed_xxx_type' conversions to look at their values.
6691 Unfortunately, there is one exception: if one of the internal
6692 history variables is an array whose elements are unconstrained
6693 records, then we will need to create distinct fixed types for each
6694 element selected. */
6696 /* The upshot of all of this is that many routines take a (type, host
6697 address, target address) triple as arguments to represent a value.
6698 The host address, if non-null, is supposed to contain an internal
6699 copy of the relevant data; otherwise, the program is to consult the
6700 target at the target address. */
6702 /* Assuming that VAL0 represents a pointer value, the result of
6703 dereferencing it. Differs from value_ind in its treatment of
6704 dynamic-sized types. */
6707 ada_value_ind (struct value
*val0
)
6709 struct value
*val
= unwrap_value (value_ind (val0
));
6711 return ada_to_fixed_value (val
);
6714 /* The value resulting from dereferencing any "reference to"
6715 qualifiers on VAL0. */
6717 static struct value
*
6718 ada_coerce_ref (struct value
*val0
)
6720 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
6722 struct value
*val
= val0
;
6724 val
= coerce_ref (val
);
6725 val
= unwrap_value (val
);
6726 return ada_to_fixed_value (val
);
6732 /* Return OFF rounded upward if necessary to a multiple of
6733 ALIGNMENT (a power of 2). */
6736 align_value (unsigned int off
, unsigned int alignment
)
6738 return (off
+ alignment
- 1) & ~(alignment
- 1);
6741 /* Return the bit alignment required for field #F of template type TYPE. */
6744 field_alignment (struct type
*type
, int f
)
6746 const char *name
= TYPE_FIELD_NAME (type
, f
);
6750 /* The field name should never be null, unless the debugging information
6751 is somehow malformed. In this case, we assume the field does not
6752 require any alignment. */
6756 len
= strlen (name
);
6758 if (!isdigit (name
[len
- 1]))
6761 if (isdigit (name
[len
- 2]))
6762 align_offset
= len
- 2;
6764 align_offset
= len
- 1;
6766 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
6767 return TARGET_CHAR_BIT
;
6769 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
6772 /* Find a symbol named NAME. Ignores ambiguity. */
6775 ada_find_any_symbol (const char *name
)
6779 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
6780 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
6783 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
6787 /* Find a type named NAME. Ignores ambiguity. This routine will look
6788 solely for types defined by debug info, it will not search the GDB
6792 ada_find_any_type (const char *name
)
6794 struct symbol
*sym
= ada_find_any_symbol (name
);
6797 return SYMBOL_TYPE (sym
);
6802 /* Given NAME and an associated BLOCK, search all symbols for
6803 NAME suffixed with "___XR", which is the ``renaming'' symbol
6804 associated to NAME. Return this symbol if found, return
6808 ada_find_renaming_symbol (const char *name
, struct block
*block
)
6812 sym
= find_old_style_renaming_symbol (name
, block
);
6817 /* Not right yet. FIXME pnh 7/20/2007. */
6818 sym
= ada_find_any_symbol (name
);
6819 if (sym
!= NULL
&& strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR") != NULL
)
6825 static struct symbol
*
6826 find_old_style_renaming_symbol (const char *name
, struct block
*block
)
6828 const struct symbol
*function_sym
= block_linkage_function (block
);
6831 if (function_sym
!= NULL
)
6833 /* If the symbol is defined inside a function, NAME is not fully
6834 qualified. This means we need to prepend the function name
6835 as well as adding the ``___XR'' suffix to build the name of
6836 the associated renaming symbol. */
6837 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
6838 /* Function names sometimes contain suffixes used
6839 for instance to qualify nested subprograms. When building
6840 the XR type name, we need to make sure that this suffix is
6841 not included. So do not include any suffix in the function
6842 name length below. */
6843 int function_name_len
= ada_name_prefix_len (function_name
);
6844 const int rename_len
= function_name_len
+ 2 /* "__" */
6845 + strlen (name
) + 6 /* "___XR\0" */ ;
6847 /* Strip the suffix if necessary. */
6848 ada_remove_trailing_digits (function_name
, &function_name_len
);
6849 ada_remove_po_subprogram_suffix (function_name
, &function_name_len
);
6850 ada_remove_Xbn_suffix (function_name
, &function_name_len
);
6852 /* Library-level functions are a special case, as GNAT adds
6853 a ``_ada_'' prefix to the function name to avoid namespace
6854 pollution. However, the renaming symbols themselves do not
6855 have this prefix, so we need to skip this prefix if present. */
6856 if (function_name_len
> 5 /* "_ada_" */
6857 && strstr (function_name
, "_ada_") == function_name
)
6860 function_name_len
-= 5;
6863 rename
= (char *) alloca (rename_len
* sizeof (char));
6864 strncpy (rename
, function_name
, function_name_len
);
6865 xsnprintf (rename
+ function_name_len
, rename_len
- function_name_len
,
6870 const int rename_len
= strlen (name
) + 6;
6872 rename
= (char *) alloca (rename_len
* sizeof (char));
6873 xsnprintf (rename
, rename_len
* sizeof (char), "%s___XR", name
);
6876 return ada_find_any_symbol (rename
);
6879 /* Because of GNAT encoding conventions, several GDB symbols may match a
6880 given type name. If the type denoted by TYPE0 is to be preferred to
6881 that of TYPE1 for purposes of type printing, return non-zero;
6882 otherwise return 0. */
6885 ada_prefer_type (struct type
*type0
, struct type
*type1
)
6889 else if (type0
== NULL
)
6891 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
6893 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
6895 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
6897 else if (ada_is_constrained_packed_array_type (type0
))
6899 else if (ada_is_array_descriptor_type (type0
)
6900 && !ada_is_array_descriptor_type (type1
))
6904 const char *type0_name
= type_name_no_tag (type0
);
6905 const char *type1_name
= type_name_no_tag (type1
);
6907 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
6908 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
6914 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6915 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6918 ada_type_name (struct type
*type
)
6922 else if (TYPE_NAME (type
) != NULL
)
6923 return TYPE_NAME (type
);
6925 return TYPE_TAG_NAME (type
);
6928 /* Search the list of "descriptive" types associated to TYPE for a type
6929 whose name is NAME. */
6931 static struct type
*
6932 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
6934 struct type
*result
;
6936 /* If there no descriptive-type info, then there is no parallel type
6938 if (!HAVE_GNAT_AUX_INFO (type
))
6941 result
= TYPE_DESCRIPTIVE_TYPE (type
);
6942 while (result
!= NULL
)
6944 char *result_name
= ada_type_name (result
);
6946 if (result_name
== NULL
)
6948 warning (_("unexpected null name on descriptive type"));
6952 /* If the names match, stop. */
6953 if (strcmp (result_name
, name
) == 0)
6956 /* Otherwise, look at the next item on the list, if any. */
6957 if (HAVE_GNAT_AUX_INFO (result
))
6958 result
= TYPE_DESCRIPTIVE_TYPE (result
);
6963 /* If we didn't find a match, see whether this is a packed array. With
6964 older compilers, the descriptive type information is either absent or
6965 irrelevant when it comes to packed arrays so the above lookup fails.
6966 Fall back to using a parallel lookup by name in this case. */
6967 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
6968 return ada_find_any_type (name
);
6973 /* Find a parallel type to TYPE with the specified NAME, using the
6974 descriptive type taken from the debugging information, if available,
6975 and otherwise using the (slower) name-based method. */
6977 static struct type
*
6978 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
6980 struct type
*result
= NULL
;
6982 if (HAVE_GNAT_AUX_INFO (type
))
6983 result
= find_parallel_type_by_descriptive_type (type
, name
);
6985 result
= ada_find_any_type (name
);
6990 /* Same as above, but specify the name of the parallel type by appending
6991 SUFFIX to the name of TYPE. */
6994 ada_find_parallel_type (struct type
*type
, const char *suffix
)
6996 char *name
, *typename
= ada_type_name (type
);
6999 if (typename
== NULL
)
7002 len
= strlen (typename
);
7004 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7006 strcpy (name
, typename
);
7007 strcpy (name
+ len
, suffix
);
7009 return ada_find_parallel_type_with_name (type
, name
);
7012 /* If TYPE is a variable-size record type, return the corresponding template
7013 type describing its fields. Otherwise, return NULL. */
7015 static struct type
*
7016 dynamic_template_type (struct type
*type
)
7018 type
= ada_check_typedef (type
);
7020 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
7021 || ada_type_name (type
) == NULL
)
7025 int len
= strlen (ada_type_name (type
));
7027 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7030 return ada_find_parallel_type (type
, "___XVE");
7034 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7035 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7038 is_dynamic_field (struct type
*templ_type
, int field_num
)
7040 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7043 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
7044 && strstr (name
, "___XVL") != NULL
;
7047 /* The index of the variant field of TYPE, or -1 if TYPE does not
7048 represent a variant record type. */
7051 variant_field_index (struct type
*type
)
7055 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
7058 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
7060 if (ada_is_variant_part (type
, f
))
7066 /* A record type with no fields. */
7068 static struct type
*
7069 empty_record (struct type
*template)
7071 struct type
*type
= alloc_type_copy (template);
7073 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
7074 TYPE_NFIELDS (type
) = 0;
7075 TYPE_FIELDS (type
) = NULL
;
7076 INIT_CPLUS_SPECIFIC (type
);
7077 TYPE_NAME (type
) = "<empty>";
7078 TYPE_TAG_NAME (type
) = NULL
;
7079 TYPE_LENGTH (type
) = 0;
7083 /* An ordinary record type (with fixed-length fields) that describes
7084 the value of type TYPE at VALADDR or ADDRESS (see comments at
7085 the beginning of this section) VAL according to GNAT conventions.
7086 DVAL0 should describe the (portion of a) record that contains any
7087 necessary discriminants. It should be NULL if value_type (VAL) is
7088 an outer-level type (i.e., as opposed to a branch of a variant.) A
7089 variant field (unless unchecked) is replaced by a particular branch
7092 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7093 length are not statically known are discarded. As a consequence,
7094 VALADDR, ADDRESS and DVAL0 are ignored.
7096 NOTE: Limitations: For now, we assume that dynamic fields and
7097 variants occupy whole numbers of bytes. However, they need not be
7101 ada_template_to_fixed_record_type_1 (struct type
*type
,
7102 const gdb_byte
*valaddr
,
7103 CORE_ADDR address
, struct value
*dval0
,
7104 int keep_dynamic_fields
)
7106 struct value
*mark
= value_mark ();
7109 int nfields
, bit_len
;
7115 /* Compute the number of fields in this record type that are going
7116 to be processed: unless keep_dynamic_fields, this includes only
7117 fields whose position and length are static will be processed. */
7118 if (keep_dynamic_fields
)
7119 nfields
= TYPE_NFIELDS (type
);
7123 while (nfields
< TYPE_NFIELDS (type
)
7124 && !ada_is_variant_part (type
, nfields
)
7125 && !is_dynamic_field (type
, nfields
))
7129 rtype
= alloc_type_copy (type
);
7130 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7131 INIT_CPLUS_SPECIFIC (rtype
);
7132 TYPE_NFIELDS (rtype
) = nfields
;
7133 TYPE_FIELDS (rtype
) = (struct field
*)
7134 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7135 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
7136 TYPE_NAME (rtype
) = ada_type_name (type
);
7137 TYPE_TAG_NAME (rtype
) = NULL
;
7138 TYPE_FIXED_INSTANCE (rtype
) = 1;
7144 for (f
= 0; f
< nfields
; f
+= 1)
7146 off
= align_value (off
, field_alignment (type
, f
))
7147 + TYPE_FIELD_BITPOS (type
, f
);
7148 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
7149 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7151 if (ada_is_variant_part (type
, f
))
7156 else if (is_dynamic_field (type
, f
))
7158 const gdb_byte
*field_valaddr
= valaddr
;
7159 CORE_ADDR field_address
= address
;
7160 struct type
*field_type
=
7161 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
));
7165 /* rtype's length is computed based on the run-time
7166 value of discriminants. If the discriminants are not
7167 initialized, the type size may be completely bogus and
7168 GDB may fail to allocate a value for it. So check the
7169 size first before creating the value. */
7171 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7176 /* If the type referenced by this field is an aligner type, we need
7177 to unwrap that aligner type, because its size might not be set.
7178 Keeping the aligner type would cause us to compute the wrong
7179 size for this field, impacting the offset of the all the fields
7180 that follow this one. */
7181 if (ada_is_aligner_type (field_type
))
7183 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7185 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7186 field_address
= cond_offset_target (field_address
, field_offset
);
7187 field_type
= ada_aligned_type (field_type
);
7190 field_valaddr
= cond_offset_host (field_valaddr
,
7191 off
/ TARGET_CHAR_BIT
);
7192 field_address
= cond_offset_target (field_address
,
7193 off
/ TARGET_CHAR_BIT
);
7195 /* Get the fixed type of the field. Note that, in this case,
7196 we do not want to get the real type out of the tag: if
7197 the current field is the parent part of a tagged record,
7198 we will get the tag of the object. Clearly wrong: the real
7199 type of the parent is not the real type of the child. We
7200 would end up in an infinite loop. */
7201 field_type
= ada_get_base_type (field_type
);
7202 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7203 field_address
, dval
, 0);
7204 /* If the field size is already larger than the maximum
7205 object size, then the record itself will necessarily
7206 be larger than the maximum object size. We need to make
7207 this check now, because the size might be so ridiculously
7208 large (due to an uninitialized variable in the inferior)
7209 that it would cause an overflow when adding it to the
7211 check_size (field_type
);
7213 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
7214 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7215 /* The multiplication can potentially overflow. But because
7216 the field length has been size-checked just above, and
7217 assuming that the maximum size is a reasonable value,
7218 an overflow should not happen in practice. So rather than
7219 adding overflow recovery code to this already complex code,
7220 we just assume that it's not going to happen. */
7222 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
7226 struct type
*field_type
= TYPE_FIELD_TYPE (type
, f
);
7228 /* If our field is a typedef type (most likely a typedef of
7229 a fat pointer, encoding an array access), then we need to
7230 look at its target type to determine its characteristics.
7231 In particular, we would miscompute the field size if we took
7232 the size of the typedef (zero), instead of the size of
7234 if (TYPE_CODE (field_type
) == TYPE_CODE_TYPEDEF
)
7235 field_type
= ada_typedef_target_type (field_type
);
7237 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
7238 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7239 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7241 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7244 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
7246 if (off
+ fld_bit_len
> bit_len
)
7247 bit_len
= off
+ fld_bit_len
;
7249 TYPE_LENGTH (rtype
) =
7250 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7253 /* We handle the variant part, if any, at the end because of certain
7254 odd cases in which it is re-ordered so as NOT to be the last field of
7255 the record. This can happen in the presence of representation
7257 if (variant_field
>= 0)
7259 struct type
*branch_type
;
7261 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
7264 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7269 to_fixed_variant_branch_type
7270 (TYPE_FIELD_TYPE (type
, variant_field
),
7271 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7272 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7273 if (branch_type
== NULL
)
7275 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
7276 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7277 TYPE_NFIELDS (rtype
) -= 1;
7281 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7282 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7284 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
7286 if (off
+ fld_bit_len
> bit_len
)
7287 bit_len
= off
+ fld_bit_len
;
7288 TYPE_LENGTH (rtype
) =
7289 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7293 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7294 should contain the alignment of that record, which should be a strictly
7295 positive value. If null or negative, then something is wrong, most
7296 probably in the debug info. In that case, we don't round up the size
7297 of the resulting type. If this record is not part of another structure,
7298 the current RTYPE length might be good enough for our purposes. */
7299 if (TYPE_LENGTH (type
) <= 0)
7301 if (TYPE_NAME (rtype
))
7302 warning (_("Invalid type size for `%s' detected: %d."),
7303 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
7305 warning (_("Invalid type size for <unnamed> detected: %d."),
7306 TYPE_LENGTH (type
));
7310 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
7311 TYPE_LENGTH (type
));
7314 value_free_to_mark (mark
);
7315 if (TYPE_LENGTH (rtype
) > varsize_limit
)
7316 error (_("record type with dynamic size is larger than varsize-limit"));
7320 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7323 static struct type
*
7324 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
7325 CORE_ADDR address
, struct value
*dval0
)
7327 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
7331 /* An ordinary record type in which ___XVL-convention fields and
7332 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7333 static approximations, containing all possible fields. Uses
7334 no runtime values. Useless for use in values, but that's OK,
7335 since the results are used only for type determinations. Works on both
7336 structs and unions. Representation note: to save space, we memorize
7337 the result of this function in the TYPE_TARGET_TYPE of the
7340 static struct type
*
7341 template_to_static_fixed_type (struct type
*type0
)
7347 if (TYPE_TARGET_TYPE (type0
) != NULL
)
7348 return TYPE_TARGET_TYPE (type0
);
7350 nfields
= TYPE_NFIELDS (type0
);
7353 for (f
= 0; f
< nfields
; f
+= 1)
7355 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
7356 struct type
*new_type
;
7358 if (is_dynamic_field (type0
, f
))
7359 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
7361 new_type
= static_unwrap_type (field_type
);
7362 if (type
== type0
&& new_type
!= field_type
)
7364 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
7365 TYPE_CODE (type
) = TYPE_CODE (type0
);
7366 INIT_CPLUS_SPECIFIC (type
);
7367 TYPE_NFIELDS (type
) = nfields
;
7368 TYPE_FIELDS (type
) = (struct field
*)
7369 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
7370 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
7371 sizeof (struct field
) * nfields
);
7372 TYPE_NAME (type
) = ada_type_name (type0
);
7373 TYPE_TAG_NAME (type
) = NULL
;
7374 TYPE_FIXED_INSTANCE (type
) = 1;
7375 TYPE_LENGTH (type
) = 0;
7377 TYPE_FIELD_TYPE (type
, f
) = new_type
;
7378 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
7383 /* Given an object of type TYPE whose contents are at VALADDR and
7384 whose address in memory is ADDRESS, returns a revision of TYPE,
7385 which should be a non-dynamic-sized record, in which the variant
7386 part, if any, is replaced with the appropriate branch. Looks
7387 for discriminant values in DVAL0, which can be NULL if the record
7388 contains the necessary discriminant values. */
7390 static struct type
*
7391 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
7392 CORE_ADDR address
, struct value
*dval0
)
7394 struct value
*mark
= value_mark ();
7397 struct type
*branch_type
;
7398 int nfields
= TYPE_NFIELDS (type
);
7399 int variant_field
= variant_field_index (type
);
7401 if (variant_field
== -1)
7405 dval
= value_from_contents_and_address (type
, valaddr
, address
);
7409 rtype
= alloc_type_copy (type
);
7410 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7411 INIT_CPLUS_SPECIFIC (rtype
);
7412 TYPE_NFIELDS (rtype
) = nfields
;
7413 TYPE_FIELDS (rtype
) =
7414 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7415 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
7416 sizeof (struct field
) * nfields
);
7417 TYPE_NAME (rtype
) = ada_type_name (type
);
7418 TYPE_TAG_NAME (rtype
) = NULL
;
7419 TYPE_FIXED_INSTANCE (rtype
) = 1;
7420 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
7422 branch_type
= to_fixed_variant_branch_type
7423 (TYPE_FIELD_TYPE (type
, variant_field
),
7424 cond_offset_host (valaddr
,
7425 TYPE_FIELD_BITPOS (type
, variant_field
)
7427 cond_offset_target (address
,
7428 TYPE_FIELD_BITPOS (type
, variant_field
)
7429 / TARGET_CHAR_BIT
), dval
);
7430 if (branch_type
== NULL
)
7434 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
7435 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7436 TYPE_NFIELDS (rtype
) -= 1;
7440 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7441 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7442 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
7443 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
7445 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
7447 value_free_to_mark (mark
);
7451 /* An ordinary record type (with fixed-length fields) that describes
7452 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7453 beginning of this section]. Any necessary discriminants' values
7454 should be in DVAL, a record value; it may be NULL if the object
7455 at ADDR itself contains any necessary discriminant values.
7456 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7457 values from the record are needed. Except in the case that DVAL,
7458 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7459 unchecked) is replaced by a particular branch of the variant.
7461 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7462 is questionable and may be removed. It can arise during the
7463 processing of an unconstrained-array-of-record type where all the
7464 variant branches have exactly the same size. This is because in
7465 such cases, the compiler does not bother to use the XVS convention
7466 when encoding the record. I am currently dubious of this
7467 shortcut and suspect the compiler should be altered. FIXME. */
7469 static struct type
*
7470 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
7471 CORE_ADDR address
, struct value
*dval
)
7473 struct type
*templ_type
;
7475 if (TYPE_FIXED_INSTANCE (type0
))
7478 templ_type
= dynamic_template_type (type0
);
7480 if (templ_type
!= NULL
)
7481 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
7482 else if (variant_field_index (type0
) >= 0)
7484 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
7486 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
7491 TYPE_FIXED_INSTANCE (type0
) = 1;
7497 /* An ordinary record type (with fixed-length fields) that describes
7498 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7499 union type. Any necessary discriminants' values should be in DVAL,
7500 a record value. That is, this routine selects the appropriate
7501 branch of the union at ADDR according to the discriminant value
7502 indicated in the union's type name. Returns VAR_TYPE0 itself if
7503 it represents a variant subject to a pragma Unchecked_Union. */
7505 static struct type
*
7506 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
7507 CORE_ADDR address
, struct value
*dval
)
7510 struct type
*templ_type
;
7511 struct type
*var_type
;
7513 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
7514 var_type
= TYPE_TARGET_TYPE (var_type0
);
7516 var_type
= var_type0
;
7518 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
7520 if (templ_type
!= NULL
)
7521 var_type
= templ_type
;
7523 if (is_unchecked_variant (var_type
, value_type (dval
)))
7526 ada_which_variant_applies (var_type
,
7527 value_type (dval
), value_contents (dval
));
7530 return empty_record (var_type
);
7531 else if (is_dynamic_field (var_type
, which
))
7532 return to_fixed_record_type
7533 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
7534 valaddr
, address
, dval
);
7535 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
7537 to_fixed_record_type
7538 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
7540 return TYPE_FIELD_TYPE (var_type
, which
);
7543 /* Assuming that TYPE0 is an array type describing the type of a value
7544 at ADDR, and that DVAL describes a record containing any
7545 discriminants used in TYPE0, returns a type for the value that
7546 contains no dynamic components (that is, no components whose sizes
7547 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7548 true, gives an error message if the resulting type's size is over
7551 static struct type
*
7552 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
7555 struct type
*index_type_desc
;
7556 struct type
*result
;
7557 int constrained_packed_array_p
;
7559 type0
= ada_check_typedef (type0
);
7560 if (TYPE_FIXED_INSTANCE (type0
))
7563 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
7564 if (constrained_packed_array_p
)
7565 type0
= decode_constrained_packed_array_type (type0
);
7567 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
7568 ada_fixup_array_indexes_type (index_type_desc
);
7569 if (index_type_desc
== NULL
)
7571 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
7573 /* NOTE: elt_type---the fixed version of elt_type0---should never
7574 depend on the contents of the array in properly constructed
7576 /* Create a fixed version of the array element type.
7577 We're not providing the address of an element here,
7578 and thus the actual object value cannot be inspected to do
7579 the conversion. This should not be a problem, since arrays of
7580 unconstrained objects are not allowed. In particular, all
7581 the elements of an array of a tagged type should all be of
7582 the same type specified in the debugging info. No need to
7583 consult the object tag. */
7584 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
7586 /* Make sure we always create a new array type when dealing with
7587 packed array types, since we're going to fix-up the array
7588 type length and element bitsize a little further down. */
7589 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
7592 result
= create_array_type (alloc_type_copy (type0
),
7593 elt_type
, TYPE_INDEX_TYPE (type0
));
7598 struct type
*elt_type0
;
7601 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
7602 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
7604 /* NOTE: result---the fixed version of elt_type0---should never
7605 depend on the contents of the array in properly constructed
7607 /* Create a fixed version of the array element type.
7608 We're not providing the address of an element here,
7609 and thus the actual object value cannot be inspected to do
7610 the conversion. This should not be a problem, since arrays of
7611 unconstrained objects are not allowed. In particular, all
7612 the elements of an array of a tagged type should all be of
7613 the same type specified in the debugging info. No need to
7614 consult the object tag. */
7616 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
7619 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
7621 struct type
*range_type
=
7622 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, i
), dval
);
7624 result
= create_array_type (alloc_type_copy (elt_type0
),
7625 result
, range_type
);
7626 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
7628 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
7629 error (_("array type with dynamic size is larger than varsize-limit"));
7632 if (constrained_packed_array_p
)
7634 /* So far, the resulting type has been created as if the original
7635 type was a regular (non-packed) array type. As a result, the
7636 bitsize of the array elements needs to be set again, and the array
7637 length needs to be recomputed based on that bitsize. */
7638 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
7639 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
7641 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
7642 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
7643 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
7644 TYPE_LENGTH (result
)++;
7647 TYPE_FIXED_INSTANCE (result
) = 1;
7652 /* A standard type (containing no dynamically sized components)
7653 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7654 DVAL describes a record containing any discriminants used in TYPE0,
7655 and may be NULL if there are none, or if the object of type TYPE at
7656 ADDRESS or in VALADDR contains these discriminants.
7658 If CHECK_TAG is not null, in the case of tagged types, this function
7659 attempts to locate the object's tag and use it to compute the actual
7660 type. However, when ADDRESS is null, we cannot use it to determine the
7661 location of the tag, and therefore compute the tagged type's actual type.
7662 So we return the tagged type without consulting the tag. */
7664 static struct type
*
7665 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
7666 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7668 type
= ada_check_typedef (type
);
7669 switch (TYPE_CODE (type
))
7673 case TYPE_CODE_STRUCT
:
7675 struct type
*static_type
= to_static_fixed_type (type
);
7676 struct type
*fixed_record_type
=
7677 to_fixed_record_type (type
, valaddr
, address
, NULL
);
7679 /* If STATIC_TYPE is a tagged type and we know the object's address,
7680 then we can determine its tag, and compute the object's actual
7681 type from there. Note that we have to use the fixed record
7682 type (the parent part of the record may have dynamic fields
7683 and the way the location of _tag is expressed may depend on
7686 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
7688 struct type
*real_type
=
7689 type_from_tag (value_tag_from_contents_and_address
7694 if (real_type
!= NULL
)
7695 return to_fixed_record_type (real_type
, valaddr
, address
, NULL
);
7698 /* Check to see if there is a parallel ___XVZ variable.
7699 If there is, then it provides the actual size of our type. */
7700 else if (ada_type_name (fixed_record_type
) != NULL
)
7702 char *name
= ada_type_name (fixed_record_type
);
7703 char *xvz_name
= alloca (strlen (name
) + 7 /* "___XVZ\0" */);
7707 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
7708 size
= get_int_var_value (xvz_name
, &xvz_found
);
7709 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
7711 fixed_record_type
= copy_type (fixed_record_type
);
7712 TYPE_LENGTH (fixed_record_type
) = size
;
7714 /* The FIXED_RECORD_TYPE may have be a stub. We have
7715 observed this when the debugging info is STABS, and
7716 apparently it is something that is hard to fix.
7718 In practice, we don't need the actual type definition
7719 at all, because the presence of the XVZ variable allows us
7720 to assume that there must be a XVS type as well, which we
7721 should be able to use later, when we need the actual type
7724 In the meantime, pretend that the "fixed" type we are
7725 returning is NOT a stub, because this can cause trouble
7726 when using this type to create new types targeting it.
7727 Indeed, the associated creation routines often check
7728 whether the target type is a stub and will try to replace
7729 it, thus using a type with the wrong size. This, in turn,
7730 might cause the new type to have the wrong size too.
7731 Consider the case of an array, for instance, where the size
7732 of the array is computed from the number of elements in
7733 our array multiplied by the size of its element. */
7734 TYPE_STUB (fixed_record_type
) = 0;
7737 return fixed_record_type
;
7739 case TYPE_CODE_ARRAY
:
7740 return to_fixed_array_type (type
, dval
, 1);
7741 case TYPE_CODE_UNION
:
7745 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
7749 /* The same as ada_to_fixed_type_1, except that it preserves the type
7750 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7752 The typedef layer needs be preserved in order to differentiate between
7753 arrays and array pointers when both types are implemented using the same
7754 fat pointer. In the array pointer case, the pointer is encoded as
7755 a typedef of the pointer type. For instance, considering:
7757 type String_Access is access String;
7758 S1 : String_Access := null;
7760 To the debugger, S1 is defined as a typedef of type String. But
7761 to the user, it is a pointer. So if the user tries to print S1,
7762 we should not dereference the array, but print the array address
7765 If we didn't preserve the typedef layer, we would lose the fact that
7766 the type is to be presented as a pointer (needs de-reference before
7767 being printed). And we would also use the source-level type name. */
7770 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
7771 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7774 struct type
*fixed_type
=
7775 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
7777 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
7778 then preserve the typedef layer.
7780 Implementation note: We can only check the main-type portion of
7781 the TYPE and FIXED_TYPE, because eliminating the typedef layer
7782 from TYPE now returns a type that has the same instance flags
7783 as TYPE. For instance, if TYPE is a "typedef const", and its
7784 target type is a "struct", then the typedef elimination will return
7785 a "const" version of the target type. See check_typedef for more
7786 details about how the typedef layer elimination is done.
7788 brobecker/2010-11-19: It seems to me that the only case where it is
7789 useful to preserve the typedef layer is when dealing with fat pointers.
7790 Perhaps, we could add a check for that and preserve the typedef layer
7791 only in that situation. But this seems unecessary so far, probably
7792 because we call check_typedef/ada_check_typedef pretty much everywhere.
7794 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
7795 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
7796 == TYPE_MAIN_TYPE (fixed_type
)))
7802 /* A standard (static-sized) type corresponding as well as possible to
7803 TYPE0, but based on no runtime data. */
7805 static struct type
*
7806 to_static_fixed_type (struct type
*type0
)
7813 if (TYPE_FIXED_INSTANCE (type0
))
7816 type0
= ada_check_typedef (type0
);
7818 switch (TYPE_CODE (type0
))
7822 case TYPE_CODE_STRUCT
:
7823 type
= dynamic_template_type (type0
);
7825 return template_to_static_fixed_type (type
);
7827 return template_to_static_fixed_type (type0
);
7828 case TYPE_CODE_UNION
:
7829 type
= ada_find_parallel_type (type0
, "___XVU");
7831 return template_to_static_fixed_type (type
);
7833 return template_to_static_fixed_type (type0
);
7837 /* A static approximation of TYPE with all type wrappers removed. */
7839 static struct type
*
7840 static_unwrap_type (struct type
*type
)
7842 if (ada_is_aligner_type (type
))
7844 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
7845 if (ada_type_name (type1
) == NULL
)
7846 TYPE_NAME (type1
) = ada_type_name (type
);
7848 return static_unwrap_type (type1
);
7852 struct type
*raw_real_type
= ada_get_base_type (type
);
7854 if (raw_real_type
== type
)
7857 return to_static_fixed_type (raw_real_type
);
7861 /* In some cases, incomplete and private types require
7862 cross-references that are not resolved as records (for example,
7864 type FooP is access Foo;
7866 type Foo is array ...;
7867 ). In these cases, since there is no mechanism for producing
7868 cross-references to such types, we instead substitute for FooP a
7869 stub enumeration type that is nowhere resolved, and whose tag is
7870 the name of the actual type. Call these types "non-record stubs". */
7872 /* A type equivalent to TYPE that is not a non-record stub, if one
7873 exists, otherwise TYPE. */
7876 ada_check_typedef (struct type
*type
)
7881 /* If our type is a typedef type of a fat pointer, then we're done.
7882 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
7883 what allows us to distinguish between fat pointers that represent
7884 array types, and fat pointers that represent array access types
7885 (in both cases, the compiler implements them as fat pointers). */
7886 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
7887 && is_thick_pntr (ada_typedef_target_type (type
)))
7890 CHECK_TYPEDEF (type
);
7891 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
7892 || !TYPE_STUB (type
)
7893 || TYPE_TAG_NAME (type
) == NULL
)
7897 char *name
= TYPE_TAG_NAME (type
);
7898 struct type
*type1
= ada_find_any_type (name
);
7903 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
7904 stubs pointing to arrays, as we don't create symbols for array
7905 types, only for the typedef-to-array types). If that's the case,
7906 strip the typedef layer. */
7907 if (TYPE_CODE (type1
) == TYPE_CODE_TYPEDEF
)
7908 type1
= ada_check_typedef (type1
);
7914 /* A value representing the data at VALADDR/ADDRESS as described by
7915 type TYPE0, but with a standard (static-sized) type that correctly
7916 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7917 type, then return VAL0 [this feature is simply to avoid redundant
7918 creation of struct values]. */
7920 static struct value
*
7921 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
7924 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
7926 if (type
== type0
&& val0
!= NULL
)
7929 return value_from_contents_and_address (type
, 0, address
);
7932 /* A value representing VAL, but with a standard (static-sized) type
7933 that correctly describes it. Does not necessarily create a new
7937 ada_to_fixed_value (struct value
*val
)
7939 return ada_to_fixed_value_create (value_type (val
),
7940 value_address (val
),
7947 /* Table mapping attribute numbers to names.
7948 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7950 static const char *attribute_names
[] = {
7968 ada_attribute_name (enum exp_opcode n
)
7970 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
7971 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
7973 return attribute_names
[0];
7976 /* Evaluate the 'POS attribute applied to ARG. */
7979 pos_atr (struct value
*arg
)
7981 struct value
*val
= coerce_ref (arg
);
7982 struct type
*type
= value_type (val
);
7984 if (!discrete_type_p (type
))
7985 error (_("'POS only defined on discrete types"));
7987 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7990 LONGEST v
= value_as_long (val
);
7992 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7994 if (v
== TYPE_FIELD_BITPOS (type
, i
))
7997 error (_("enumeration value is invalid: can't find 'POS"));
8000 return value_as_long (val
);
8003 static struct value
*
8004 value_pos_atr (struct type
*type
, struct value
*arg
)
8006 return value_from_longest (type
, pos_atr (arg
));
8009 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8011 static struct value
*
8012 value_val_atr (struct type
*type
, struct value
*arg
)
8014 if (!discrete_type_p (type
))
8015 error (_("'VAL only defined on discrete types"));
8016 if (!integer_type_p (value_type (arg
)))
8017 error (_("'VAL requires integral argument"));
8019 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8021 long pos
= value_as_long (arg
);
8023 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
8024 error (_("argument to 'VAL out of range"));
8025 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
8028 return value_from_longest (type
, value_as_long (arg
));
8034 /* True if TYPE appears to be an Ada character type.
8035 [At the moment, this is true only for Character and Wide_Character;
8036 It is a heuristic test that could stand improvement]. */
8039 ada_is_character_type (struct type
*type
)
8043 /* If the type code says it's a character, then assume it really is,
8044 and don't check any further. */
8045 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
8048 /* Otherwise, assume it's a character type iff it is a discrete type
8049 with a known character type name. */
8050 name
= ada_type_name (type
);
8051 return (name
!= NULL
8052 && (TYPE_CODE (type
) == TYPE_CODE_INT
8053 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8054 && (strcmp (name
, "character") == 0
8055 || strcmp (name
, "wide_character") == 0
8056 || strcmp (name
, "wide_wide_character") == 0
8057 || strcmp (name
, "unsigned char") == 0));
8060 /* True if TYPE appears to be an Ada string type. */
8063 ada_is_string_type (struct type
*type
)
8065 type
= ada_check_typedef (type
);
8067 && TYPE_CODE (type
) != TYPE_CODE_PTR
8068 && (ada_is_simple_array_type (type
)
8069 || ada_is_array_descriptor_type (type
))
8070 && ada_array_arity (type
) == 1)
8072 struct type
*elttype
= ada_array_element_type (type
, 1);
8074 return ada_is_character_type (elttype
);
8080 /* The compiler sometimes provides a parallel XVS type for a given
8081 PAD type. Normally, it is safe to follow the PAD type directly,
8082 but older versions of the compiler have a bug that causes the offset
8083 of its "F" field to be wrong. Following that field in that case
8084 would lead to incorrect results, but this can be worked around
8085 by ignoring the PAD type and using the associated XVS type instead.
8087 Set to True if the debugger should trust the contents of PAD types.
8088 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8089 static int trust_pad_over_xvs
= 1;
8091 /* True if TYPE is a struct type introduced by the compiler to force the
8092 alignment of a value. Such types have a single field with a
8093 distinctive name. */
8096 ada_is_aligner_type (struct type
*type
)
8098 type
= ada_check_typedef (type
);
8100 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
8103 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
8104 && TYPE_NFIELDS (type
) == 1
8105 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
8108 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8109 the parallel type. */
8112 ada_get_base_type (struct type
*raw_type
)
8114 struct type
*real_type_namer
;
8115 struct type
*raw_real_type
;
8117 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
8120 if (ada_is_aligner_type (raw_type
))
8121 /* The encoding specifies that we should always use the aligner type.
8122 So, even if this aligner type has an associated XVS type, we should
8125 According to the compiler gurus, an XVS type parallel to an aligner
8126 type may exist because of a stabs limitation. In stabs, aligner
8127 types are empty because the field has a variable-sized type, and
8128 thus cannot actually be used as an aligner type. As a result,
8129 we need the associated parallel XVS type to decode the type.
8130 Since the policy in the compiler is to not change the internal
8131 representation based on the debugging info format, we sometimes
8132 end up having a redundant XVS type parallel to the aligner type. */
8135 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
8136 if (real_type_namer
== NULL
8137 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
8138 || TYPE_NFIELDS (real_type_namer
) != 1)
8141 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer
, 0)) != TYPE_CODE_REF
)
8143 /* This is an older encoding form where the base type needs to be
8144 looked up by name. We prefer the newer enconding because it is
8146 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
8147 if (raw_real_type
== NULL
)
8150 return raw_real_type
;
8153 /* The field in our XVS type is a reference to the base type. */
8154 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer
, 0));
8157 /* The type of value designated by TYPE, with all aligners removed. */
8160 ada_aligned_type (struct type
*type
)
8162 if (ada_is_aligner_type (type
))
8163 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
8165 return ada_get_base_type (type
);
8169 /* The address of the aligned value in an object at address VALADDR
8170 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
8173 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
8175 if (ada_is_aligner_type (type
))
8176 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
8178 TYPE_FIELD_BITPOS (type
,
8179 0) / TARGET_CHAR_BIT
);
8186 /* The printed representation of an enumeration literal with encoded
8187 name NAME. The value is good to the next call of ada_enum_name. */
8189 ada_enum_name (const char *name
)
8191 static char *result
;
8192 static size_t result_len
= 0;
8195 /* First, unqualify the enumeration name:
8196 1. Search for the last '.' character. If we find one, then skip
8197 all the preceeding characters, the unqualified name starts
8198 right after that dot.
8199 2. Otherwise, we may be debugging on a target where the compiler
8200 translates dots into "__". Search forward for double underscores,
8201 but stop searching when we hit an overloading suffix, which is
8202 of the form "__" followed by digits. */
8204 tmp
= strrchr (name
, '.');
8209 while ((tmp
= strstr (name
, "__")) != NULL
)
8211 if (isdigit (tmp
[2]))
8222 if (name
[1] == 'U' || name
[1] == 'W')
8224 if (sscanf (name
+ 2, "%x", &v
) != 1)
8230 GROW_VECT (result
, result_len
, 16);
8231 if (isascii (v
) && isprint (v
))
8232 xsnprintf (result
, result_len
, "'%c'", v
);
8233 else if (name
[1] == 'U')
8234 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
8236 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
8242 tmp
= strstr (name
, "__");
8244 tmp
= strstr (name
, "$");
8247 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
8248 strncpy (result
, name
, tmp
- name
);
8249 result
[tmp
- name
] = '\0';
8257 /* Evaluate the subexpression of EXP starting at *POS as for
8258 evaluate_type, updating *POS to point just past the evaluated
8261 static struct value
*
8262 evaluate_subexp_type (struct expression
*exp
, int *pos
)
8264 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8267 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8270 static struct value
*
8271 unwrap_value (struct value
*val
)
8273 struct type
*type
= ada_check_typedef (value_type (val
));
8275 if (ada_is_aligner_type (type
))
8277 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
8278 struct type
*val_type
= ada_check_typedef (value_type (v
));
8280 if (ada_type_name (val_type
) == NULL
)
8281 TYPE_NAME (val_type
) = ada_type_name (type
);
8283 return unwrap_value (v
);
8287 struct type
*raw_real_type
=
8288 ada_check_typedef (ada_get_base_type (type
));
8290 /* If there is no parallel XVS or XVE type, then the value is
8291 already unwrapped. Return it without further modification. */
8292 if ((type
== raw_real_type
)
8293 && ada_find_parallel_type (type
, "___XVE") == NULL
)
8297 coerce_unspec_val_to_type
8298 (val
, ada_to_fixed_type (raw_real_type
, 0,
8299 value_address (val
),
8304 static struct value
*
8305 cast_to_fixed (struct type
*type
, struct value
*arg
)
8309 if (type
== value_type (arg
))
8311 else if (ada_is_fixed_point_type (value_type (arg
)))
8312 val
= ada_float_to_fixed (type
,
8313 ada_fixed_to_float (value_type (arg
),
8314 value_as_long (arg
)));
8317 DOUBLEST argd
= value_as_double (arg
);
8319 val
= ada_float_to_fixed (type
, argd
);
8322 return value_from_longest (type
, val
);
8325 static struct value
*
8326 cast_from_fixed (struct type
*type
, struct value
*arg
)
8328 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
8329 value_as_long (arg
));
8331 return value_from_double (type
, val
);
8334 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8335 return the converted value. */
8337 static struct value
*
8338 coerce_for_assign (struct type
*type
, struct value
*val
)
8340 struct type
*type2
= value_type (val
);
8345 type2
= ada_check_typedef (type2
);
8346 type
= ada_check_typedef (type
);
8348 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
8349 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8351 val
= ada_value_ind (val
);
8352 type2
= value_type (val
);
8355 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
8356 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8358 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
8359 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
8360 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
8361 error (_("Incompatible types in assignment"));
8362 deprecated_set_value_type (val
, type
);
8367 static struct value
*
8368 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
8371 struct type
*type1
, *type2
;
8374 arg1
= coerce_ref (arg1
);
8375 arg2
= coerce_ref (arg2
);
8376 type1
= base_type (ada_check_typedef (value_type (arg1
)));
8377 type2
= base_type (ada_check_typedef (value_type (arg2
)));
8379 if (TYPE_CODE (type1
) != TYPE_CODE_INT
8380 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
8381 return value_binop (arg1
, arg2
, op
);
8390 return value_binop (arg1
, arg2
, op
);
8393 v2
= value_as_long (arg2
);
8395 error (_("second operand of %s must not be zero."), op_string (op
));
8397 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
8398 return value_binop (arg1
, arg2
, op
);
8400 v1
= value_as_long (arg1
);
8405 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
8406 v
+= v
> 0 ? -1 : 1;
8414 /* Should not reach this point. */
8418 val
= allocate_value (type1
);
8419 store_unsigned_integer (value_contents_raw (val
),
8420 TYPE_LENGTH (value_type (val
)),
8421 gdbarch_byte_order (get_type_arch (type1
)), v
);
8426 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
8428 if (ada_is_direct_array_type (value_type (arg1
))
8429 || ada_is_direct_array_type (value_type (arg2
)))
8431 /* Automatically dereference any array reference before
8432 we attempt to perform the comparison. */
8433 arg1
= ada_coerce_ref (arg1
);
8434 arg2
= ada_coerce_ref (arg2
);
8436 arg1
= ada_coerce_to_simple_array (arg1
);
8437 arg2
= ada_coerce_to_simple_array (arg2
);
8438 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
8439 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
8440 error (_("Attempt to compare array with non-array"));
8441 /* FIXME: The following works only for types whose
8442 representations use all bits (no padding or undefined bits)
8443 and do not have user-defined equality. */
8445 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
8446 && memcmp (value_contents (arg1
), value_contents (arg2
),
8447 TYPE_LENGTH (value_type (arg1
))) == 0;
8449 return value_equal (arg1
, arg2
);
8452 /* Total number of component associations in the aggregate starting at
8453 index PC in EXP. Assumes that index PC is the start of an
8457 num_component_specs (struct expression
*exp
, int pc
)
8461 m
= exp
->elts
[pc
+ 1].longconst
;
8464 for (i
= 0; i
< m
; i
+= 1)
8466 switch (exp
->elts
[pc
].opcode
)
8472 n
+= exp
->elts
[pc
+ 1].longconst
;
8475 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
8480 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
8481 component of LHS (a simple array or a record), updating *POS past
8482 the expression, assuming that LHS is contained in CONTAINER. Does
8483 not modify the inferior's memory, nor does it modify LHS (unless
8484 LHS == CONTAINER). */
8487 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
8488 struct expression
*exp
, int *pos
)
8490 struct value
*mark
= value_mark ();
8493 if (TYPE_CODE (value_type (lhs
)) == TYPE_CODE_ARRAY
)
8495 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
8496 struct value
*index_val
= value_from_longest (index_type
, index
);
8498 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
8502 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
8503 elt
= ada_to_fixed_value (unwrap_value (elt
));
8506 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8507 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
8509 value_assign_to_component (container
, elt
,
8510 ada_evaluate_subexp (NULL
, exp
, pos
,
8513 value_free_to_mark (mark
);
8516 /* Assuming that LHS represents an lvalue having a record or array
8517 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8518 of that aggregate's value to LHS, advancing *POS past the
8519 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8520 lvalue containing LHS (possibly LHS itself). Does not modify
8521 the inferior's memory, nor does it modify the contents of
8522 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
8524 static struct value
*
8525 assign_aggregate (struct value
*container
,
8526 struct value
*lhs
, struct expression
*exp
,
8527 int *pos
, enum noside noside
)
8529 struct type
*lhs_type
;
8530 int n
= exp
->elts
[*pos
+1].longconst
;
8531 LONGEST low_index
, high_index
;
8534 int max_indices
, num_indices
;
8535 int is_array_aggregate
;
8539 if (noside
!= EVAL_NORMAL
)
8543 for (i
= 0; i
< n
; i
+= 1)
8544 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
8548 container
= ada_coerce_ref (container
);
8549 if (ada_is_direct_array_type (value_type (container
)))
8550 container
= ada_coerce_to_simple_array (container
);
8551 lhs
= ada_coerce_ref (lhs
);
8552 if (!deprecated_value_modifiable (lhs
))
8553 error (_("Left operand of assignment is not a modifiable lvalue."));
8555 lhs_type
= value_type (lhs
);
8556 if (ada_is_direct_array_type (lhs_type
))
8558 lhs
= ada_coerce_to_simple_array (lhs
);
8559 lhs_type
= value_type (lhs
);
8560 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
8561 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
8562 is_array_aggregate
= 1;
8564 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
8567 high_index
= num_visible_fields (lhs_type
) - 1;
8568 is_array_aggregate
= 0;
8571 error (_("Left-hand side must be array or record."));
8573 num_specs
= num_component_specs (exp
, *pos
- 3);
8574 max_indices
= 4 * num_specs
+ 4;
8575 indices
= alloca (max_indices
* sizeof (indices
[0]));
8576 indices
[0] = indices
[1] = low_index
- 1;
8577 indices
[2] = indices
[3] = high_index
+ 1;
8580 for (i
= 0; i
< n
; i
+= 1)
8582 switch (exp
->elts
[*pos
].opcode
)
8585 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
8586 &num_indices
, max_indices
,
8587 low_index
, high_index
);
8590 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
8591 &num_indices
, max_indices
,
8592 low_index
, high_index
);
8596 error (_("Misplaced 'others' clause"));
8597 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
8598 num_indices
, low_index
, high_index
);
8601 error (_("Internal error: bad aggregate clause"));
8608 /* Assign into the component of LHS indexed by the OP_POSITIONAL
8609 construct at *POS, updating *POS past the construct, given that
8610 the positions are relative to lower bound LOW, where HIGH is the
8611 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8612 updating *NUM_INDICES as needed. CONTAINER is as for
8613 assign_aggregate. */
8615 aggregate_assign_positional (struct value
*container
,
8616 struct value
*lhs
, struct expression
*exp
,
8617 int *pos
, LONGEST
*indices
, int *num_indices
,
8618 int max_indices
, LONGEST low
, LONGEST high
)
8620 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
8622 if (ind
- 1 == high
)
8623 warning (_("Extra components in aggregate ignored."));
8626 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
8628 assign_component (container
, lhs
, ind
, exp
, pos
);
8631 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8634 /* Assign into the components of LHS indexed by the OP_CHOICES
8635 construct at *POS, updating *POS past the construct, given that
8636 the allowable indices are LOW..HIGH. Record the indices assigned
8637 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8638 needed. CONTAINER is as for assign_aggregate. */
8640 aggregate_assign_from_choices (struct value
*container
,
8641 struct value
*lhs
, struct expression
*exp
,
8642 int *pos
, LONGEST
*indices
, int *num_indices
,
8643 int max_indices
, LONGEST low
, LONGEST high
)
8646 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
8647 int choice_pos
, expr_pc
;
8648 int is_array
= ada_is_direct_array_type (value_type (lhs
));
8650 choice_pos
= *pos
+= 3;
8652 for (j
= 0; j
< n_choices
; j
+= 1)
8653 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8655 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8657 for (j
= 0; j
< n_choices
; j
+= 1)
8659 LONGEST lower
, upper
;
8660 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
8662 if (op
== OP_DISCRETE_RANGE
)
8665 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8667 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8672 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
8684 name
= &exp
->elts
[choice_pos
+ 2].string
;
8687 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
8690 error (_("Invalid record component association."));
8692 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
8694 if (! find_struct_field (name
, value_type (lhs
), 0,
8695 NULL
, NULL
, NULL
, NULL
, &ind
))
8696 error (_("Unknown component name: %s."), name
);
8697 lower
= upper
= ind
;
8700 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
8701 error (_("Index in component association out of bounds."));
8703 add_component_interval (lower
, upper
, indices
, num_indices
,
8705 while (lower
<= upper
)
8710 assign_component (container
, lhs
, lower
, exp
, &pos1
);
8716 /* Assign the value of the expression in the OP_OTHERS construct in
8717 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8718 have not been previously assigned. The index intervals already assigned
8719 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8720 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
8722 aggregate_assign_others (struct value
*container
,
8723 struct value
*lhs
, struct expression
*exp
,
8724 int *pos
, LONGEST
*indices
, int num_indices
,
8725 LONGEST low
, LONGEST high
)
8728 int expr_pc
= *pos
+ 1;
8730 for (i
= 0; i
< num_indices
- 2; i
+= 2)
8734 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
8739 assign_component (container
, lhs
, ind
, exp
, &localpos
);
8742 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8745 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
8746 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8747 modifying *SIZE as needed. It is an error if *SIZE exceeds
8748 MAX_SIZE. The resulting intervals do not overlap. */
8750 add_component_interval (LONGEST low
, LONGEST high
,
8751 LONGEST
* indices
, int *size
, int max_size
)
8755 for (i
= 0; i
< *size
; i
+= 2) {
8756 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
8760 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
8761 if (high
< indices
[kh
])
8763 if (low
< indices
[i
])
8765 indices
[i
+ 1] = indices
[kh
- 1];
8766 if (high
> indices
[i
+ 1])
8767 indices
[i
+ 1] = high
;
8768 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
8769 *size
-= kh
- i
- 2;
8772 else if (high
< indices
[i
])
8776 if (*size
== max_size
)
8777 error (_("Internal error: miscounted aggregate components."));
8779 for (j
= *size
-1; j
>= i
+2; j
-= 1)
8780 indices
[j
] = indices
[j
- 2];
8782 indices
[i
+ 1] = high
;
8785 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8788 static struct value
*
8789 ada_value_cast (struct type
*type
, struct value
*arg2
, enum noside noside
)
8791 if (type
== ada_check_typedef (value_type (arg2
)))
8794 if (ada_is_fixed_point_type (type
))
8795 return (cast_to_fixed (type
, arg2
));
8797 if (ada_is_fixed_point_type (value_type (arg2
)))
8798 return cast_from_fixed (type
, arg2
);
8800 return value_cast (type
, arg2
);
8803 /* Evaluating Ada expressions, and printing their result.
8804 ------------------------------------------------------
8809 We usually evaluate an Ada expression in order to print its value.
8810 We also evaluate an expression in order to print its type, which
8811 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
8812 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
8813 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
8814 the evaluation compared to the EVAL_NORMAL, but is otherwise very
8817 Evaluating expressions is a little more complicated for Ada entities
8818 than it is for entities in languages such as C. The main reason for
8819 this is that Ada provides types whose definition might be dynamic.
8820 One example of such types is variant records. Or another example
8821 would be an array whose bounds can only be known at run time.
8823 The following description is a general guide as to what should be
8824 done (and what should NOT be done) in order to evaluate an expression
8825 involving such types, and when. This does not cover how the semantic
8826 information is encoded by GNAT as this is covered separatly. For the
8827 document used as the reference for the GNAT encoding, see exp_dbug.ads
8828 in the GNAT sources.
8830 Ideally, we should embed each part of this description next to its
8831 associated code. Unfortunately, the amount of code is so vast right
8832 now that it's hard to see whether the code handling a particular
8833 situation might be duplicated or not. One day, when the code is
8834 cleaned up, this guide might become redundant with the comments
8835 inserted in the code, and we might want to remove it.
8837 2. ``Fixing'' an Entity, the Simple Case:
8838 -----------------------------------------
8840 When evaluating Ada expressions, the tricky issue is that they may
8841 reference entities whose type contents and size are not statically
8842 known. Consider for instance a variant record:
8844 type Rec (Empty : Boolean := True) is record
8847 when False => Value : Integer;
8850 Yes : Rec := (Empty => False, Value => 1);
8851 No : Rec := (empty => True);
8853 The size and contents of that record depends on the value of the
8854 descriminant (Rec.Empty). At this point, neither the debugging
8855 information nor the associated type structure in GDB are able to
8856 express such dynamic types. So what the debugger does is to create
8857 "fixed" versions of the type that applies to the specific object.
8858 We also informally refer to this opperation as "fixing" an object,
8859 which means creating its associated fixed type.
8861 Example: when printing the value of variable "Yes" above, its fixed
8862 type would look like this:
8869 On the other hand, if we printed the value of "No", its fixed type
8876 Things become a little more complicated when trying to fix an entity
8877 with a dynamic type that directly contains another dynamic type,
8878 such as an array of variant records, for instance. There are
8879 two possible cases: Arrays, and records.
8881 3. ``Fixing'' Arrays:
8882 ---------------------
8884 The type structure in GDB describes an array in terms of its bounds,
8885 and the type of its elements. By design, all elements in the array
8886 have the same type and we cannot represent an array of variant elements
8887 using the current type structure in GDB. When fixing an array,
8888 we cannot fix the array element, as we would potentially need one
8889 fixed type per element of the array. As a result, the best we can do
8890 when fixing an array is to produce an array whose bounds and size
8891 are correct (allowing us to read it from memory), but without having
8892 touched its element type. Fixing each element will be done later,
8893 when (if) necessary.
8895 Arrays are a little simpler to handle than records, because the same
8896 amount of memory is allocated for each element of the array, even if
8897 the amount of space actually used by each element differs from element
8898 to element. Consider for instance the following array of type Rec:
8900 type Rec_Array is array (1 .. 2) of Rec;
8902 The actual amount of memory occupied by each element might be different
8903 from element to element, depending on the value of their discriminant.
8904 But the amount of space reserved for each element in the array remains
8905 fixed regardless. So we simply need to compute that size using
8906 the debugging information available, from which we can then determine
8907 the array size (we multiply the number of elements of the array by
8908 the size of each element).
8910 The simplest case is when we have an array of a constrained element
8911 type. For instance, consider the following type declarations:
8913 type Bounded_String (Max_Size : Integer) is
8915 Buffer : String (1 .. Max_Size);
8917 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
8919 In this case, the compiler describes the array as an array of
8920 variable-size elements (identified by its XVS suffix) for which
8921 the size can be read in the parallel XVZ variable.
8923 In the case of an array of an unconstrained element type, the compiler
8924 wraps the array element inside a private PAD type. This type should not
8925 be shown to the user, and must be "unwrap"'ed before printing. Note
8926 that we also use the adjective "aligner" in our code to designate
8927 these wrapper types.
8929 In some cases, the size allocated for each element is statically
8930 known. In that case, the PAD type already has the correct size,
8931 and the array element should remain unfixed.
8933 But there are cases when this size is not statically known.
8934 For instance, assuming that "Five" is an integer variable:
8936 type Dynamic is array (1 .. Five) of Integer;
8937 type Wrapper (Has_Length : Boolean := False) is record
8940 when True => Length : Integer;
8944 type Wrapper_Array is array (1 .. 2) of Wrapper;
8946 Hello : Wrapper_Array := (others => (Has_Length => True,
8947 Data => (others => 17),
8951 The debugging info would describe variable Hello as being an
8952 array of a PAD type. The size of that PAD type is not statically
8953 known, but can be determined using a parallel XVZ variable.
8954 In that case, a copy of the PAD type with the correct size should
8955 be used for the fixed array.
8957 3. ``Fixing'' record type objects:
8958 ----------------------------------
8960 Things are slightly different from arrays in the case of dynamic
8961 record types. In this case, in order to compute the associated
8962 fixed type, we need to determine the size and offset of each of
8963 its components. This, in turn, requires us to compute the fixed
8964 type of each of these components.
8966 Consider for instance the example:
8968 type Bounded_String (Max_Size : Natural) is record
8969 Str : String (1 .. Max_Size);
8972 My_String : Bounded_String (Max_Size => 10);
8974 In that case, the position of field "Length" depends on the size
8975 of field Str, which itself depends on the value of the Max_Size
8976 discriminant. In order to fix the type of variable My_String,
8977 we need to fix the type of field Str. Therefore, fixing a variant
8978 record requires us to fix each of its components.
8980 However, if a component does not have a dynamic size, the component
8981 should not be fixed. In particular, fields that use a PAD type
8982 should not fixed. Here is an example where this might happen
8983 (assuming type Rec above):
8985 type Container (Big : Boolean) is record
8989 when True => Another : Integer;
8993 My_Container : Container := (Big => False,
8994 First => (Empty => True),
8997 In that example, the compiler creates a PAD type for component First,
8998 whose size is constant, and then positions the component After just
8999 right after it. The offset of component After is therefore constant
9002 The debugger computes the position of each field based on an algorithm
9003 that uses, among other things, the actual position and size of the field
9004 preceding it. Let's now imagine that the user is trying to print
9005 the value of My_Container. If the type fixing was recursive, we would
9006 end up computing the offset of field After based on the size of the
9007 fixed version of field First. And since in our example First has
9008 only one actual field, the size of the fixed type is actually smaller
9009 than the amount of space allocated to that field, and thus we would
9010 compute the wrong offset of field After.
9012 To make things more complicated, we need to watch out for dynamic
9013 components of variant records (identified by the ___XVL suffix in
9014 the component name). Even if the target type is a PAD type, the size
9015 of that type might not be statically known. So the PAD type needs
9016 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9017 we might end up with the wrong size for our component. This can be
9018 observed with the following type declarations:
9020 type Octal is new Integer range 0 .. 7;
9021 type Octal_Array is array (Positive range <>) of Octal;
9022 pragma Pack (Octal_Array);
9024 type Octal_Buffer (Size : Positive) is record
9025 Buffer : Octal_Array (1 .. Size);
9029 In that case, Buffer is a PAD type whose size is unset and needs
9030 to be computed by fixing the unwrapped type.
9032 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9033 ----------------------------------------------------------
9035 Lastly, when should the sub-elements of an entity that remained unfixed
9036 thus far, be actually fixed?
9038 The answer is: Only when referencing that element. For instance
9039 when selecting one component of a record, this specific component
9040 should be fixed at that point in time. Or when printing the value
9041 of a record, each component should be fixed before its value gets
9042 printed. Similarly for arrays, the element of the array should be
9043 fixed when printing each element of the array, or when extracting
9044 one element out of that array. On the other hand, fixing should
9045 not be performed on the elements when taking a slice of an array!
9047 Note that one of the side-effects of miscomputing the offset and
9048 size of each field is that we end up also miscomputing the size
9049 of the containing type. This can have adverse results when computing
9050 the value of an entity. GDB fetches the value of an entity based
9051 on the size of its type, and thus a wrong size causes GDB to fetch
9052 the wrong amount of memory. In the case where the computed size is
9053 too small, GDB fetches too little data to print the value of our
9054 entiry. Results in this case as unpredicatble, as we usually read
9055 past the buffer containing the data =:-o. */
9057 /* Implement the evaluate_exp routine in the exp_descriptor structure
9058 for the Ada language. */
9060 static struct value
*
9061 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
9062 int *pos
, enum noside noside
)
9067 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
9070 struct value
**argvec
;
9074 op
= exp
->elts
[pc
].opcode
;
9080 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9081 arg1
= unwrap_value (arg1
);
9083 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
9084 then we need to perform the conversion manually, because
9085 evaluate_subexp_standard doesn't do it. This conversion is
9086 necessary in Ada because the different kinds of float/fixed
9087 types in Ada have different representations.
9089 Similarly, we need to perform the conversion from OP_LONG
9091 if ((op
== OP_DOUBLE
|| op
== OP_LONG
) && expect_type
!= NULL
)
9092 arg1
= ada_value_cast (expect_type
, arg1
, noside
);
9098 struct value
*result
;
9101 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9102 /* The result type will have code OP_STRING, bashed there from
9103 OP_ARRAY. Bash it back. */
9104 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
9105 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
9111 type
= exp
->elts
[pc
+ 1].type
;
9112 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
9113 if (noside
== EVAL_SKIP
)
9115 arg1
= ada_value_cast (type
, arg1
, noside
);
9120 type
= exp
->elts
[pc
+ 1].type
;
9121 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
9124 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9125 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9127 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
9128 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
9130 return ada_value_assign (arg1
, arg1
);
9132 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9133 except if the lhs of our assignment is a convenience variable.
9134 In the case of assigning to a convenience variable, the lhs
9135 should be exactly the result of the evaluation of the rhs. */
9136 type
= value_type (arg1
);
9137 if (VALUE_LVAL (arg1
) == lval_internalvar
)
9139 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
9140 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
9142 if (ada_is_fixed_point_type (value_type (arg1
)))
9143 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
9144 else if (ada_is_fixed_point_type (value_type (arg2
)))
9146 (_("Fixed-point values must be assigned to fixed-point variables"));
9148 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
9149 return ada_value_assign (arg1
, arg2
);
9152 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
9153 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
9154 if (noside
== EVAL_SKIP
)
9156 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
9157 return (value_from_longest
9159 value_as_long (arg1
) + value_as_long (arg2
)));
9160 if ((ada_is_fixed_point_type (value_type (arg1
))
9161 || ada_is_fixed_point_type (value_type (arg2
)))
9162 && value_type (arg1
) != value_type (arg2
))
9163 error (_("Operands of fixed-point addition must have the same type"));
9164 /* Do the addition, and cast the result to the type of the first
9165 argument. We cannot cast the result to a reference type, so if
9166 ARG1 is a reference type, find its underlying type. */
9167 type
= value_type (arg1
);
9168 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
9169 type
= TYPE_TARGET_TYPE (type
);
9170 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9171 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
9174 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
9175 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
9176 if (noside
== EVAL_SKIP
)
9178 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
9179 return (value_from_longest
9181 value_as_long (arg1
) - value_as_long (arg2
)));
9182 if ((ada_is_fixed_point_type (value_type (arg1
))
9183 || ada_is_fixed_point_type (value_type (arg2
)))
9184 && value_type (arg1
) != value_type (arg2
))
9185 error (_("Operands of fixed-point subtraction "
9186 "must have the same type"));
9187 /* Do the substraction, and cast the result to the type of the first
9188 argument. We cannot cast the result to a reference type, so if
9189 ARG1 is a reference type, find its underlying type. */
9190 type
= value_type (arg1
);
9191 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
9192 type
= TYPE_TARGET_TYPE (type
);
9193 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9194 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
9200 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9201 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9202 if (noside
== EVAL_SKIP
)
9204 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9206 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9207 return value_zero (value_type (arg1
), not_lval
);
9211 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
9212 if (ada_is_fixed_point_type (value_type (arg1
)))
9213 arg1
= cast_from_fixed (type
, arg1
);
9214 if (ada_is_fixed_point_type (value_type (arg2
)))
9215 arg2
= cast_from_fixed (type
, arg2
);
9216 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9217 return ada_value_binop (arg1
, arg2
, op
);
9221 case BINOP_NOTEQUAL
:
9222 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9223 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
9224 if (noside
== EVAL_SKIP
)
9226 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9230 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9231 tem
= ada_value_equal (arg1
, arg2
);
9233 if (op
== BINOP_NOTEQUAL
)
9235 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9236 return value_from_longest (type
, (LONGEST
) tem
);
9239 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9240 if (noside
== EVAL_SKIP
)
9242 else if (ada_is_fixed_point_type (value_type (arg1
)))
9243 return value_cast (value_type (arg1
), value_neg (arg1
));
9246 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9247 return value_neg (arg1
);
9250 case BINOP_LOGICAL_AND
:
9251 case BINOP_LOGICAL_OR
:
9252 case UNOP_LOGICAL_NOT
:
9257 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9258 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9259 return value_cast (type
, val
);
9262 case BINOP_BITWISE_AND
:
9263 case BINOP_BITWISE_IOR
:
9264 case BINOP_BITWISE_XOR
:
9268 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9270 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9272 return value_cast (value_type (arg1
), val
);
9278 if (noside
== EVAL_SKIP
)
9283 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
9284 /* Only encountered when an unresolved symbol occurs in a
9285 context other than a function call, in which case, it is
9287 error (_("Unexpected unresolved symbol, %s, during evaluation"),
9288 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
9289 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9291 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
9292 /* Check to see if this is a tagged type. We also need to handle
9293 the case where the type is a reference to a tagged type, but
9294 we have to be careful to exclude pointers to tagged types.
9295 The latter should be shown as usual (as a pointer), whereas
9296 a reference should mostly be transparent to the user. */
9297 if (ada_is_tagged_type (type
, 0)
9298 || (TYPE_CODE(type
) == TYPE_CODE_REF
9299 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
9301 /* Tagged types are a little special in the fact that the real
9302 type is dynamic and can only be determined by inspecting the
9303 object's tag. This means that we need to get the object's
9304 value first (EVAL_NORMAL) and then extract the actual object
9307 Note that we cannot skip the final step where we extract
9308 the object type from its tag, because the EVAL_NORMAL phase
9309 results in dynamic components being resolved into fixed ones.
9310 This can cause problems when trying to print the type
9311 description of tagged types whose parent has a dynamic size:
9312 We use the type name of the "_parent" component in order
9313 to print the name of the ancestor type in the type description.
9314 If that component had a dynamic size, the resolution into
9315 a fixed type would result in the loss of that type name,
9316 thus preventing us from printing the name of the ancestor
9317 type in the type description. */
9318 struct type
*actual_type
;
9320 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
9321 actual_type
= type_from_tag (ada_value_tag (arg1
));
9322 if (actual_type
== NULL
)
9323 /* If, for some reason, we were unable to determine
9324 the actual type from the tag, then use the static
9325 approximation that we just computed as a fallback.
9326 This can happen if the debugging information is
9327 incomplete, for instance. */
9330 return value_zero (actual_type
, not_lval
);
9335 (to_static_fixed_type
9336 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
9341 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9342 arg1
= unwrap_value (arg1
);
9343 return ada_to_fixed_value (arg1
);
9349 /* Allocate arg vector, including space for the function to be
9350 called in argvec[0] and a terminating NULL. */
9351 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9353 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
9355 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
9356 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
9357 error (_("Unexpected unresolved symbol, %s, during evaluation"),
9358 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
9361 for (tem
= 0; tem
<= nargs
; tem
+= 1)
9362 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9365 if (noside
== EVAL_SKIP
)
9369 if (ada_is_constrained_packed_array_type
9370 (desc_base_type (value_type (argvec
[0]))))
9371 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
9372 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
9373 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
9374 /* This is a packed array that has already been fixed, and
9375 therefore already coerced to a simple array. Nothing further
9378 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
9379 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
9380 && VALUE_LVAL (argvec
[0]) == lval_memory
))
9381 argvec
[0] = value_addr (argvec
[0]);
9383 type
= ada_check_typedef (value_type (argvec
[0]));
9385 /* Ada allows us to implicitly dereference arrays when subscripting
9386 them. So, if this is an typedef (encoding use for array access
9387 types encoded as fat pointers), strip it now. */
9388 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
9389 type
= ada_typedef_target_type (type
);
9391 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
9393 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
9395 case TYPE_CODE_FUNC
:
9396 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
9398 case TYPE_CODE_ARRAY
:
9400 case TYPE_CODE_STRUCT
:
9401 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
9402 argvec
[0] = ada_value_ind (argvec
[0]);
9403 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
9406 error (_("cannot subscript or call something of type `%s'"),
9407 ada_type_name (value_type (argvec
[0])));
9412 switch (TYPE_CODE (type
))
9414 case TYPE_CODE_FUNC
:
9415 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9416 return allocate_value (TYPE_TARGET_TYPE (type
));
9417 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
9418 case TYPE_CODE_STRUCT
:
9422 arity
= ada_array_arity (type
);
9423 type
= ada_array_element_type (type
, nargs
);
9425 error (_("cannot subscript or call a record"));
9427 error (_("wrong number of subscripts; expecting %d"), arity
);
9428 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9429 return value_zero (ada_aligned_type (type
), lval_memory
);
9431 unwrap_value (ada_value_subscript
9432 (argvec
[0], nargs
, argvec
+ 1));
9434 case TYPE_CODE_ARRAY
:
9435 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9437 type
= ada_array_element_type (type
, nargs
);
9439 error (_("element type of array unknown"));
9441 return value_zero (ada_aligned_type (type
), lval_memory
);
9444 unwrap_value (ada_value_subscript
9445 (ada_coerce_to_simple_array (argvec
[0]),
9446 nargs
, argvec
+ 1));
9447 case TYPE_CODE_PTR
: /* Pointer to array */
9448 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
9449 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9451 type
= ada_array_element_type (type
, nargs
);
9453 error (_("element type of array unknown"));
9455 return value_zero (ada_aligned_type (type
), lval_memory
);
9458 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
9459 nargs
, argvec
+ 1));
9462 error (_("Attempt to index or call something other than an "
9463 "array or function"));
9468 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9469 struct value
*low_bound_val
=
9470 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9471 struct value
*high_bound_val
=
9472 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9476 low_bound_val
= coerce_ref (low_bound_val
);
9477 high_bound_val
= coerce_ref (high_bound_val
);
9478 low_bound
= pos_atr (low_bound_val
);
9479 high_bound
= pos_atr (high_bound_val
);
9481 if (noside
== EVAL_SKIP
)
9484 /* If this is a reference to an aligner type, then remove all
9486 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
9487 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
9488 TYPE_TARGET_TYPE (value_type (array
)) =
9489 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
9491 if (ada_is_constrained_packed_array_type (value_type (array
)))
9492 error (_("cannot slice a packed array"));
9494 /* If this is a reference to an array or an array lvalue,
9495 convert to a pointer. */
9496 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
9497 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
9498 && VALUE_LVAL (array
) == lval_memory
))
9499 array
= value_addr (array
);
9501 if (noside
== EVAL_AVOID_SIDE_EFFECTS
9502 && ada_is_array_descriptor_type (ada_check_typedef
9503 (value_type (array
))))
9504 return empty_array (ada_type_of_array (array
, 0), low_bound
);
9506 array
= ada_coerce_to_simple_array_ptr (array
);
9508 /* If we have more than one level of pointer indirection,
9509 dereference the value until we get only one level. */
9510 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
9511 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
9513 array
= value_ind (array
);
9515 /* Make sure we really do have an array type before going further,
9516 to avoid a SEGV when trying to get the index type or the target
9517 type later down the road if the debug info generated by
9518 the compiler is incorrect or incomplete. */
9519 if (!ada_is_simple_array_type (value_type (array
)))
9520 error (_("cannot take slice of non-array"));
9522 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
9524 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
9525 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
9529 struct type
*arr_type0
=
9530 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
9533 return ada_value_slice_from_ptr (array
, arr_type0
,
9534 longest_to_int (low_bound
),
9535 longest_to_int (high_bound
));
9538 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9540 else if (high_bound
< low_bound
)
9541 return empty_array (value_type (array
), low_bound
);
9543 return ada_value_slice (array
, longest_to_int (low_bound
),
9544 longest_to_int (high_bound
));
9549 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9550 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
9552 if (noside
== EVAL_SKIP
)
9555 switch (TYPE_CODE (type
))
9558 lim_warning (_("Membership test incompletely implemented; "
9559 "always returns true"));
9560 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9561 return value_from_longest (type
, (LONGEST
) 1);
9563 case TYPE_CODE_RANGE
:
9564 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
9565 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
9566 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9567 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
9568 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9570 value_from_longest (type
,
9571 (value_less (arg1
, arg3
)
9572 || value_equal (arg1
, arg3
))
9573 && (value_less (arg2
, arg1
)
9574 || value_equal (arg2
, arg1
)));
9577 case BINOP_IN_BOUNDS
:
9579 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9580 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9582 if (noside
== EVAL_SKIP
)
9585 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9587 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9588 return value_zero (type
, not_lval
);
9591 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9593 type
= ada_index_type (value_type (arg2
), tem
, "range");
9595 type
= value_type (arg1
);
9597 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
9598 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
9600 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9601 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
9602 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9604 value_from_longest (type
,
9605 (value_less (arg1
, arg3
)
9606 || value_equal (arg1
, arg3
))
9607 && (value_less (arg2
, arg1
)
9608 || value_equal (arg2
, arg1
)));
9610 case TERNOP_IN_RANGE
:
9611 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9612 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9613 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9615 if (noside
== EVAL_SKIP
)
9618 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9619 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
9620 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9622 value_from_longest (type
,
9623 (value_less (arg1
, arg3
)
9624 || value_equal (arg1
, arg3
))
9625 && (value_less (arg2
, arg1
)
9626 || value_equal (arg2
, arg1
)));
9632 struct type
*type_arg
;
9634 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
9636 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9638 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
9642 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9646 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
9647 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
9648 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
9651 if (noside
== EVAL_SKIP
)
9654 if (type_arg
== NULL
)
9656 arg1
= ada_coerce_ref (arg1
);
9658 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
9659 arg1
= ada_coerce_to_simple_array (arg1
);
9661 type
= ada_index_type (value_type (arg1
), tem
,
9662 ada_attribute_name (op
));
9664 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9666 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9667 return allocate_value (type
);
9671 default: /* Should never happen. */
9672 error (_("unexpected attribute encountered"));
9674 return value_from_longest
9675 (type
, ada_array_bound (arg1
, tem
, 0));
9677 return value_from_longest
9678 (type
, ada_array_bound (arg1
, tem
, 1));
9680 return value_from_longest
9681 (type
, ada_array_length (arg1
, tem
));
9684 else if (discrete_type_p (type_arg
))
9686 struct type
*range_type
;
9687 char *name
= ada_type_name (type_arg
);
9690 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
9691 range_type
= to_fixed_range_type (type_arg
, NULL
);
9692 if (range_type
== NULL
)
9693 range_type
= type_arg
;
9697 error (_("unexpected attribute encountered"));
9699 return value_from_longest
9700 (range_type
, ada_discrete_type_low_bound (range_type
));
9702 return value_from_longest
9703 (range_type
, ada_discrete_type_high_bound (range_type
));
9705 error (_("the 'length attribute applies only to array types"));
9708 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
9709 error (_("unimplemented type attribute"));
9714 if (ada_is_constrained_packed_array_type (type_arg
))
9715 type_arg
= decode_constrained_packed_array_type (type_arg
);
9717 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
9719 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9721 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9722 return allocate_value (type
);
9727 error (_("unexpected attribute encountered"));
9729 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
9730 return value_from_longest (type
, low
);
9732 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
9733 return value_from_longest (type
, high
);
9735 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
9736 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
9737 return value_from_longest (type
, high
- low
+ 1);
9743 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9744 if (noside
== EVAL_SKIP
)
9747 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9748 return value_zero (ada_tag_type (arg1
), not_lval
);
9750 return ada_value_tag (arg1
);
9754 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9755 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9756 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9757 if (noside
== EVAL_SKIP
)
9759 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9760 return value_zero (value_type (arg1
), not_lval
);
9763 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9764 return value_binop (arg1
, arg2
,
9765 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
9768 case OP_ATR_MODULUS
:
9770 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
9772 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9773 if (noside
== EVAL_SKIP
)
9776 if (!ada_is_modular_type (type_arg
))
9777 error (_("'modulus must be applied to modular type"));
9779 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
9780 ada_modulus (type_arg
));
9785 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9786 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9787 if (noside
== EVAL_SKIP
)
9789 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9790 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9791 return value_zero (type
, not_lval
);
9793 return value_pos_atr (type
, arg1
);
9796 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9797 type
= value_type (arg1
);
9799 /* If the argument is a reference, then dereference its type, since
9800 the user is really asking for the size of the actual object,
9801 not the size of the pointer. */
9802 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
9803 type
= TYPE_TARGET_TYPE (type
);
9805 if (noside
== EVAL_SKIP
)
9807 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9808 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
9810 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
9811 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
9814 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9815 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9816 type
= exp
->elts
[pc
+ 2].type
;
9817 if (noside
== EVAL_SKIP
)
9819 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9820 return value_zero (type
, not_lval
);
9822 return value_val_atr (type
, arg1
);
9825 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9826 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9827 if (noside
== EVAL_SKIP
)
9829 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9830 return value_zero (value_type (arg1
), not_lval
);
9833 /* For integer exponentiation operations,
9834 only promote the first argument. */
9835 if (is_integral_type (value_type (arg2
)))
9836 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9838 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9840 return value_binop (arg1
, arg2
, op
);
9844 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9845 if (noside
== EVAL_SKIP
)
9851 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9852 if (noside
== EVAL_SKIP
)
9854 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9855 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
9856 return value_neg (arg1
);
9861 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9862 if (noside
== EVAL_SKIP
)
9864 type
= ada_check_typedef (value_type (arg1
));
9865 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9867 if (ada_is_array_descriptor_type (type
))
9868 /* GDB allows dereferencing GNAT array descriptors. */
9870 struct type
*arrType
= ada_type_of_array (arg1
, 0);
9872 if (arrType
== NULL
)
9873 error (_("Attempt to dereference null array pointer."));
9874 return value_at_lazy (arrType
, 0);
9876 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
9877 || TYPE_CODE (type
) == TYPE_CODE_REF
9878 /* In C you can dereference an array to get the 1st elt. */
9879 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9881 type
= to_static_fixed_type
9883 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
9885 return value_zero (type
, lval_memory
);
9887 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9889 /* GDB allows dereferencing an int. */
9890 if (expect_type
== NULL
)
9891 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
9896 to_static_fixed_type (ada_aligned_type (expect_type
));
9897 return value_zero (expect_type
, lval_memory
);
9901 error (_("Attempt to take contents of a non-pointer value."));
9903 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
9904 type
= ada_check_typedef (value_type (arg1
));
9906 if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9907 /* GDB allows dereferencing an int. If we were given
9908 the expect_type, then use that as the target type.
9909 Otherwise, assume that the target type is an int. */
9911 if (expect_type
!= NULL
)
9912 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
9915 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
9916 (CORE_ADDR
) value_as_address (arg1
));
9919 if (ada_is_array_descriptor_type (type
))
9920 /* GDB allows dereferencing GNAT array descriptors. */
9921 return ada_coerce_to_simple_array (arg1
);
9923 return ada_value_ind (arg1
);
9925 case STRUCTOP_STRUCT
:
9926 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9927 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
9928 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9929 if (noside
== EVAL_SKIP
)
9931 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9933 struct type
*type1
= value_type (arg1
);
9935 if (ada_is_tagged_type (type1
, 1))
9937 type
= ada_lookup_struct_elt_type (type1
,
9938 &exp
->elts
[pc
+ 2].string
,
9941 /* In this case, we assume that the field COULD exist
9942 in some extension of the type. Return an object of
9943 "type" void, which will match any formal
9944 (see ada_type_match). */
9945 return value_zero (builtin_type (exp
->gdbarch
)->builtin_void
,
9950 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
9953 return value_zero (ada_aligned_type (type
), lval_memory
);
9956 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
9957 arg1
= unwrap_value (arg1
);
9958 return ada_to_fixed_value (arg1
);
9961 /* The value is not supposed to be used. This is here to make it
9962 easier to accommodate expressions that contain types. */
9964 if (noside
== EVAL_SKIP
)
9966 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9967 return allocate_value (exp
->elts
[pc
+ 1].type
);
9969 error (_("Attempt to use a type name as an expression"));
9974 case OP_DISCRETE_RANGE
:
9977 if (noside
== EVAL_NORMAL
)
9981 error (_("Undefined name, ambiguous name, or renaming used in "
9982 "component association: %s."), &exp
->elts
[pc
+2].string
);
9984 error (_("Aggregates only allowed on the right of an assignment"));
9986 internal_error (__FILE__
, __LINE__
,
9987 _("aggregate apparently mangled"));
9990 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
9992 for (tem
= 0; tem
< nargs
; tem
+= 1)
9993 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9998 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
, 1);
10004 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
10005 type name that encodes the 'small and 'delta information.
10006 Otherwise, return NULL. */
10008 static const char *
10009 fixed_type_info (struct type
*type
)
10011 const char *name
= ada_type_name (type
);
10012 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
10014 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
10016 const char *tail
= strstr (name
, "___XF_");
10023 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
10024 return fixed_type_info (TYPE_TARGET_TYPE (type
));
10029 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
10032 ada_is_fixed_point_type (struct type
*type
)
10034 return fixed_type_info (type
) != NULL
;
10037 /* Return non-zero iff TYPE represents a System.Address type. */
10040 ada_is_system_address_type (struct type
*type
)
10042 return (TYPE_NAME (type
)
10043 && strcmp (TYPE_NAME (type
), "system__address") == 0);
10046 /* Assuming that TYPE is the representation of an Ada fixed-point
10047 type, return its delta, or -1 if the type is malformed and the
10048 delta cannot be determined. */
10051 ada_delta (struct type
*type
)
10053 const char *encoding
= fixed_type_info (type
);
10056 /* Strictly speaking, num and den are encoded as integer. However,
10057 they may not fit into a long, and they will have to be converted
10058 to DOUBLEST anyway. So scan them as DOUBLEST. */
10059 if (sscanf (encoding
, "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
,
10066 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
10067 factor ('SMALL value) associated with the type. */
10070 scaling_factor (struct type
*type
)
10072 const char *encoding
= fixed_type_info (type
);
10073 DOUBLEST num0
, den0
, num1
, den1
;
10076 /* Strictly speaking, num's and den's are encoded as integer. However,
10077 they may not fit into a long, and they will have to be converted
10078 to DOUBLEST anyway. So scan them as DOUBLEST. */
10079 n
= sscanf (encoding
,
10080 "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
10081 "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
,
10082 &num0
, &den0
, &num1
, &den1
);
10087 return num1
/ den1
;
10089 return num0
/ den0
;
10093 /* Assuming that X is the representation of a value of fixed-point
10094 type TYPE, return its floating-point equivalent. */
10097 ada_fixed_to_float (struct type
*type
, LONGEST x
)
10099 return (DOUBLEST
) x
*scaling_factor (type
);
10102 /* The representation of a fixed-point value of type TYPE
10103 corresponding to the value X. */
10106 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
10108 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
10115 /* Scan STR beginning at position K for a discriminant name, and
10116 return the value of that discriminant field of DVAL in *PX. If
10117 PNEW_K is not null, put the position of the character beyond the
10118 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
10119 not alter *PX and *PNEW_K if unsuccessful. */
10122 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
10125 static char *bound_buffer
= NULL
;
10126 static size_t bound_buffer_len
= 0;
10129 struct value
*bound_val
;
10131 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
10134 pend
= strstr (str
+ k
, "__");
10138 k
+= strlen (bound
);
10142 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
10143 bound
= bound_buffer
;
10144 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
10145 bound
[pend
- (str
+ k
)] = '\0';
10149 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
10150 if (bound_val
== NULL
)
10153 *px
= value_as_long (bound_val
);
10154 if (pnew_k
!= NULL
)
10159 /* Value of variable named NAME in the current environment. If
10160 no such variable found, then if ERR_MSG is null, returns 0, and
10161 otherwise causes an error with message ERR_MSG. */
10163 static struct value
*
10164 get_var_value (char *name
, char *err_msg
)
10166 struct ada_symbol_info
*syms
;
10169 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
10174 if (err_msg
== NULL
)
10177 error (("%s"), err_msg
);
10180 return value_of_variable (syms
[0].sym
, syms
[0].block
);
10183 /* Value of integer variable named NAME in the current environment. If
10184 no such variable found, returns 0, and sets *FLAG to 0. If
10185 successful, sets *FLAG to 1. */
10188 get_int_var_value (char *name
, int *flag
)
10190 struct value
*var_val
= get_var_value (name
, 0);
10202 return value_as_long (var_val
);
10207 /* Return a range type whose base type is that of the range type named
10208 NAME in the current environment, and whose bounds are calculated
10209 from NAME according to the GNAT range encoding conventions.
10210 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
10211 corresponding range type from debug information; fall back to using it
10212 if symbol lookup fails. If a new type must be created, allocate it
10213 like ORIG_TYPE was. The bounds information, in general, is encoded
10214 in NAME, the base type given in the named range type. */
10216 static struct type
*
10217 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
10220 struct type
*base_type
;
10221 char *subtype_info
;
10223 gdb_assert (raw_type
!= NULL
);
10224 gdb_assert (TYPE_NAME (raw_type
) != NULL
);
10226 if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
10227 base_type
= TYPE_TARGET_TYPE (raw_type
);
10229 base_type
= raw_type
;
10231 name
= TYPE_NAME (raw_type
);
10232 subtype_info
= strstr (name
, "___XD");
10233 if (subtype_info
== NULL
)
10235 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
10236 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
10238 if (L
< INT_MIN
|| U
> INT_MAX
)
10241 return create_range_type (alloc_type_copy (raw_type
), raw_type
,
10242 ada_discrete_type_low_bound (raw_type
),
10243 ada_discrete_type_high_bound (raw_type
));
10247 static char *name_buf
= NULL
;
10248 static size_t name_len
= 0;
10249 int prefix_len
= subtype_info
- name
;
10255 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
10256 strncpy (name_buf
, name
, prefix_len
);
10257 name_buf
[prefix_len
] = '\0';
10260 bounds_str
= strchr (subtype_info
, '_');
10263 if (*subtype_info
== 'L')
10265 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
10266 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
10268 if (bounds_str
[n
] == '_')
10270 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
10278 strcpy (name_buf
+ prefix_len
, "___L");
10279 L
= get_int_var_value (name_buf
, &ok
);
10282 lim_warning (_("Unknown lower bound, using 1."));
10287 if (*subtype_info
== 'U')
10289 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
10290 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
10297 strcpy (name_buf
+ prefix_len
, "___U");
10298 U
= get_int_var_value (name_buf
, &ok
);
10301 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
10306 type
= create_range_type (alloc_type_copy (raw_type
), base_type
, L
, U
);
10307 TYPE_NAME (type
) = name
;
10312 /* True iff NAME is the name of a range type. */
10315 ada_is_range_type_name (const char *name
)
10317 return (name
!= NULL
&& strstr (name
, "___XD"));
10321 /* Modular types */
10323 /* True iff TYPE is an Ada modular type. */
10326 ada_is_modular_type (struct type
*type
)
10328 struct type
*subranged_type
= base_type (type
);
10330 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
10331 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
10332 && TYPE_UNSIGNED (subranged_type
));
10335 /* Try to determine the lower and upper bounds of the given modular type
10336 using the type name only. Return non-zero and set L and U as the lower
10337 and upper bounds (respectively) if successful. */
10340 ada_modulus_from_name (struct type
*type
, ULONGEST
*modulus
)
10342 char *name
= ada_type_name (type
);
10350 /* Discrete type bounds are encoded using an __XD suffix. In our case,
10351 we are looking for static bounds, which means an __XDLU suffix.
10352 Moreover, we know that the lower bound of modular types is always
10353 zero, so the actual suffix should start with "__XDLU_0__", and
10354 then be followed by the upper bound value. */
10355 suffix
= strstr (name
, "__XDLU_0__");
10356 if (suffix
== NULL
)
10359 if (!ada_scan_number (suffix
, k
, &U
, NULL
))
10362 *modulus
= (ULONGEST
) U
+ 1;
10366 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
10369 ada_modulus (struct type
*type
)
10371 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
10375 /* Ada exception catchpoint support:
10376 ---------------------------------
10378 We support 3 kinds of exception catchpoints:
10379 . catchpoints on Ada exceptions
10380 . catchpoints on unhandled Ada exceptions
10381 . catchpoints on failed assertions
10383 Exceptions raised during failed assertions, or unhandled exceptions
10384 could perfectly be caught with the general catchpoint on Ada exceptions.
10385 However, we can easily differentiate these two special cases, and having
10386 the option to distinguish these two cases from the rest can be useful
10387 to zero-in on certain situations.
10389 Exception catchpoints are a specialized form of breakpoint,
10390 since they rely on inserting breakpoints inside known routines
10391 of the GNAT runtime. The implementation therefore uses a standard
10392 breakpoint structure of the BP_BREAKPOINT type, but with its own set
10395 Support in the runtime for exception catchpoints have been changed
10396 a few times already, and these changes affect the implementation
10397 of these catchpoints. In order to be able to support several
10398 variants of the runtime, we use a sniffer that will determine
10399 the runtime variant used by the program being debugged. */
10401 /* The different types of catchpoints that we introduced for catching
10404 enum exception_catchpoint_kind
10406 ex_catch_exception
,
10407 ex_catch_exception_unhandled
,
10411 /* Ada's standard exceptions. */
10413 static char *standard_exc
[] = {
10414 "constraint_error",
10420 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
10422 /* A structure that describes how to support exception catchpoints
10423 for a given executable. */
10425 struct exception_support_info
10427 /* The name of the symbol to break on in order to insert
10428 a catchpoint on exceptions. */
10429 const char *catch_exception_sym
;
10431 /* The name of the symbol to break on in order to insert
10432 a catchpoint on unhandled exceptions. */
10433 const char *catch_exception_unhandled_sym
;
10435 /* The name of the symbol to break on in order to insert
10436 a catchpoint on failed assertions. */
10437 const char *catch_assert_sym
;
10439 /* Assuming that the inferior just triggered an unhandled exception
10440 catchpoint, this function is responsible for returning the address
10441 in inferior memory where the name of that exception is stored.
10442 Return zero if the address could not be computed. */
10443 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
10446 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
10447 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
10449 /* The following exception support info structure describes how to
10450 implement exception catchpoints with the latest version of the
10451 Ada runtime (as of 2007-03-06). */
10453 static const struct exception_support_info default_exception_support_info
=
10455 "__gnat_debug_raise_exception", /* catch_exception_sym */
10456 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10457 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
10458 ada_unhandled_exception_name_addr
10461 /* The following exception support info structure describes how to
10462 implement exception catchpoints with a slightly older version
10463 of the Ada runtime. */
10465 static const struct exception_support_info exception_support_info_fallback
=
10467 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
10468 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10469 "system__assertions__raise_assert_failure", /* catch_assert_sym */
10470 ada_unhandled_exception_name_addr_from_raise
10473 /* For each executable, we sniff which exception info structure to use
10474 and cache it in the following global variable. */
10476 static const struct exception_support_info
*exception_info
= NULL
;
10478 /* Inspect the Ada runtime and determine which exception info structure
10479 should be used to provide support for exception catchpoints.
10481 This function will always set exception_info, or raise an error. */
10484 ada_exception_support_info_sniffer (void)
10486 struct symbol
*sym
;
10488 /* If the exception info is already known, then no need to recompute it. */
10489 if (exception_info
!= NULL
)
10492 /* Check the latest (default) exception support info. */
10493 sym
= standard_lookup (default_exception_support_info
.catch_exception_sym
,
10497 exception_info
= &default_exception_support_info
;
10501 /* Try our fallback exception suport info. */
10502 sym
= standard_lookup (exception_support_info_fallback
.catch_exception_sym
,
10506 exception_info
= &exception_support_info_fallback
;
10510 /* Sometimes, it is normal for us to not be able to find the routine
10511 we are looking for. This happens when the program is linked with
10512 the shared version of the GNAT runtime, and the program has not been
10513 started yet. Inform the user of these two possible causes if
10516 if (ada_update_initial_language (language_unknown
) != language_ada
)
10517 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
10519 /* If the symbol does not exist, then check that the program is
10520 already started, to make sure that shared libraries have been
10521 loaded. If it is not started, this may mean that the symbol is
10522 in a shared library. */
10524 if (ptid_get_pid (inferior_ptid
) == 0)
10525 error (_("Unable to insert catchpoint. Try to start the program first."));
10527 /* At this point, we know that we are debugging an Ada program and
10528 that the inferior has been started, but we still are not able to
10529 find the run-time symbols. That can mean that we are in
10530 configurable run time mode, or that a-except as been optimized
10531 out by the linker... In any case, at this point it is not worth
10532 supporting this feature. */
10534 error (_("Cannot insert catchpoints in this configuration."));
10537 /* An observer of "executable_changed" events.
10538 Its role is to clear certain cached values that need to be recomputed
10539 each time a new executable is loaded by GDB. */
10542 ada_executable_changed_observer (void)
10544 /* If the executable changed, then it is possible that the Ada runtime
10545 is different. So we need to invalidate the exception support info
10547 exception_info
= NULL
;
10550 /* True iff FRAME is very likely to be that of a function that is
10551 part of the runtime system. This is all very heuristic, but is
10552 intended to be used as advice as to what frames are uninteresting
10556 is_known_support_routine (struct frame_info
*frame
)
10558 struct symtab_and_line sal
;
10560 enum language func_lang
;
10563 /* If this code does not have any debugging information (no symtab),
10564 This cannot be any user code. */
10566 find_frame_sal (frame
, &sal
);
10567 if (sal
.symtab
== NULL
)
10570 /* If there is a symtab, but the associated source file cannot be
10571 located, then assume this is not user code: Selecting a frame
10572 for which we cannot display the code would not be very helpful
10573 for the user. This should also take care of case such as VxWorks
10574 where the kernel has some debugging info provided for a few units. */
10576 if (symtab_to_fullname (sal
.symtab
) == NULL
)
10579 /* Check the unit filename againt the Ada runtime file naming.
10580 We also check the name of the objfile against the name of some
10581 known system libraries that sometimes come with debugging info
10584 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
10586 re_comp (known_runtime_file_name_patterns
[i
]);
10587 if (re_exec (sal
.symtab
->filename
))
10589 if (sal
.symtab
->objfile
!= NULL
10590 && re_exec (sal
.symtab
->objfile
->name
))
10594 /* Check whether the function is a GNAT-generated entity. */
10596 find_frame_funname (frame
, &func_name
, &func_lang
, NULL
);
10597 if (func_name
== NULL
)
10600 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
10602 re_comp (known_auxiliary_function_name_patterns
[i
]);
10603 if (re_exec (func_name
))
10610 /* Find the first frame that contains debugging information and that is not
10611 part of the Ada run-time, starting from FI and moving upward. */
10614 ada_find_printable_frame (struct frame_info
*fi
)
10616 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
10618 if (!is_known_support_routine (fi
))
10627 /* Assuming that the inferior just triggered an unhandled exception
10628 catchpoint, return the address in inferior memory where the name
10629 of the exception is stored.
10631 Return zero if the address could not be computed. */
10634 ada_unhandled_exception_name_addr (void)
10636 return parse_and_eval_address ("e.full_name");
10639 /* Same as ada_unhandled_exception_name_addr, except that this function
10640 should be used when the inferior uses an older version of the runtime,
10641 where the exception name needs to be extracted from a specific frame
10642 several frames up in the callstack. */
10645 ada_unhandled_exception_name_addr_from_raise (void)
10648 struct frame_info
*fi
;
10650 /* To determine the name of this exception, we need to select
10651 the frame corresponding to RAISE_SYM_NAME. This frame is
10652 at least 3 levels up, so we simply skip the first 3 frames
10653 without checking the name of their associated function. */
10654 fi
= get_current_frame ();
10655 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
10657 fi
= get_prev_frame (fi
);
10662 enum language func_lang
;
10664 find_frame_funname (fi
, &func_name
, &func_lang
, NULL
);
10665 if (func_name
!= NULL
10666 && strcmp (func_name
, exception_info
->catch_exception_sym
) == 0)
10667 break; /* We found the frame we were looking for... */
10668 fi
= get_prev_frame (fi
);
10675 return parse_and_eval_address ("id.full_name");
10678 /* Assuming the inferior just triggered an Ada exception catchpoint
10679 (of any type), return the address in inferior memory where the name
10680 of the exception is stored, if applicable.
10682 Return zero if the address could not be computed, or if not relevant. */
10685 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex
,
10686 struct breakpoint
*b
)
10690 case ex_catch_exception
:
10691 return (parse_and_eval_address ("e.full_name"));
10694 case ex_catch_exception_unhandled
:
10695 return exception_info
->unhandled_exception_name_addr ();
10698 case ex_catch_assert
:
10699 return 0; /* Exception name is not relevant in this case. */
10703 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10707 return 0; /* Should never be reached. */
10710 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
10711 any error that ada_exception_name_addr_1 might cause to be thrown.
10712 When an error is intercepted, a warning with the error message is printed,
10713 and zero is returned. */
10716 ada_exception_name_addr (enum exception_catchpoint_kind ex
,
10717 struct breakpoint
*b
)
10719 struct gdb_exception e
;
10720 CORE_ADDR result
= 0;
10722 TRY_CATCH (e
, RETURN_MASK_ERROR
)
10724 result
= ada_exception_name_addr_1 (ex
, b
);
10729 warning (_("failed to get exception name: %s"), e
.message
);
10736 static struct symtab_and_line
ada_exception_sal (enum exception_catchpoint_kind
,
10738 struct breakpoint_ops
**);
10739 static char *ada_exception_catchpoint_cond_string (const char *excep_string
);
10741 /* Ada catchpoints.
10743 In the case of catchpoints on Ada exceptions, the catchpoint will
10744 stop the target on every exception the program throws. When a user
10745 specifies the name of a specific exception, we translate this
10746 request into a condition expression (in text form), and then parse
10747 it into an expression stored in each of the catchpoint's locations.
10748 We then use this condition to check whether the exception that was
10749 raised is the one the user is interested in. If not, then the
10750 target is resumed again. We store the name of the requested
10751 exception, in order to be able to re-set the condition expression
10752 when symbols change. */
10754 /* An instance of this type is used to represent an Ada catchpoint
10755 breakpoint location. It includes a "struct bp_location" as a kind
10756 of base class; users downcast to "struct bp_location *" when
10759 struct ada_catchpoint_location
10761 /* The base class. */
10762 struct bp_location base
;
10764 /* The condition that checks whether the exception that was raised
10765 is the specific exception the user specified on catchpoint
10767 struct expression
*excep_cond_expr
;
10770 /* Implement the DTOR method in the bp_location_ops structure for all
10771 Ada exception catchpoint kinds. */
10774 ada_catchpoint_location_dtor (struct bp_location
*bl
)
10776 struct ada_catchpoint_location
*al
= (struct ada_catchpoint_location
*) bl
;
10778 xfree (al
->excep_cond_expr
);
10781 /* The vtable to be used in Ada catchpoint locations. */
10783 static const struct bp_location_ops ada_catchpoint_location_ops
=
10785 ada_catchpoint_location_dtor
10788 /* An instance of this type is used to represent an Ada catchpoint.
10789 It includes a "struct breakpoint" as a kind of base class; users
10790 downcast to "struct breakpoint *" when needed. */
10792 struct ada_catchpoint
10794 /* The base class. */
10795 struct breakpoint base
;
10797 /* The name of the specific exception the user specified. */
10798 char *excep_string
;
10801 /* Parse the exception condition string in the context of each of the
10802 catchpoint's locations, and store them for later evaluation. */
10805 create_excep_cond_exprs (struct ada_catchpoint
*c
)
10807 struct cleanup
*old_chain
;
10808 struct bp_location
*bl
;
10811 /* Nothing to do if there's no specific exception to catch. */
10812 if (c
->excep_string
== NULL
)
10815 /* Same if there are no locations... */
10816 if (c
->base
.loc
== NULL
)
10819 /* Compute the condition expression in text form, from the specific
10820 expection we want to catch. */
10821 cond_string
= ada_exception_catchpoint_cond_string (c
->excep_string
);
10822 old_chain
= make_cleanup (xfree
, cond_string
);
10824 /* Iterate over all the catchpoint's locations, and parse an
10825 expression for each. */
10826 for (bl
= c
->base
.loc
; bl
!= NULL
; bl
= bl
->next
)
10828 struct ada_catchpoint_location
*ada_loc
10829 = (struct ada_catchpoint_location
*) bl
;
10830 struct expression
*exp
= NULL
;
10832 if (!bl
->shlib_disabled
)
10834 volatile struct gdb_exception e
;
10838 TRY_CATCH (e
, RETURN_MASK_ERROR
)
10840 exp
= parse_exp_1 (&s
, block_for_pc (bl
->address
), 0);
10843 warning (_("failed to reevaluate internal exception condition "
10844 "for catchpoint %d: %s"),
10845 c
->base
.number
, e
.message
);
10848 ada_loc
->excep_cond_expr
= exp
;
10851 do_cleanups (old_chain
);
10854 /* Implement the DTOR method in the breakpoint_ops structure for all
10855 exception catchpoint kinds. */
10858 dtor_exception (enum exception_catchpoint_kind ex
, struct breakpoint
*b
)
10860 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
10862 xfree (c
->excep_string
);
10865 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
10866 structure for all exception catchpoint kinds. */
10868 static struct bp_location
*
10869 allocate_location_exception (enum exception_catchpoint_kind ex
,
10870 struct breakpoint
*self
)
10872 struct ada_catchpoint_location
*loc
;
10874 loc
= XNEW (struct ada_catchpoint_location
);
10875 init_bp_location (&loc
->base
, &ada_catchpoint_location_ops
, self
);
10876 loc
->excep_cond_expr
= NULL
;
10880 /* Implement the RE_SET method in the breakpoint_ops structure for all
10881 exception catchpoint kinds. */
10884 re_set_exception (enum exception_catchpoint_kind ex
, struct breakpoint
*b
)
10886 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
10888 /* Call the base class's method. This updates the catchpoint's
10890 breakpoint_re_set_default (b
);
10892 /* Reparse the exception conditional expressions. One for each
10894 create_excep_cond_exprs (c
);
10897 /* Returns true if we should stop for this breakpoint hit. If the
10898 user specified a specific exception, we only want to cause a stop
10899 if the program thrown that exception. */
10902 should_stop_exception (const struct bp_location
*bl
)
10904 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
10905 const struct ada_catchpoint_location
*ada_loc
10906 = (const struct ada_catchpoint_location
*) bl
;
10907 volatile struct gdb_exception ex
;
10910 /* With no specific exception, should always stop. */
10911 if (c
->excep_string
== NULL
)
10914 if (ada_loc
->excep_cond_expr
== NULL
)
10916 /* We will have a NULL expression if back when we were creating
10917 the expressions, this location's had failed to parse. */
10922 TRY_CATCH (ex
, RETURN_MASK_ALL
)
10924 struct value
*mark
;
10926 mark
= value_mark ();
10927 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
));
10928 value_free_to_mark (mark
);
10931 exception_fprintf (gdb_stderr
, ex
,
10932 _("Error in testing exception condition:\n"));
10936 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
10937 for all exception catchpoint kinds. */
10940 check_status_exception (enum exception_catchpoint_kind ex
, bpstat bs
)
10942 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
10945 /* Implement the PRINT_IT method in the breakpoint_ops structure
10946 for all exception catchpoint kinds. */
10948 static enum print_stop_action
10949 print_it_exception (enum exception_catchpoint_kind ex
, struct breakpoint
*b
)
10951 annotate_catchpoint (b
->number
);
10953 if (ui_out_is_mi_like_p (uiout
))
10955 ui_out_field_string (uiout
, "reason",
10956 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
10957 ui_out_field_string (uiout
, "disp", bpdisp_text (b
->disposition
));
10960 ui_out_text (uiout
, "\nCatchpoint ");
10961 ui_out_field_int (uiout
, "bkptno", b
->number
);
10962 ui_out_text (uiout
, ", ");
10966 case ex_catch_exception
:
10967 case ex_catch_exception_unhandled
:
10969 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
10970 char exception_name
[256];
10974 read_memory (addr
, exception_name
, sizeof (exception_name
) - 1);
10975 exception_name
[sizeof (exception_name
) - 1] = '\0';
10979 /* For some reason, we were unable to read the exception
10980 name. This could happen if the Runtime was compiled
10981 without debugging info, for instance. In that case,
10982 just replace the exception name by the generic string
10983 "exception" - it will read as "an exception" in the
10984 notification we are about to print. */
10985 memcpy (exception_name
, "exception", sizeof ("exception"));
10987 /* In the case of unhandled exception breakpoints, we print
10988 the exception name as "unhandled EXCEPTION_NAME", to make
10989 it clearer to the user which kind of catchpoint just got
10990 hit. We used ui_out_text to make sure that this extra
10991 info does not pollute the exception name in the MI case. */
10992 if (ex
== ex_catch_exception_unhandled
)
10993 ui_out_text (uiout
, "unhandled ");
10994 ui_out_field_string (uiout
, "exception-name", exception_name
);
10997 case ex_catch_assert
:
10998 /* In this case, the name of the exception is not really
10999 important. Just print "failed assertion" to make it clearer
11000 that his program just hit an assertion-failure catchpoint.
11001 We used ui_out_text because this info does not belong in
11003 ui_out_text (uiout
, "failed assertion");
11006 ui_out_text (uiout
, " at ");
11007 ada_find_printable_frame (get_current_frame ());
11009 return PRINT_SRC_AND_LOC
;
11012 /* Implement the PRINT_ONE method in the breakpoint_ops structure
11013 for all exception catchpoint kinds. */
11016 print_one_exception (enum exception_catchpoint_kind ex
,
11017 struct breakpoint
*b
, struct bp_location
**last_loc
)
11019 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
11020 struct value_print_options opts
;
11022 get_user_print_options (&opts
);
11023 if (opts
.addressprint
)
11025 annotate_field (4);
11026 ui_out_field_core_addr (uiout
, "addr", b
->loc
->gdbarch
, b
->loc
->address
);
11029 annotate_field (5);
11030 *last_loc
= b
->loc
;
11033 case ex_catch_exception
:
11034 if (c
->excep_string
!= NULL
)
11036 char *msg
= xstrprintf (_("`%s' Ada exception"), c
->excep_string
);
11038 ui_out_field_string (uiout
, "what", msg
);
11042 ui_out_field_string (uiout
, "what", "all Ada exceptions");
11046 case ex_catch_exception_unhandled
:
11047 ui_out_field_string (uiout
, "what", "unhandled Ada exceptions");
11050 case ex_catch_assert
:
11051 ui_out_field_string (uiout
, "what", "failed Ada assertions");
11055 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11060 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
11061 for all exception catchpoint kinds. */
11064 print_mention_exception (enum exception_catchpoint_kind ex
,
11065 struct breakpoint
*b
)
11067 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
11071 case ex_catch_exception
:
11072 if (c
->excep_string
!= NULL
)
11073 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
11074 b
->number
, c
->excep_string
);
11076 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b
->number
);
11080 case ex_catch_exception_unhandled
:
11081 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
11085 case ex_catch_assert
:
11086 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b
->number
);
11090 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11095 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
11096 for all exception catchpoint kinds. */
11099 print_recreate_exception (enum exception_catchpoint_kind ex
,
11100 struct breakpoint
*b
, struct ui_file
*fp
)
11102 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
11106 case ex_catch_exception
:
11107 fprintf_filtered (fp
, "catch exception");
11108 if (c
->excep_string
!= NULL
)
11109 fprintf_filtered (fp
, " %s", c
->excep_string
);
11112 case ex_catch_exception_unhandled
:
11113 fprintf_filtered (fp
, "catch exception unhandled");
11116 case ex_catch_assert
:
11117 fprintf_filtered (fp
, "catch assert");
11121 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11125 /* Virtual table for "catch exception" breakpoints. */
11128 dtor_catch_exception (struct breakpoint
*b
)
11130 dtor_exception (ex_catch_exception
, b
);
11133 static struct bp_location
*
11134 allocate_location_catch_exception (struct breakpoint
*self
)
11136 return allocate_location_exception (ex_catch_exception
, self
);
11140 re_set_catch_exception (struct breakpoint
*b
)
11142 re_set_exception (ex_catch_exception
, b
);
11146 check_status_catch_exception (bpstat bs
)
11148 check_status_exception (ex_catch_exception
, bs
);
11151 static enum print_stop_action
11152 print_it_catch_exception (struct breakpoint
*b
)
11154 return print_it_exception (ex_catch_exception
, b
);
11158 print_one_catch_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
11160 print_one_exception (ex_catch_exception
, b
, last_loc
);
11164 print_mention_catch_exception (struct breakpoint
*b
)
11166 print_mention_exception (ex_catch_exception
, b
);
11170 print_recreate_catch_exception (struct breakpoint
*b
, struct ui_file
*fp
)
11172 print_recreate_exception (ex_catch_exception
, b
, fp
);
11175 static struct breakpoint_ops catch_exception_breakpoint_ops
=
11177 dtor_catch_exception
,
11178 allocate_location_catch_exception
,
11179 re_set_catch_exception
,
11182 NULL
, /* breakpoint_hit */
11183 check_status_catch_exception
,
11184 NULL
, /* resources_needed */
11185 NULL
, /* works_in_software_mode */
11186 print_it_catch_exception
,
11187 print_one_catch_exception
,
11188 NULL
, /* print_one_detail */
11189 print_mention_catch_exception
,
11190 print_recreate_catch_exception
11193 /* Virtual table for "catch exception unhandled" breakpoints. */
11196 dtor_catch_exception_unhandled (struct breakpoint
*b
)
11198 dtor_exception (ex_catch_exception_unhandled
, b
);
11201 static struct bp_location
*
11202 allocate_location_catch_exception_unhandled (struct breakpoint
*self
)
11204 return allocate_location_exception (ex_catch_exception_unhandled
, self
);
11208 re_set_catch_exception_unhandled (struct breakpoint
*b
)
11210 re_set_exception (ex_catch_exception_unhandled
, b
);
11214 check_status_catch_exception_unhandled (bpstat bs
)
11216 check_status_exception (ex_catch_exception_unhandled
, bs
);
11219 static enum print_stop_action
11220 print_it_catch_exception_unhandled (struct breakpoint
*b
)
11222 return print_it_exception (ex_catch_exception_unhandled
, b
);
11226 print_one_catch_exception_unhandled (struct breakpoint
*b
,
11227 struct bp_location
**last_loc
)
11229 print_one_exception (ex_catch_exception_unhandled
, b
, last_loc
);
11233 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
11235 print_mention_exception (ex_catch_exception_unhandled
, b
);
11239 print_recreate_catch_exception_unhandled (struct breakpoint
*b
,
11240 struct ui_file
*fp
)
11242 print_recreate_exception (ex_catch_exception_unhandled
, b
, fp
);
11245 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
= {
11246 dtor_catch_exception_unhandled
,
11247 allocate_location_catch_exception_unhandled
,
11248 re_set_catch_exception_unhandled
,
11251 NULL
, /* breakpoint_hit */
11252 check_status_catch_exception_unhandled
,
11253 NULL
, /* resources_needed */
11254 NULL
, /* works_in_software_mode */
11255 print_it_catch_exception_unhandled
,
11256 print_one_catch_exception_unhandled
,
11257 NULL
, /* print_one_detail */
11258 print_mention_catch_exception_unhandled
,
11259 print_recreate_catch_exception_unhandled
11262 /* Virtual table for "catch assert" breakpoints. */
11265 dtor_catch_assert (struct breakpoint
*b
)
11267 dtor_exception (ex_catch_assert
, b
);
11270 static struct bp_location
*
11271 allocate_location_catch_assert (struct breakpoint
*self
)
11273 return allocate_location_exception (ex_catch_assert
, self
);
11277 re_set_catch_assert (struct breakpoint
*b
)
11279 return re_set_exception (ex_catch_assert
, b
);
11283 check_status_catch_assert (bpstat bs
)
11285 check_status_exception (ex_catch_assert
, bs
);
11288 static enum print_stop_action
11289 print_it_catch_assert (struct breakpoint
*b
)
11291 return print_it_exception (ex_catch_assert
, b
);
11295 print_one_catch_assert (struct breakpoint
*b
, struct bp_location
**last_loc
)
11297 print_one_exception (ex_catch_assert
, b
, last_loc
);
11301 print_mention_catch_assert (struct breakpoint
*b
)
11303 print_mention_exception (ex_catch_assert
, b
);
11307 print_recreate_catch_assert (struct breakpoint
*b
, struct ui_file
*fp
)
11309 print_recreate_exception (ex_catch_assert
, b
, fp
);
11312 static struct breakpoint_ops catch_assert_breakpoint_ops
= {
11314 allocate_location_catch_assert
,
11315 re_set_catch_assert
,
11318 NULL
, /* breakpoint_hit */
11319 check_status_catch_assert
,
11320 NULL
, /* resources_needed */
11321 NULL
, /* works_in_software_mode */
11322 print_it_catch_assert
,
11323 print_one_catch_assert
,
11324 NULL
, /* print_one_detail */
11325 print_mention_catch_assert
,
11326 print_recreate_catch_assert
11329 /* Return a newly allocated copy of the first space-separated token
11330 in ARGSP, and then adjust ARGSP to point immediately after that
11333 Return NULL if ARGPS does not contain any more tokens. */
11336 ada_get_next_arg (char **argsp
)
11338 char *args
= *argsp
;
11342 /* Skip any leading white space. */
11344 while (isspace (*args
))
11347 if (args
[0] == '\0')
11348 return NULL
; /* No more arguments. */
11350 /* Find the end of the current argument. */
11353 while (*end
!= '\0' && !isspace (*end
))
11356 /* Adjust ARGSP to point to the start of the next argument. */
11360 /* Make a copy of the current argument and return it. */
11362 result
= xmalloc (end
- args
+ 1);
11363 strncpy (result
, args
, end
- args
);
11364 result
[end
- args
] = '\0';
11369 /* Split the arguments specified in a "catch exception" command.
11370 Set EX to the appropriate catchpoint type.
11371 Set EXCEP_STRING to the name of the specific exception if
11372 specified by the user. */
11375 catch_ada_exception_command_split (char *args
,
11376 enum exception_catchpoint_kind
*ex
,
11377 char **excep_string
)
11379 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
11380 char *exception_name
;
11382 exception_name
= ada_get_next_arg (&args
);
11383 make_cleanup (xfree
, exception_name
);
11385 /* Check that we do not have any more arguments. Anything else
11388 while (isspace (*args
))
11391 if (args
[0] != '\0')
11392 error (_("Junk at end of expression"));
11394 discard_cleanups (old_chain
);
11396 if (exception_name
== NULL
)
11398 /* Catch all exceptions. */
11399 *ex
= ex_catch_exception
;
11400 *excep_string
= NULL
;
11402 else if (strcmp (exception_name
, "unhandled") == 0)
11404 /* Catch unhandled exceptions. */
11405 *ex
= ex_catch_exception_unhandled
;
11406 *excep_string
= NULL
;
11410 /* Catch a specific exception. */
11411 *ex
= ex_catch_exception
;
11412 *excep_string
= exception_name
;
11416 /* Return the name of the symbol on which we should break in order to
11417 implement a catchpoint of the EX kind. */
11419 static const char *
11420 ada_exception_sym_name (enum exception_catchpoint_kind ex
)
11422 gdb_assert (exception_info
!= NULL
);
11426 case ex_catch_exception
:
11427 return (exception_info
->catch_exception_sym
);
11429 case ex_catch_exception_unhandled
:
11430 return (exception_info
->catch_exception_unhandled_sym
);
11432 case ex_catch_assert
:
11433 return (exception_info
->catch_assert_sym
);
11436 internal_error (__FILE__
, __LINE__
,
11437 _("unexpected catchpoint kind (%d)"), ex
);
11441 /* Return the breakpoint ops "virtual table" used for catchpoints
11444 static struct breakpoint_ops
*
11445 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex
)
11449 case ex_catch_exception
:
11450 return (&catch_exception_breakpoint_ops
);
11452 case ex_catch_exception_unhandled
:
11453 return (&catch_exception_unhandled_breakpoint_ops
);
11455 case ex_catch_assert
:
11456 return (&catch_assert_breakpoint_ops
);
11459 internal_error (__FILE__
, __LINE__
,
11460 _("unexpected catchpoint kind (%d)"), ex
);
11464 /* Return the condition that will be used to match the current exception
11465 being raised with the exception that the user wants to catch. This
11466 assumes that this condition is used when the inferior just triggered
11467 an exception catchpoint.
11469 The string returned is a newly allocated string that needs to be
11470 deallocated later. */
11473 ada_exception_catchpoint_cond_string (const char *excep_string
)
11477 /* The standard exceptions are a special case. They are defined in
11478 runtime units that have been compiled without debugging info; if
11479 EXCEP_STRING is the not-fully-qualified name of a standard
11480 exception (e.g. "constraint_error") then, during the evaluation
11481 of the condition expression, the symbol lookup on this name would
11482 *not* return this standard exception. The catchpoint condition
11483 may then be set only on user-defined exceptions which have the
11484 same not-fully-qualified name (e.g. my_package.constraint_error).
11486 To avoid this unexcepted behavior, these standard exceptions are
11487 systematically prefixed by "standard". This means that "catch
11488 exception constraint_error" is rewritten into "catch exception
11489 standard.constraint_error".
11491 If an exception named contraint_error is defined in another package of
11492 the inferior program, then the only way to specify this exception as a
11493 breakpoint condition is to use its fully-qualified named:
11494 e.g. my_package.constraint_error. */
11496 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
11498 if (strcmp (standard_exc
[i
], excep_string
) == 0)
11500 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
11504 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string
);
11507 /* Return the symtab_and_line that should be used to insert an exception
11508 catchpoint of the TYPE kind.
11510 EXCEP_STRING should contain the name of a specific exception that
11511 the catchpoint should catch, or NULL otherwise.
11513 ADDR_STRING returns the name of the function where the real
11514 breakpoint that implements the catchpoints is set, depending on the
11515 type of catchpoint we need to create. */
11517 static struct symtab_and_line
11518 ada_exception_sal (enum exception_catchpoint_kind ex
, char *excep_string
,
11519 char **addr_string
, struct breakpoint_ops
**ops
)
11521 const char *sym_name
;
11522 struct symbol
*sym
;
11523 struct symtab_and_line sal
;
11525 /* First, find out which exception support info to use. */
11526 ada_exception_support_info_sniffer ();
11528 /* Then lookup the function on which we will break in order to catch
11529 the Ada exceptions requested by the user. */
11531 sym_name
= ada_exception_sym_name (ex
);
11532 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
11534 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11535 that should be compiled with debugging information. As a result, we
11536 expect to find that symbol in the symtabs. If we don't find it, then
11537 the target most likely does not support Ada exceptions, or we cannot
11538 insert exception breakpoints yet, because the GNAT runtime hasn't been
11541 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
11542 in such a way that no debugging information is produced for the symbol
11543 we are looking for. In this case, we could search the minimal symbols
11544 as a fall-back mechanism. This would still be operating in degraded
11545 mode, however, as we would still be missing the debugging information
11546 that is needed in order to extract the name of the exception being
11547 raised (this name is printed in the catchpoint message, and is also
11548 used when trying to catch a specific exception). We do not handle
11549 this case for now. */
11552 error (_("Unable to break on '%s' in this configuration."), sym_name
);
11554 /* Make sure that the symbol we found corresponds to a function. */
11555 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11556 error (_("Symbol \"%s\" is not a function (class = %d)"),
11557 sym_name
, SYMBOL_CLASS (sym
));
11559 sal
= find_function_start_sal (sym
, 1);
11561 /* Set ADDR_STRING. */
11563 *addr_string
= xstrdup (sym_name
);
11566 *ops
= ada_exception_breakpoint_ops (ex
);
11571 /* Parse the arguments (ARGS) of the "catch exception" command.
11573 If the user asked the catchpoint to catch only a specific
11574 exception, then save the exception name in ADDR_STRING.
11576 See ada_exception_sal for a description of all the remaining
11577 function arguments of this function. */
11579 static struct symtab_and_line
11580 ada_decode_exception_location (char *args
, char **addr_string
,
11581 char **excep_string
,
11582 struct breakpoint_ops
**ops
)
11584 enum exception_catchpoint_kind ex
;
11586 catch_ada_exception_command_split (args
, &ex
, excep_string
);
11587 return ada_exception_sal (ex
, *excep_string
, addr_string
, ops
);
11590 /* Create an Ada exception catchpoint. */
11593 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
11594 struct symtab_and_line sal
,
11596 char *excep_string
,
11597 struct breakpoint_ops
*ops
,
11601 struct ada_catchpoint
*c
;
11603 c
= XNEW (struct ada_catchpoint
);
11604 init_ada_exception_breakpoint (&c
->base
, gdbarch
, sal
, addr_string
,
11605 ops
, tempflag
, from_tty
);
11606 c
->excep_string
= excep_string
;
11607 create_excep_cond_exprs (c
);
11608 install_breakpoint (&c
->base
);
11611 /* Implement the "catch exception" command. */
11614 catch_ada_exception_command (char *arg
, int from_tty
,
11615 struct cmd_list_element
*command
)
11617 struct gdbarch
*gdbarch
= get_current_arch ();
11619 struct symtab_and_line sal
;
11620 char *addr_string
= NULL
;
11621 char *excep_string
= NULL
;
11622 struct breakpoint_ops
*ops
= NULL
;
11624 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
11628 sal
= ada_decode_exception_location (arg
, &addr_string
, &excep_string
, &ops
);
11629 create_ada_exception_catchpoint (gdbarch
, sal
, addr_string
,
11630 excep_string
, ops
, tempflag
, from_tty
);
11633 static struct symtab_and_line
11634 ada_decode_assert_location (char *args
, char **addr_string
,
11635 struct breakpoint_ops
**ops
)
11637 /* Check that no argument where provided at the end of the command. */
11641 while (isspace (*args
))
11644 error (_("Junk at end of arguments."));
11647 return ada_exception_sal (ex_catch_assert
, NULL
, addr_string
, ops
);
11650 /* Implement the "catch assert" command. */
11653 catch_assert_command (char *arg
, int from_tty
,
11654 struct cmd_list_element
*command
)
11656 struct gdbarch
*gdbarch
= get_current_arch ();
11658 struct symtab_and_line sal
;
11659 char *addr_string
= NULL
;
11660 struct breakpoint_ops
*ops
= NULL
;
11662 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
11666 sal
= ada_decode_assert_location (arg
, &addr_string
, &ops
);
11667 create_ada_exception_catchpoint (gdbarch
, sal
, addr_string
,
11668 NULL
, ops
, tempflag
, from_tty
);
11671 /* Information about operators given special treatment in functions
11673 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
11675 #define ADA_OPERATORS \
11676 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
11677 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
11678 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
11679 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
11680 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
11681 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
11682 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
11683 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
11684 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
11685 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
11686 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
11687 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
11688 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
11689 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
11690 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
11691 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
11692 OP_DEFN (OP_OTHERS, 1, 1, 0) \
11693 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
11694 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
11697 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
11700 switch (exp
->elts
[pc
- 1].opcode
)
11703 operator_length_standard (exp
, pc
, oplenp
, argsp
);
11706 #define OP_DEFN(op, len, args, binop) \
11707 case op: *oplenp = len; *argsp = args; break;
11713 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
11718 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
11723 /* Implementation of the exp_descriptor method operator_check. */
11726 ada_operator_check (struct expression
*exp
, int pos
,
11727 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
11730 const union exp_element
*const elts
= exp
->elts
;
11731 struct type
*type
= NULL
;
11733 switch (elts
[pos
].opcode
)
11735 case UNOP_IN_RANGE
:
11737 type
= elts
[pos
+ 1].type
;
11741 return operator_check_standard (exp
, pos
, objfile_func
, data
);
11744 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
11746 if (type
&& TYPE_OBJFILE (type
)
11747 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
11754 ada_op_name (enum exp_opcode opcode
)
11759 return op_name_standard (opcode
);
11761 #define OP_DEFN(op, len, args, binop) case op: return #op;
11766 return "OP_AGGREGATE";
11768 return "OP_CHOICES";
11774 /* As for operator_length, but assumes PC is pointing at the first
11775 element of the operator, and gives meaningful results only for the
11776 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
11779 ada_forward_operator_length (struct expression
*exp
, int pc
,
11780 int *oplenp
, int *argsp
)
11782 switch (exp
->elts
[pc
].opcode
)
11785 *oplenp
= *argsp
= 0;
11788 #define OP_DEFN(op, len, args, binop) \
11789 case op: *oplenp = len; *argsp = args; break;
11795 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11800 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
11806 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11808 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
11816 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
11818 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
11823 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
11827 /* Ada attributes ('Foo). */
11830 case OP_ATR_LENGTH
:
11834 case OP_ATR_MODULUS
:
11841 case UNOP_IN_RANGE
:
11843 /* XXX: gdb_sprint_host_address, type_sprint */
11844 fprintf_filtered (stream
, _("Type @"));
11845 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
11846 fprintf_filtered (stream
, " (");
11847 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
11848 fprintf_filtered (stream
, ")");
11850 case BINOP_IN_BOUNDS
:
11851 fprintf_filtered (stream
, " (%d)",
11852 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
11854 case TERNOP_IN_RANGE
:
11859 case OP_DISCRETE_RANGE
:
11860 case OP_POSITIONAL
:
11867 char *name
= &exp
->elts
[elt
+ 2].string
;
11868 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
11870 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
11875 return dump_subexp_body_standard (exp
, stream
, elt
);
11879 for (i
= 0; i
< nargs
; i
+= 1)
11880 elt
= dump_subexp (exp
, stream
, elt
);
11885 /* The Ada extension of print_subexp (q.v.). */
11888 ada_print_subexp (struct expression
*exp
, int *pos
,
11889 struct ui_file
*stream
, enum precedence prec
)
11891 int oplen
, nargs
, i
;
11893 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
11895 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11902 print_subexp_standard (exp
, pos
, stream
, prec
);
11906 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
11909 case BINOP_IN_BOUNDS
:
11910 /* XXX: sprint_subexp */
11911 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11912 fputs_filtered (" in ", stream
);
11913 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11914 fputs_filtered ("'range", stream
);
11915 if (exp
->elts
[pc
+ 1].longconst
> 1)
11916 fprintf_filtered (stream
, "(%ld)",
11917 (long) exp
->elts
[pc
+ 1].longconst
);
11920 case TERNOP_IN_RANGE
:
11921 if (prec
>= PREC_EQUAL
)
11922 fputs_filtered ("(", stream
);
11923 /* XXX: sprint_subexp */
11924 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11925 fputs_filtered (" in ", stream
);
11926 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
11927 fputs_filtered (" .. ", stream
);
11928 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
11929 if (prec
>= PREC_EQUAL
)
11930 fputs_filtered (")", stream
);
11935 case OP_ATR_LENGTH
:
11939 case OP_ATR_MODULUS
:
11944 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
11946 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
11947 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
11951 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11952 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
11957 for (tem
= 1; tem
< nargs
; tem
+= 1)
11959 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
11960 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
11962 fputs_filtered (")", stream
);
11967 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
11968 fputs_filtered ("'(", stream
);
11969 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
11970 fputs_filtered (")", stream
);
11973 case UNOP_IN_RANGE
:
11974 /* XXX: sprint_subexp */
11975 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11976 fputs_filtered (" in ", stream
);
11977 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
11980 case OP_DISCRETE_RANGE
:
11981 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11982 fputs_filtered ("..", stream
);
11983 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11987 fputs_filtered ("others => ", stream
);
11988 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11992 for (i
= 0; i
< nargs
-1; i
+= 1)
11995 fputs_filtered ("|", stream
);
11996 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11998 fputs_filtered (" => ", stream
);
11999 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
12002 case OP_POSITIONAL
:
12003 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
12007 fputs_filtered ("(", stream
);
12008 for (i
= 0; i
< nargs
; i
+= 1)
12011 fputs_filtered (", ", stream
);
12012 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
12014 fputs_filtered (")", stream
);
12019 /* Table mapping opcodes into strings for printing operators
12020 and precedences of the operators. */
12022 static const struct op_print ada_op_print_tab
[] = {
12023 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
12024 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
12025 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
12026 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
12027 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
12028 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
12029 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
12030 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
12031 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
12032 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
12033 {">", BINOP_GTR
, PREC_ORDER
, 0},
12034 {"<", BINOP_LESS
, PREC_ORDER
, 0},
12035 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
12036 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
12037 {"+", BINOP_ADD
, PREC_ADD
, 0},
12038 {"-", BINOP_SUB
, PREC_ADD
, 0},
12039 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
12040 {"*", BINOP_MUL
, PREC_MUL
, 0},
12041 {"/", BINOP_DIV
, PREC_MUL
, 0},
12042 {"rem", BINOP_REM
, PREC_MUL
, 0},
12043 {"mod", BINOP_MOD
, PREC_MUL
, 0},
12044 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
12045 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
12046 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
12047 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
12048 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
12049 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
12050 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
12051 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
12052 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
12053 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
12057 enum ada_primitive_types
{
12058 ada_primitive_type_int
,
12059 ada_primitive_type_long
,
12060 ada_primitive_type_short
,
12061 ada_primitive_type_char
,
12062 ada_primitive_type_float
,
12063 ada_primitive_type_double
,
12064 ada_primitive_type_void
,
12065 ada_primitive_type_long_long
,
12066 ada_primitive_type_long_double
,
12067 ada_primitive_type_natural
,
12068 ada_primitive_type_positive
,
12069 ada_primitive_type_system_address
,
12070 nr_ada_primitive_types
12074 ada_language_arch_info (struct gdbarch
*gdbarch
,
12075 struct language_arch_info
*lai
)
12077 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
12079 lai
->primitive_type_vector
12080 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
12083 lai
->primitive_type_vector
[ada_primitive_type_int
]
12084 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
12086 lai
->primitive_type_vector
[ada_primitive_type_long
]
12087 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
12088 0, "long_integer");
12089 lai
->primitive_type_vector
[ada_primitive_type_short
]
12090 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
12091 0, "short_integer");
12092 lai
->string_char_type
12093 = lai
->primitive_type_vector
[ada_primitive_type_char
]
12094 = arch_integer_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
12095 lai
->primitive_type_vector
[ada_primitive_type_float
]
12096 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
12098 lai
->primitive_type_vector
[ada_primitive_type_double
]
12099 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
12100 "long_float", NULL
);
12101 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
12102 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
12103 0, "long_long_integer");
12104 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
12105 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
12106 "long_long_float", NULL
);
12107 lai
->primitive_type_vector
[ada_primitive_type_natural
]
12108 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
12110 lai
->primitive_type_vector
[ada_primitive_type_positive
]
12111 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
12113 lai
->primitive_type_vector
[ada_primitive_type_void
]
12114 = builtin
->builtin_void
;
12116 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
12117 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, 1, "void"));
12118 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
12119 = "system__address";
12121 lai
->bool_type_symbol
= NULL
;
12122 lai
->bool_type_default
= builtin
->builtin_bool
;
12125 /* Language vector */
12127 /* Not really used, but needed in the ada_language_defn. */
12130 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
12132 ada_emit_char (c
, type
, stream
, quoter
, 1);
12138 warnings_issued
= 0;
12139 return ada_parse ();
12142 static const struct exp_descriptor ada_exp_descriptor
= {
12144 ada_operator_length
,
12145 ada_operator_check
,
12147 ada_dump_subexp_body
,
12148 ada_evaluate_subexp
12151 const struct language_defn ada_language_defn
= {
12152 "ada", /* Language name */
12156 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
12157 that's not quite what this means. */
12159 macro_expansion_no
,
12160 &ada_exp_descriptor
,
12164 ada_printchar
, /* Print a character constant */
12165 ada_printstr
, /* Function to print string constant */
12166 emit_char
, /* Function to print single char (not used) */
12167 ada_print_type
, /* Print a type using appropriate syntax */
12168 ada_print_typedef
, /* Print a typedef using appropriate syntax */
12169 ada_val_print
, /* Print a value using appropriate syntax */
12170 ada_value_print
, /* Print a top-level value */
12171 NULL
, /* Language specific skip_trampoline */
12172 NULL
, /* name_of_this */
12173 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
12174 basic_lookup_transparent_type
, /* lookup_transparent_type */
12175 ada_la_decode
, /* Language specific symbol demangler */
12176 NULL
, /* Language specific
12177 class_name_from_physname */
12178 ada_op_print_tab
, /* expression operators for printing */
12179 0, /* c-style arrays */
12180 1, /* String lower bound */
12181 ada_get_gdb_completer_word_break_characters
,
12182 ada_make_symbol_completion_list
,
12183 ada_language_arch_info
,
12184 ada_print_array_index
,
12185 default_pass_by_reference
,
12190 /* Provide a prototype to silence -Wmissing-prototypes. */
12191 extern initialize_file_ftype _initialize_ada_language
;
12193 /* Command-list for the "set/show ada" prefix command. */
12194 static struct cmd_list_element
*set_ada_list
;
12195 static struct cmd_list_element
*show_ada_list
;
12197 /* Implement the "set ada" prefix command. */
12200 set_ada_command (char *arg
, int from_tty
)
12202 printf_unfiltered (_(\
12203 "\"set ada\" must be followed by the name of a setting.\n"));
12204 help_list (set_ada_list
, "set ada ", -1, gdb_stdout
);
12207 /* Implement the "show ada" prefix command. */
12210 show_ada_command (char *args
, int from_tty
)
12212 cmd_show_list (show_ada_list
, from_tty
, "");
12216 _initialize_ada_language (void)
12218 add_language (&ada_language_defn
);
12220 add_prefix_cmd ("ada", no_class
, set_ada_command
,
12221 _("Prefix command for changing Ada-specfic settings"),
12222 &set_ada_list
, "set ada ", 0, &setlist
);
12224 add_prefix_cmd ("ada", no_class
, show_ada_command
,
12225 _("Generic command for showing Ada-specific settings."),
12226 &show_ada_list
, "show ada ", 0, &showlist
);
12228 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
12229 &trust_pad_over_xvs
, _("\
12230 Enable or disable an optimization trusting PAD types over XVS types"), _("\
12231 Show whether an optimization trusting PAD types over XVS types is activated"),
12233 This is related to the encoding used by the GNAT compiler. The debugger\n\
12234 should normally trust the contents of PAD types, but certain older versions\n\
12235 of GNAT have a bug that sometimes causes the information in the PAD type\n\
12236 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
12237 work around this bug. It is always safe to turn this option \"off\", but\n\
12238 this incurs a slight performance penalty, so it is recommended to NOT change\n\
12239 this option to \"off\" unless necessary."),
12240 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
12242 add_catch_command ("exception", _("\
12243 Catch Ada exceptions, when raised.\n\
12244 With an argument, catch only exceptions with the given name."),
12245 catch_ada_exception_command
,
12249 add_catch_command ("assert", _("\
12250 Catch failed Ada assertions, when raised.\n\
12251 With an argument, catch only exceptions with the given name."),
12252 catch_assert_command
,
12257 varsize_limit
= 65536;
12259 obstack_init (&symbol_list_obstack
);
12261 decoded_names_store
= htab_create_alloc
12262 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
12263 NULL
, xcalloc
, xfree
);
12265 observer_attach_executable_changed (ada_executable_changed_observer
);
12267 /* Setup per-inferior data. */
12268 observer_attach_inferior_exit (ada_inferior_exit
);
12270 = register_inferior_data_with_cleanup (ada_inferior_data_cleanup
);