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 /* Define whether or not the C operator '/' truncates towards zero for
64 differently signed operands (truncation direction is undefined in C).
65 Copied from valarith.c. */
67 #ifndef TRUNCATION_TOWARDS_ZERO
68 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
71 static void modify_general_field (struct type
*, char *, LONGEST
, int, int);
73 static struct type
*desc_base_type (struct type
*);
75 static struct type
*desc_bounds_type (struct type
*);
77 static struct value
*desc_bounds (struct value
*);
79 static int fat_pntr_bounds_bitpos (struct type
*);
81 static int fat_pntr_bounds_bitsize (struct type
*);
83 static struct type
*desc_data_target_type (struct type
*);
85 static struct value
*desc_data (struct value
*);
87 static int fat_pntr_data_bitpos (struct type
*);
89 static int fat_pntr_data_bitsize (struct type
*);
91 static struct value
*desc_one_bound (struct value
*, int, int);
93 static int desc_bound_bitpos (struct type
*, int, int);
95 static int desc_bound_bitsize (struct type
*, int, int);
97 static struct type
*desc_index_type (struct type
*, int);
99 static int desc_arity (struct type
*);
101 static int ada_type_match (struct type
*, struct type
*, int);
103 static int ada_args_match (struct symbol
*, struct value
**, int);
105 static struct value
*ensure_lval (struct value
*,
106 struct gdbarch
*, CORE_ADDR
*);
108 static struct value
*make_array_descriptor (struct type
*, struct value
*,
109 struct gdbarch
*, CORE_ADDR
*);
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 wild_match (const char *, int, const char *);
205 static struct value
*ada_coerce_ref (struct value
*);
207 static LONGEST
pos_atr (struct value
*);
209 static struct value
*value_pos_atr (struct type
*, struct value
*);
211 static struct value
*value_val_atr (struct type
*, struct value
*);
213 static struct symbol
*standard_lookup (const char *, const struct block
*,
216 static struct value
*ada_search_struct_field (char *, struct value
*, int,
219 static struct value
*ada_value_primitive_field (struct value
*, int, int,
222 static int find_struct_field (char *, struct type
*, int,
223 struct type
**, int *, int *, int *, int *);
225 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
228 static int ada_resolve_function (struct ada_symbol_info
*, int,
229 struct value
**, int, const char *,
232 static struct value
*ada_coerce_to_simple_array (struct value
*);
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
*,
245 struct expression
*, int *, enum noside
);
247 static void aggregate_assign_from_choices (struct value
*, struct value
*,
249 int *, LONGEST
*, int *,
250 int, LONGEST
, LONGEST
);
252 static void aggregate_assign_positional (struct value
*, struct value
*,
254 int *, LONGEST
*, int *, int,
258 static void aggregate_assign_others (struct value
*, struct value
*,
260 int *, LONGEST
*, int, LONGEST
, LONGEST
);
263 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
266 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
269 static void ada_forward_operator_length (struct expression
*, int, int *,
274 /* Maximum-sized dynamic type. */
275 static unsigned int varsize_limit
;
277 /* FIXME: brobecker/2003-09-17: No longer a const because it is
278 returned by a function that does not return a const char *. */
279 static char *ada_completer_word_break_characters
=
281 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
283 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
286 /* The name of the symbol to use to get the name of the main subprogram. */
287 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
288 = "__gnat_ada_main_program_name";
290 /* Limit on the number of warnings to raise per expression evaluation. */
291 static int warning_limit
= 2;
293 /* Number of warning messages issued; reset to 0 by cleanups after
294 expression evaluation. */
295 static int warnings_issued
= 0;
297 static const char *known_runtime_file_name_patterns
[] = {
298 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
301 static const char *known_auxiliary_function_name_patterns
[] = {
302 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
305 /* Space for allocating results of ada_lookup_symbol_list. */
306 static struct obstack symbol_list_obstack
;
308 /* Inferior-specific data. */
310 /* Per-inferior data for this module. */
312 struct ada_inferior_data
314 /* The ada__tags__type_specific_data type, which is used when decoding
315 tagged types. With older versions of GNAT, this type was directly
316 accessible through a component ("tsd") in the object tag. But this
317 is no longer the case, so we cache it for each inferior. */
318 struct type
*tsd_type
;
321 /* Our key to this module's inferior data. */
322 static const struct inferior_data
*ada_inferior_data
;
324 /* A cleanup routine for our inferior data. */
326 ada_inferior_data_cleanup (struct inferior
*inf
, void *arg
)
328 struct ada_inferior_data
*data
;
330 data
= inferior_data (inf
, ada_inferior_data
);
335 /* Return our inferior data for the given inferior (INF).
337 This function always returns a valid pointer to an allocated
338 ada_inferior_data structure. If INF's inferior data has not
339 been previously set, this functions creates a new one with all
340 fields set to zero, sets INF's inferior to it, and then returns
341 a pointer to that newly allocated ada_inferior_data. */
343 static struct ada_inferior_data
*
344 get_ada_inferior_data (struct inferior
*inf
)
346 struct ada_inferior_data
*data
;
348 data
= inferior_data (inf
, ada_inferior_data
);
351 data
= XZALLOC (struct ada_inferior_data
);
352 set_inferior_data (inf
, ada_inferior_data
, data
);
358 /* Perform all necessary cleanups regarding our module's inferior data
359 that is required after the inferior INF just exited. */
362 ada_inferior_exit (struct inferior
*inf
)
364 ada_inferior_data_cleanup (inf
, NULL
);
365 set_inferior_data (inf
, ada_inferior_data
, NULL
);
370 /* Given DECODED_NAME a string holding a symbol name in its
371 decoded form (ie using the Ada dotted notation), returns
372 its unqualified name. */
375 ada_unqualified_name (const char *decoded_name
)
377 const char *result
= strrchr (decoded_name
, '.');
380 result
++; /* Skip the dot... */
382 result
= decoded_name
;
387 /* Return a string starting with '<', followed by STR, and '>'.
388 The result is good until the next call. */
391 add_angle_brackets (const char *str
)
393 static char *result
= NULL
;
396 result
= xstrprintf ("<%s>", str
);
401 ada_get_gdb_completer_word_break_characters (void)
403 return ada_completer_word_break_characters
;
406 /* Print an array element index using the Ada syntax. */
409 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
410 const struct value_print_options
*options
)
412 LA_VALUE_PRINT (index_value
, stream
, options
);
413 fprintf_filtered (stream
, " => ");
416 /* Assuming VECT points to an array of *SIZE objects of size
417 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
418 updating *SIZE as necessary and returning the (new) array. */
421 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
423 if (*size
< min_size
)
426 if (*size
< min_size
)
428 vect
= xrealloc (vect
, *size
* element_size
);
433 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
434 suffix of FIELD_NAME beginning "___". */
437 field_name_match (const char *field_name
, const char *target
)
439 int len
= strlen (target
);
442 (strncmp (field_name
, target
, len
) == 0
443 && (field_name
[len
] == '\0'
444 || (strncmp (field_name
+ len
, "___", 3) == 0
445 && strcmp (field_name
+ strlen (field_name
) - 6,
450 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
451 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
452 and return its index. This function also handles fields whose name
453 have ___ suffixes because the compiler sometimes alters their name
454 by adding such a suffix to represent fields with certain constraints.
455 If the field could not be found, return a negative number if
456 MAYBE_MISSING is set. Otherwise raise an error. */
459 ada_get_field_index (const struct type
*type
, const char *field_name
,
463 struct type
*struct_type
= check_typedef ((struct type
*) type
);
465 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (struct_type
); fieldno
++)
466 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
470 error (_("Unable to find field %s in struct %s. Aborting"),
471 field_name
, TYPE_NAME (struct_type
));
476 /* The length of the prefix of NAME prior to any "___" suffix. */
479 ada_name_prefix_len (const char *name
)
485 const char *p
= strstr (name
, "___");
488 return strlen (name
);
494 /* Return non-zero if SUFFIX is a suffix of STR.
495 Return zero if STR is null. */
498 is_suffix (const char *str
, const char *suffix
)
505 len2
= strlen (suffix
);
506 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
509 /* The contents of value VAL, treated as a value of type TYPE. The
510 result is an lval in memory if VAL is. */
512 static struct value
*
513 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
515 type
= ada_check_typedef (type
);
516 if (value_type (val
) == type
)
520 struct value
*result
;
522 /* Make sure that the object size is not unreasonable before
523 trying to allocate some memory for it. */
526 result
= allocate_value (type
);
527 set_value_component_location (result
, val
);
528 set_value_bitsize (result
, value_bitsize (val
));
529 set_value_bitpos (result
, value_bitpos (val
));
530 set_value_address (result
, value_address (val
));
532 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
533 set_value_lazy (result
, 1);
535 memcpy (value_contents_raw (result
), value_contents (val
),
541 static const gdb_byte
*
542 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
547 return valaddr
+ offset
;
551 cond_offset_target (CORE_ADDR address
, long offset
)
556 return address
+ offset
;
559 /* Issue a warning (as for the definition of warning in utils.c, but
560 with exactly one argument rather than ...), unless the limit on the
561 number of warnings has passed during the evaluation of the current
564 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
565 provided by "complaint". */
566 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
569 lim_warning (const char *format
, ...)
573 va_start (args
, format
);
574 warnings_issued
+= 1;
575 if (warnings_issued
<= warning_limit
)
576 vwarning (format
, args
);
581 /* Issue an error if the size of an object of type T is unreasonable,
582 i.e. if it would be a bad idea to allocate a value of this type in
586 check_size (const struct type
*type
)
588 if (TYPE_LENGTH (type
) > varsize_limit
)
589 error (_("object size is larger than varsize-limit"));
592 /* Maximum value of a SIZE-byte signed integer type. */
594 max_of_size (int size
)
596 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
598 return top_bit
| (top_bit
- 1);
601 /* Minimum value of a SIZE-byte signed integer type. */
603 min_of_size (int size
)
605 return -max_of_size (size
) - 1;
608 /* Maximum value of a SIZE-byte unsigned integer type. */
610 umax_of_size (int size
)
612 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
614 return top_bit
| (top_bit
- 1);
617 /* Maximum value of integral type T, as a signed quantity. */
619 max_of_type (struct type
*t
)
621 if (TYPE_UNSIGNED (t
))
622 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
624 return max_of_size (TYPE_LENGTH (t
));
627 /* Minimum value of integral type T, as a signed quantity. */
629 min_of_type (struct type
*t
)
631 if (TYPE_UNSIGNED (t
))
634 return min_of_size (TYPE_LENGTH (t
));
637 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
639 ada_discrete_type_high_bound (struct type
*type
)
641 switch (TYPE_CODE (type
))
643 case TYPE_CODE_RANGE
:
644 return TYPE_HIGH_BOUND (type
);
646 return TYPE_FIELD_BITPOS (type
, TYPE_NFIELDS (type
) - 1);
651 return max_of_type (type
);
653 error (_("Unexpected type in ada_discrete_type_high_bound."));
657 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
659 ada_discrete_type_low_bound (struct type
*type
)
661 switch (TYPE_CODE (type
))
663 case TYPE_CODE_RANGE
:
664 return TYPE_LOW_BOUND (type
);
666 return TYPE_FIELD_BITPOS (type
, 0);
671 return min_of_type (type
);
673 error (_("Unexpected type in ada_discrete_type_low_bound."));
677 /* The identity on non-range types. For range types, the underlying
678 non-range scalar type. */
681 base_type (struct type
*type
)
683 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
685 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
687 type
= TYPE_TARGET_TYPE (type
);
693 /* Language Selection */
695 /* If the main program is in Ada, return language_ada, otherwise return LANG
696 (the main program is in Ada iif the adainit symbol is found). */
699 ada_update_initial_language (enum language lang
)
701 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
702 (struct objfile
*) NULL
) != NULL
)
708 /* If the main procedure is written in Ada, then return its name.
709 The result is good until the next call. Return NULL if the main
710 procedure doesn't appear to be in Ada. */
715 struct minimal_symbol
*msym
;
716 static char *main_program_name
= NULL
;
718 /* For Ada, the name of the main procedure is stored in a specific
719 string constant, generated by the binder. Look for that symbol,
720 extract its address, and then read that string. If we didn't find
721 that string, then most probably the main procedure is not written
723 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
727 CORE_ADDR main_program_name_addr
;
730 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
731 if (main_program_name_addr
== 0)
732 error (_("Invalid address for Ada main program name."));
734 xfree (main_program_name
);
735 target_read_string (main_program_name_addr
, &main_program_name
,
740 return main_program_name
;
743 /* The main procedure doesn't seem to be in Ada. */
749 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
752 const struct ada_opname_map ada_opname_table
[] = {
753 {"Oadd", "\"+\"", BINOP_ADD
},
754 {"Osubtract", "\"-\"", BINOP_SUB
},
755 {"Omultiply", "\"*\"", BINOP_MUL
},
756 {"Odivide", "\"/\"", BINOP_DIV
},
757 {"Omod", "\"mod\"", BINOP_MOD
},
758 {"Orem", "\"rem\"", BINOP_REM
},
759 {"Oexpon", "\"**\"", BINOP_EXP
},
760 {"Olt", "\"<\"", BINOP_LESS
},
761 {"Ole", "\"<=\"", BINOP_LEQ
},
762 {"Ogt", "\">\"", BINOP_GTR
},
763 {"Oge", "\">=\"", BINOP_GEQ
},
764 {"Oeq", "\"=\"", BINOP_EQUAL
},
765 {"One", "\"/=\"", BINOP_NOTEQUAL
},
766 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
767 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
768 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
769 {"Oconcat", "\"&\"", BINOP_CONCAT
},
770 {"Oabs", "\"abs\"", UNOP_ABS
},
771 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
772 {"Oadd", "\"+\"", UNOP_PLUS
},
773 {"Osubtract", "\"-\"", UNOP_NEG
},
777 /* The "encoded" form of DECODED, according to GNAT conventions.
778 The result is valid until the next call to ada_encode. */
781 ada_encode (const char *decoded
)
783 static char *encoding_buffer
= NULL
;
784 static size_t encoding_buffer_size
= 0;
791 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
792 2 * strlen (decoded
) + 10);
795 for (p
= decoded
; *p
!= '\0'; p
+= 1)
799 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
804 const struct ada_opname_map
*mapping
;
806 for (mapping
= ada_opname_table
;
807 mapping
->encoded
!= NULL
808 && strncmp (mapping
->decoded
, p
,
809 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
811 if (mapping
->encoded
== NULL
)
812 error (_("invalid Ada operator name: %s"), p
);
813 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
814 k
+= strlen (mapping
->encoded
);
819 encoding_buffer
[k
] = *p
;
824 encoding_buffer
[k
] = '\0';
825 return encoding_buffer
;
828 /* Return NAME folded to lower case, or, if surrounded by single
829 quotes, unfolded, but with the quotes stripped away. Result good
833 ada_fold_name (const char *name
)
835 static char *fold_buffer
= NULL
;
836 static size_t fold_buffer_size
= 0;
838 int len
= strlen (name
);
839 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
843 strncpy (fold_buffer
, name
+ 1, len
- 2);
844 fold_buffer
[len
- 2] = '\000';
850 for (i
= 0; i
<= len
; i
+= 1)
851 fold_buffer
[i
] = tolower (name
[i
]);
857 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
860 is_lower_alphanum (const char c
)
862 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
865 /* Remove either of these suffixes:
870 These are suffixes introduced by the compiler for entities such as
871 nested subprogram for instance, in order to avoid name clashes.
872 They do not serve any purpose for the debugger. */
875 ada_remove_trailing_digits (const char *encoded
, int *len
)
877 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
881 while (i
> 0 && isdigit (encoded
[i
]))
883 if (i
>= 0 && encoded
[i
] == '.')
885 else if (i
>= 0 && encoded
[i
] == '$')
887 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
889 else if (i
>= 1 && strncmp (encoded
+ i
- 1, "__", 2) == 0)
894 /* Remove the suffix introduced by the compiler for protected object
898 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
900 /* Remove trailing N. */
902 /* Protected entry subprograms are broken into two
903 separate subprograms: The first one is unprotected, and has
904 a 'N' suffix; the second is the protected version, and has
905 the 'P' suffix. The second calls the first one after handling
906 the protection. Since the P subprograms are internally generated,
907 we leave these names undecoded, giving the user a clue that this
908 entity is internal. */
911 && encoded
[*len
- 1] == 'N'
912 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
916 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
919 ada_remove_Xbn_suffix (const char *encoded
, int *len
)
923 while (i
> 0 && (encoded
[i
] == 'b' || encoded
[i
] == 'n'))
926 if (encoded
[i
] != 'X')
932 if (isalnum (encoded
[i
-1]))
936 /* If ENCODED follows the GNAT entity encoding conventions, then return
937 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
940 The resulting string is valid until the next call of ada_decode.
941 If the string is unchanged by decoding, the original string pointer
945 ada_decode (const char *encoded
)
952 static char *decoding_buffer
= NULL
;
953 static size_t decoding_buffer_size
= 0;
955 /* The name of the Ada main procedure starts with "_ada_".
956 This prefix is not part of the decoded name, so skip this part
957 if we see this prefix. */
958 if (strncmp (encoded
, "_ada_", 5) == 0)
961 /* If the name starts with '_', then it is not a properly encoded
962 name, so do not attempt to decode it. Similarly, if the name
963 starts with '<', the name should not be decoded. */
964 if (encoded
[0] == '_' || encoded
[0] == '<')
967 len0
= strlen (encoded
);
969 ada_remove_trailing_digits (encoded
, &len0
);
970 ada_remove_po_subprogram_suffix (encoded
, &len0
);
972 /* Remove the ___X.* suffix if present. Do not forget to verify that
973 the suffix is located before the current "end" of ENCODED. We want
974 to avoid re-matching parts of ENCODED that have previously been
975 marked as discarded (by decrementing LEN0). */
976 p
= strstr (encoded
, "___");
977 if (p
!= NULL
&& p
- encoded
< len0
- 3)
985 /* Remove any trailing TKB suffix. It tells us that this symbol
986 is for the body of a task, but that information does not actually
987 appear in the decoded name. */
989 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
992 /* Remove any trailing TB suffix. The TB suffix is slightly different
993 from the TKB suffix because it is used for non-anonymous task
996 if (len0
> 2 && strncmp (encoded
+ len0
- 2, "TB", 2) == 0)
999 /* Remove trailing "B" suffixes. */
1000 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1002 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
1005 /* Make decoded big enough for possible expansion by operator name. */
1007 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
1008 decoded
= decoding_buffer
;
1010 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1012 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1015 while ((i
>= 0 && isdigit (encoded
[i
]))
1016 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1018 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1020 else if (encoded
[i
] == '$')
1024 /* The first few characters that are not alphabetic are not part
1025 of any encoding we use, so we can copy them over verbatim. */
1027 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1028 decoded
[j
] = encoded
[i
];
1033 /* Is this a symbol function? */
1034 if (at_start_name
&& encoded
[i
] == 'O')
1038 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1040 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1041 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1043 && !isalnum (encoded
[i
+ op_len
]))
1045 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1048 j
+= strlen (ada_opname_table
[k
].decoded
);
1052 if (ada_opname_table
[k
].encoded
!= NULL
)
1057 /* Replace "TK__" with "__", which will eventually be translated
1058 into "." (just below). */
1060 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
1063 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1064 be translated into "." (just below). These are internal names
1065 generated for anonymous blocks inside which our symbol is nested. */
1067 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1068 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1069 && isdigit (encoded
[i
+4]))
1073 while (k
< len0
&& isdigit (encoded
[k
]))
1074 k
++; /* Skip any extra digit. */
1076 /* Double-check that the "__B_{DIGITS}+" sequence we found
1077 is indeed followed by "__". */
1078 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1082 /* Remove _E{DIGITS}+[sb] */
1084 /* Just as for protected object subprograms, there are 2 categories
1085 of subprograms created by the compiler for each entry. The first
1086 one implements the actual entry code, and has a suffix following
1087 the convention above; the second one implements the barrier and
1088 uses the same convention as above, except that the 'E' is replaced
1091 Just as above, we do not decode the name of barrier functions
1092 to give the user a clue that the code he is debugging has been
1093 internally generated. */
1095 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1096 && isdigit (encoded
[i
+2]))
1100 while (k
< len0
&& isdigit (encoded
[k
]))
1104 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1107 /* Just as an extra precaution, make sure that if this
1108 suffix is followed by anything else, it is a '_'.
1109 Otherwise, we matched this sequence by accident. */
1111 || (k
< len0
&& encoded
[k
] == '_'))
1116 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1117 the GNAT front-end in protected object subprograms. */
1120 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1122 /* Backtrack a bit up until we reach either the begining of
1123 the encoded name, or "__". Make sure that we only find
1124 digits or lowercase characters. */
1125 const char *ptr
= encoded
+ i
- 1;
1127 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1130 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1134 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1136 /* This is a X[bn]* sequence not separated from the previous
1137 part of the name with a non-alpha-numeric character (in other
1138 words, immediately following an alpha-numeric character), then
1139 verify that it is placed at the end of the encoded name. If
1140 not, then the encoding is not valid and we should abort the
1141 decoding. Otherwise, just skip it, it is used in body-nested
1145 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1149 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1151 /* Replace '__' by '.'. */
1159 /* It's a character part of the decoded name, so just copy it
1161 decoded
[j
] = encoded
[i
];
1166 decoded
[j
] = '\000';
1168 /* Decoded names should never contain any uppercase character.
1169 Double-check this, and abort the decoding if we find one. */
1171 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1172 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1175 if (strcmp (decoded
, encoded
) == 0)
1181 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1182 decoded
= decoding_buffer
;
1183 if (encoded
[0] == '<')
1184 strcpy (decoded
, encoded
);
1186 xsnprintf (decoded
, decoding_buffer_size
, "<%s>", encoded
);
1191 /* Table for keeping permanent unique copies of decoded names. Once
1192 allocated, names in this table are never released. While this is a
1193 storage leak, it should not be significant unless there are massive
1194 changes in the set of decoded names in successive versions of a
1195 symbol table loaded during a single session. */
1196 static struct htab
*decoded_names_store
;
1198 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1199 in the language-specific part of GSYMBOL, if it has not been
1200 previously computed. Tries to save the decoded name in the same
1201 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1202 in any case, the decoded symbol has a lifetime at least that of
1204 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1205 const, but nevertheless modified to a semantically equivalent form
1206 when a decoded name is cached in it.
1210 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1213 (char **) &gsymbol
->language_specific
.mangled_lang
.demangled_name
;
1215 if (*resultp
== NULL
)
1217 const char *decoded
= ada_decode (gsymbol
->name
);
1219 if (gsymbol
->obj_section
!= NULL
)
1221 struct objfile
*objf
= gsymbol
->obj_section
->objfile
;
1223 *resultp
= obsavestring (decoded
, strlen (decoded
),
1224 &objf
->objfile_obstack
);
1226 /* Sometimes, we can't find a corresponding objfile, in which
1227 case, we put the result on the heap. Since we only decode
1228 when needed, we hope this usually does not cause a
1229 significant memory leak (FIXME). */
1230 if (*resultp
== NULL
)
1232 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1236 *slot
= xstrdup (decoded
);
1245 ada_la_decode (const char *encoded
, int options
)
1247 return xstrdup (ada_decode (encoded
));
1250 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1251 suffixes that encode debugging information or leading _ada_ on
1252 SYM_NAME (see is_name_suffix commentary for the debugging
1253 information that is ignored). If WILD, then NAME need only match a
1254 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1255 either argument is NULL. */
1258 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1260 if (sym_name
== NULL
|| name
== NULL
)
1263 return wild_match (name
, strlen (name
), sym_name
);
1266 int len_name
= strlen (name
);
1268 return (strncmp (sym_name
, name
, len_name
) == 0
1269 && is_name_suffix (sym_name
+ len_name
))
1270 || (strncmp (sym_name
, "_ada_", 5) == 0
1271 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1272 && is_name_suffix (sym_name
+ len_name
+ 5));
1279 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1280 generated by the GNAT compiler to describe the index type used
1281 for each dimension of an array, check whether it follows the latest
1282 known encoding. If not, fix it up to conform to the latest encoding.
1283 Otherwise, do nothing. This function also does nothing if
1284 INDEX_DESC_TYPE is NULL.
1286 The GNAT encoding used to describle the array index type evolved a bit.
1287 Initially, the information would be provided through the name of each
1288 field of the structure type only, while the type of these fields was
1289 described as unspecified and irrelevant. The debugger was then expected
1290 to perform a global type lookup using the name of that field in order
1291 to get access to the full index type description. Because these global
1292 lookups can be very expensive, the encoding was later enhanced to make
1293 the global lookup unnecessary by defining the field type as being
1294 the full index type description.
1296 The purpose of this routine is to allow us to support older versions
1297 of the compiler by detecting the use of the older encoding, and by
1298 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1299 we essentially replace each field's meaningless type by the associated
1303 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1307 if (index_desc_type
== NULL
)
1309 gdb_assert (TYPE_NFIELDS (index_desc_type
) > 0);
1311 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1312 to check one field only, no need to check them all). If not, return
1315 If our INDEX_DESC_TYPE was generated using the older encoding,
1316 the field type should be a meaningless integer type whose name
1317 is not equal to the field name. */
1318 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)) != NULL
1319 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)),
1320 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1323 /* Fixup each field of INDEX_DESC_TYPE. */
1324 for (i
= 0; i
< TYPE_NFIELDS (index_desc_type
); i
++)
1326 char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1327 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1330 TYPE_FIELD_TYPE (index_desc_type
, i
) = raw_type
;
1334 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1336 static char *bound_name
[] = {
1337 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1338 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1341 /* Maximum number of array dimensions we are prepared to handle. */
1343 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1345 /* Like modify_field, but allows bitpos > wordlength. */
1348 modify_general_field (struct type
*type
, char *addr
,
1349 LONGEST fieldval
, int bitpos
, int bitsize
)
1351 modify_field (type
, addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1355 /* The desc_* routines return primitive portions of array descriptors
1358 /* The descriptor or array type, if any, indicated by TYPE; removes
1359 level of indirection, if needed. */
1361 static struct type
*
1362 desc_base_type (struct type
*type
)
1366 type
= ada_check_typedef (type
);
1368 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1369 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1370 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1375 /* True iff TYPE indicates a "thin" array pointer type. */
1378 is_thin_pntr (struct type
*type
)
1381 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1382 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1385 /* The descriptor type for thin pointer type TYPE. */
1387 static struct type
*
1388 thin_descriptor_type (struct type
*type
)
1390 struct type
*base_type
= desc_base_type (type
);
1392 if (base_type
== NULL
)
1394 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1398 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1400 if (alt_type
== NULL
)
1407 /* A pointer to the array data for thin-pointer value VAL. */
1409 static struct value
*
1410 thin_data_pntr (struct value
*val
)
1412 struct type
*type
= value_type (val
);
1413 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1415 data_type
= lookup_pointer_type (data_type
);
1417 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1418 return value_cast (data_type
, value_copy (val
));
1420 return value_from_longest (data_type
, value_address (val
));
1423 /* True iff TYPE indicates a "thick" array pointer type. */
1426 is_thick_pntr (struct type
*type
)
1428 type
= desc_base_type (type
);
1429 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1430 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1433 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1434 pointer to one, the type of its bounds data; otherwise, NULL. */
1436 static struct type
*
1437 desc_bounds_type (struct type
*type
)
1441 type
= desc_base_type (type
);
1445 else if (is_thin_pntr (type
))
1447 type
= thin_descriptor_type (type
);
1450 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1452 return ada_check_typedef (r
);
1454 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1456 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1458 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1463 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1464 one, a pointer to its bounds data. Otherwise NULL. */
1466 static struct value
*
1467 desc_bounds (struct value
*arr
)
1469 struct type
*type
= ada_check_typedef (value_type (arr
));
1471 if (is_thin_pntr (type
))
1473 struct type
*bounds_type
=
1474 desc_bounds_type (thin_descriptor_type (type
));
1477 if (bounds_type
== NULL
)
1478 error (_("Bad GNAT array descriptor"));
1480 /* NOTE: The following calculation is not really kosher, but
1481 since desc_type is an XVE-encoded type (and shouldn't be),
1482 the correct calculation is a real pain. FIXME (and fix GCC). */
1483 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1484 addr
= value_as_long (arr
);
1486 addr
= value_address (arr
);
1489 value_from_longest (lookup_pointer_type (bounds_type
),
1490 addr
- TYPE_LENGTH (bounds_type
));
1493 else if (is_thick_pntr (type
))
1495 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1496 _("Bad GNAT array descriptor"));
1497 struct type
*p_bounds_type
= value_type (p_bounds
);
1500 && TYPE_CODE (p_bounds_type
) == TYPE_CODE_PTR
)
1502 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1504 if (TYPE_STUB (target_type
))
1505 p_bounds
= value_cast (lookup_pointer_type
1506 (ada_check_typedef (target_type
)),
1510 error (_("Bad GNAT array descriptor"));
1518 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1519 position of the field containing the address of the bounds data. */
1522 fat_pntr_bounds_bitpos (struct type
*type
)
1524 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1527 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1528 size of the field containing the address of the bounds data. */
1531 fat_pntr_bounds_bitsize (struct type
*type
)
1533 type
= desc_base_type (type
);
1535 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1536 return TYPE_FIELD_BITSIZE (type
, 1);
1538 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1541 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1542 pointer to one, the type of its array data (a array-with-no-bounds type);
1543 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1546 static struct type
*
1547 desc_data_target_type (struct type
*type
)
1549 type
= desc_base_type (type
);
1551 /* NOTE: The following is bogus; see comment in desc_bounds. */
1552 if (is_thin_pntr (type
))
1553 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1));
1554 else if (is_thick_pntr (type
))
1556 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1559 && TYPE_CODE (ada_check_typedef (data_type
)) == TYPE_CODE_PTR
)
1560 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1566 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1569 static struct value
*
1570 desc_data (struct value
*arr
)
1572 struct type
*type
= value_type (arr
);
1574 if (is_thin_pntr (type
))
1575 return thin_data_pntr (arr
);
1576 else if (is_thick_pntr (type
))
1577 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1578 _("Bad GNAT array descriptor"));
1584 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1585 position of the field containing the address of the data. */
1588 fat_pntr_data_bitpos (struct type
*type
)
1590 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1593 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1594 size of the field containing the address of the data. */
1597 fat_pntr_data_bitsize (struct type
*type
)
1599 type
= desc_base_type (type
);
1601 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1602 return TYPE_FIELD_BITSIZE (type
, 0);
1604 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1607 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1608 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1609 bound, if WHICH is 1. The first bound is I=1. */
1611 static struct value
*
1612 desc_one_bound (struct value
*bounds
, int i
, int which
)
1614 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1615 _("Bad GNAT array descriptor bounds"));
1618 /* If BOUNDS is an array-bounds structure type, return the bit position
1619 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1620 bound, if WHICH is 1. The first bound is I=1. */
1623 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1625 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1628 /* If BOUNDS is an array-bounds structure type, return the bit field size
1629 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1630 bound, if WHICH is 1. The first bound is I=1. */
1633 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1635 type
= desc_base_type (type
);
1637 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1638 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1640 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1643 /* If TYPE is the type of an array-bounds structure, the type of its
1644 Ith bound (numbering from 1). Otherwise, NULL. */
1646 static struct type
*
1647 desc_index_type (struct type
*type
, int i
)
1649 type
= desc_base_type (type
);
1651 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1652 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1657 /* The number of index positions in the array-bounds type TYPE.
1658 Return 0 if TYPE is NULL. */
1661 desc_arity (struct type
*type
)
1663 type
= desc_base_type (type
);
1666 return TYPE_NFIELDS (type
) / 2;
1670 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1671 an array descriptor type (representing an unconstrained array
1675 ada_is_direct_array_type (struct type
*type
)
1679 type
= ada_check_typedef (type
);
1680 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1681 || ada_is_array_descriptor_type (type
));
1684 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1688 ada_is_array_type (struct type
*type
)
1691 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1692 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1693 type
= TYPE_TARGET_TYPE (type
);
1694 return ada_is_direct_array_type (type
);
1697 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1700 ada_is_simple_array_type (struct type
*type
)
1704 type
= ada_check_typedef (type
);
1705 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1706 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1707 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1710 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1713 ada_is_array_descriptor_type (struct type
*type
)
1715 struct type
*data_type
= desc_data_target_type (type
);
1719 type
= ada_check_typedef (type
);
1720 return (data_type
!= NULL
1721 && TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
1722 && desc_arity (desc_bounds_type (type
)) > 0);
1725 /* Non-zero iff type is a partially mal-formed GNAT array
1726 descriptor. FIXME: This is to compensate for some problems with
1727 debugging output from GNAT. Re-examine periodically to see if it
1731 ada_is_bogus_array_descriptor (struct type
*type
)
1735 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1736 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1737 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1738 && !ada_is_array_descriptor_type (type
);
1742 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1743 (fat pointer) returns the type of the array data described---specifically,
1744 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1745 in from the descriptor; otherwise, they are left unspecified. If
1746 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1747 returns NULL. The result is simply the type of ARR if ARR is not
1750 ada_type_of_array (struct value
*arr
, int bounds
)
1752 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1753 return decode_constrained_packed_array_type (value_type (arr
));
1755 if (!ada_is_array_descriptor_type (value_type (arr
)))
1756 return value_type (arr
);
1760 struct type
*array_type
=
1761 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1763 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1764 TYPE_FIELD_BITSIZE (array_type
, 0) =
1765 decode_packed_array_bitsize (value_type (arr
));
1771 struct type
*elt_type
;
1773 struct value
*descriptor
;
1775 elt_type
= ada_array_element_type (value_type (arr
), -1);
1776 arity
= ada_array_arity (value_type (arr
));
1778 if (elt_type
== NULL
|| arity
== 0)
1779 return ada_check_typedef (value_type (arr
));
1781 descriptor
= desc_bounds (arr
);
1782 if (value_as_long (descriptor
) == 0)
1786 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1787 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1788 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1789 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1792 create_range_type (range_type
, value_type (low
),
1793 longest_to_int (value_as_long (low
)),
1794 longest_to_int (value_as_long (high
)));
1795 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1797 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1798 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1799 decode_packed_array_bitsize (value_type (arr
));
1802 return lookup_pointer_type (elt_type
);
1806 /* If ARR does not represent an array, returns ARR unchanged.
1807 Otherwise, returns either a standard GDB array with bounds set
1808 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1809 GDB array. Returns NULL if ARR is a null fat pointer. */
1812 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1814 if (ada_is_array_descriptor_type (value_type (arr
)))
1816 struct type
*arrType
= ada_type_of_array (arr
, 1);
1818 if (arrType
== NULL
)
1820 return value_cast (arrType
, value_copy (desc_data (arr
)));
1822 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1823 return decode_constrained_packed_array (arr
);
1828 /* If ARR does not represent an array, returns ARR unchanged.
1829 Otherwise, returns a standard GDB array describing ARR (which may
1830 be ARR itself if it already is in the proper form). */
1832 static struct value
*
1833 ada_coerce_to_simple_array (struct value
*arr
)
1835 if (ada_is_array_descriptor_type (value_type (arr
)))
1837 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1840 error (_("Bounds unavailable for null array pointer."));
1841 check_size (TYPE_TARGET_TYPE (value_type (arrVal
)));
1842 return value_ind (arrVal
);
1844 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
1845 return decode_constrained_packed_array (arr
);
1850 /* If TYPE represents a GNAT array type, return it translated to an
1851 ordinary GDB array type (possibly with BITSIZE fields indicating
1852 packing). For other types, is the identity. */
1855 ada_coerce_to_simple_array_type (struct type
*type
)
1857 if (ada_is_constrained_packed_array_type (type
))
1858 return decode_constrained_packed_array_type (type
);
1860 if (ada_is_array_descriptor_type (type
))
1861 return ada_check_typedef (desc_data_target_type (type
));
1866 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1869 ada_is_packed_array_type (struct type
*type
)
1873 type
= desc_base_type (type
);
1874 type
= ada_check_typedef (type
);
1876 ada_type_name (type
) != NULL
1877 && strstr (ada_type_name (type
), "___XP") != NULL
;
1880 /* Non-zero iff TYPE represents a standard GNAT constrained
1881 packed-array type. */
1884 ada_is_constrained_packed_array_type (struct type
*type
)
1886 return ada_is_packed_array_type (type
)
1887 && !ada_is_array_descriptor_type (type
);
1890 /* Non-zero iff TYPE represents an array descriptor for a
1891 unconstrained packed-array type. */
1894 ada_is_unconstrained_packed_array_type (struct type
*type
)
1896 return ada_is_packed_array_type (type
)
1897 && ada_is_array_descriptor_type (type
);
1900 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
1901 return the size of its elements in bits. */
1904 decode_packed_array_bitsize (struct type
*type
)
1906 char *raw_name
= ada_type_name (ada_check_typedef (type
));
1911 raw_name
= ada_type_name (desc_base_type (type
));
1916 tail
= strstr (raw_name
, "___XP");
1918 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1921 (_("could not understand bit size information on packed array"));
1928 /* Given that TYPE is a standard GDB array type with all bounds filled
1929 in, and that the element size of its ultimate scalar constituents
1930 (that is, either its elements, or, if it is an array of arrays, its
1931 elements' elements, etc.) is *ELT_BITS, return an identical type,
1932 but with the bit sizes of its elements (and those of any
1933 constituent arrays) recorded in the BITSIZE components of its
1934 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1937 static struct type
*
1938 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
1940 struct type
*new_elt_type
;
1941 struct type
*new_type
;
1942 LONGEST low_bound
, high_bound
;
1944 type
= ada_check_typedef (type
);
1945 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1948 new_type
= alloc_type_copy (type
);
1950 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1952 create_array_type (new_type
, new_elt_type
, TYPE_INDEX_TYPE (type
));
1953 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1954 TYPE_NAME (new_type
) = ada_type_name (type
);
1956 if (get_discrete_bounds (TYPE_INDEX_TYPE (type
),
1957 &low_bound
, &high_bound
) < 0)
1958 low_bound
= high_bound
= 0;
1959 if (high_bound
< low_bound
)
1960 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1963 *elt_bits
*= (high_bound
- low_bound
+ 1);
1964 TYPE_LENGTH (new_type
) =
1965 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1968 TYPE_FIXED_INSTANCE (new_type
) = 1;
1972 /* The array type encoded by TYPE, where
1973 ada_is_constrained_packed_array_type (TYPE). */
1975 static struct type
*
1976 decode_constrained_packed_array_type (struct type
*type
)
1978 char *raw_name
= ada_type_name (ada_check_typedef (type
));
1981 struct type
*shadow_type
;
1985 raw_name
= ada_type_name (desc_base_type (type
));
1990 name
= (char *) alloca (strlen (raw_name
) + 1);
1991 tail
= strstr (raw_name
, "___XP");
1992 type
= desc_base_type (type
);
1994 memcpy (name
, raw_name
, tail
- raw_name
);
1995 name
[tail
- raw_name
] = '\000';
1997 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
1999 if (shadow_type
== NULL
)
2001 lim_warning (_("could not find bounds information on packed array"));
2004 CHECK_TYPEDEF (shadow_type
);
2006 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
2008 lim_warning (_("could not understand bounds information on packed array"));
2012 bits
= decode_packed_array_bitsize (type
);
2013 return constrained_packed_array_type (shadow_type
, &bits
);
2016 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2017 array, returns a simple array that denotes that array. Its type is a
2018 standard GDB array type except that the BITSIZEs of the array
2019 target types are set to the number of bits in each element, and the
2020 type length is set appropriately. */
2022 static struct value
*
2023 decode_constrained_packed_array (struct value
*arr
)
2027 arr
= ada_coerce_ref (arr
);
2029 /* If our value is a pointer, then dererence it. Make sure that
2030 this operation does not cause the target type to be fixed, as
2031 this would indirectly cause this array to be decoded. The rest
2032 of the routine assumes that the array hasn't been decoded yet,
2033 so we use the basic "value_ind" routine to perform the dereferencing,
2034 as opposed to using "ada_value_ind". */
2035 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
2036 arr
= value_ind (arr
);
2038 type
= decode_constrained_packed_array_type (value_type (arr
));
2041 error (_("can't unpack array"));
2045 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr
)))
2046 && ada_is_modular_type (value_type (arr
)))
2048 /* This is a (right-justified) modular type representing a packed
2049 array with no wrapper. In order to interpret the value through
2050 the (left-justified) packed array type we just built, we must
2051 first left-justify it. */
2052 int bit_size
, bit_pos
;
2055 mod
= ada_modulus (value_type (arr
)) - 1;
2062 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2063 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2064 bit_pos
/ HOST_CHAR_BIT
,
2065 bit_pos
% HOST_CHAR_BIT
,
2070 return coerce_unspec_val_to_type (arr
, type
);
2074 /* The value of the element of packed array ARR at the ARITY indices
2075 given in IND. ARR must be a simple array. */
2077 static struct value
*
2078 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2081 int bits
, elt_off
, bit_off
;
2082 long elt_total_bit_offset
;
2083 struct type
*elt_type
;
2087 elt_total_bit_offset
= 0;
2088 elt_type
= ada_check_typedef (value_type (arr
));
2089 for (i
= 0; i
< arity
; i
+= 1)
2091 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
2092 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2094 (_("attempt to do packed indexing of something other than a packed array"));
2097 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
2098 LONGEST lowerbound
, upperbound
;
2101 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2103 lim_warning (_("don't know bounds of array"));
2104 lowerbound
= upperbound
= 0;
2107 idx
= pos_atr (ind
[i
]);
2108 if (idx
< lowerbound
|| idx
> upperbound
)
2109 lim_warning (_("packed array index %ld out of bounds"), (long) idx
);
2110 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2111 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2112 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2115 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2116 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2118 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2123 /* Non-zero iff TYPE includes negative integer values. */
2126 has_negatives (struct type
*type
)
2128 switch (TYPE_CODE (type
))
2133 return !TYPE_UNSIGNED (type
);
2134 case TYPE_CODE_RANGE
:
2135 return TYPE_LOW_BOUND (type
) < 0;
2140 /* Create a new value of type TYPE from the contents of OBJ starting
2141 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2142 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2143 assigning through the result will set the field fetched from.
2144 VALADDR is ignored unless OBJ is NULL, in which case,
2145 VALADDR+OFFSET must address the start of storage containing the
2146 packed value. The value returned in this case is never an lval.
2147 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2150 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2151 long offset
, int bit_offset
, int bit_size
,
2155 int src
, /* Index into the source area */
2156 targ
, /* Index into the target area */
2157 srcBitsLeft
, /* Number of source bits left to move */
2158 nsrc
, ntarg
, /* Number of source and target bytes */
2159 unusedLS
, /* Number of bits in next significant
2160 byte of source that are unused */
2161 accumSize
; /* Number of meaningful bits in accum */
2162 unsigned char *bytes
; /* First byte containing data to unpack */
2163 unsigned char *unpacked
;
2164 unsigned long accum
; /* Staging area for bits being transferred */
2166 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2167 /* Transmit bytes from least to most significant; delta is the direction
2168 the indices move. */
2169 int delta
= gdbarch_bits_big_endian (get_type_arch (type
)) ? -1 : 1;
2171 type
= ada_check_typedef (type
);
2175 v
= allocate_value (type
);
2176 bytes
= (unsigned char *) (valaddr
+ offset
);
2178 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2181 value_address (obj
) + offset
);
2182 bytes
= (unsigned char *) alloca (len
);
2183 read_memory (value_address (v
), bytes
, len
);
2187 v
= allocate_value (type
);
2188 bytes
= (unsigned char *) value_contents (obj
) + offset
;
2195 set_value_component_location (v
, obj
);
2196 new_addr
= value_address (obj
) + offset
;
2197 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2198 set_value_bitsize (v
, bit_size
);
2199 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2202 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2204 set_value_address (v
, new_addr
);
2207 set_value_bitsize (v
, bit_size
);
2208 unpacked
= (unsigned char *) value_contents (v
);
2210 srcBitsLeft
= bit_size
;
2212 ntarg
= TYPE_LENGTH (type
);
2216 memset (unpacked
, 0, TYPE_LENGTH (type
));
2219 else if (gdbarch_bits_big_endian (get_type_arch (type
)))
2222 if (has_negatives (type
)
2223 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2227 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2230 switch (TYPE_CODE (type
))
2232 case TYPE_CODE_ARRAY
:
2233 case TYPE_CODE_UNION
:
2234 case TYPE_CODE_STRUCT
:
2235 /* Non-scalar values must be aligned at a byte boundary... */
2237 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2238 /* ... And are placed at the beginning (most-significant) bytes
2240 targ
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2245 targ
= TYPE_LENGTH (type
) - 1;
2251 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2254 unusedLS
= bit_offset
;
2257 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
2264 /* Mask for removing bits of the next source byte that are not
2265 part of the value. */
2266 unsigned int unusedMSMask
=
2267 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2269 /* Sign-extend bits for this byte. */
2270 unsigned int signMask
= sign
& ~unusedMSMask
;
2273 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2274 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2275 if (accumSize
>= HOST_CHAR_BIT
)
2277 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2278 accumSize
-= HOST_CHAR_BIT
;
2279 accum
>>= HOST_CHAR_BIT
;
2283 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2290 accum
|= sign
<< accumSize
;
2291 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2292 accumSize
-= HOST_CHAR_BIT
;
2293 accum
>>= HOST_CHAR_BIT
;
2301 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2302 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2305 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
2306 int src_offset
, int n
, int bits_big_endian_p
)
2308 unsigned int accum
, mask
;
2309 int accum_bits
, chunk_size
;
2311 target
+= targ_offset
/ HOST_CHAR_BIT
;
2312 targ_offset
%= HOST_CHAR_BIT
;
2313 source
+= src_offset
/ HOST_CHAR_BIT
;
2314 src_offset
%= HOST_CHAR_BIT
;
2315 if (bits_big_endian_p
)
2317 accum
= (unsigned char) *source
;
2319 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2325 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2326 accum_bits
+= HOST_CHAR_BIT
;
2328 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2331 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2332 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2335 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2337 accum_bits
-= chunk_size
;
2344 accum
= (unsigned char) *source
>> src_offset
;
2346 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2350 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2351 accum_bits
+= HOST_CHAR_BIT
;
2353 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2356 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2357 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2359 accum_bits
-= chunk_size
;
2360 accum
>>= chunk_size
;
2367 /* Store the contents of FROMVAL into the location of TOVAL.
2368 Return a new value with the location of TOVAL and contents of
2369 FROMVAL. Handles assignment into packed fields that have
2370 floating-point or non-scalar types. */
2372 static struct value
*
2373 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2375 struct type
*type
= value_type (toval
);
2376 int bits
= value_bitsize (toval
);
2378 toval
= ada_coerce_ref (toval
);
2379 fromval
= ada_coerce_ref (fromval
);
2381 if (ada_is_direct_array_type (value_type (toval
)))
2382 toval
= ada_coerce_to_simple_array (toval
);
2383 if (ada_is_direct_array_type (value_type (fromval
)))
2384 fromval
= ada_coerce_to_simple_array (fromval
);
2386 if (!deprecated_value_modifiable (toval
))
2387 error (_("Left operand of assignment is not a modifiable lvalue."));
2389 if (VALUE_LVAL (toval
) == lval_memory
2391 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2392 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2394 int len
= (value_bitpos (toval
)
2395 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2397 char *buffer
= (char *) alloca (len
);
2399 CORE_ADDR to_addr
= value_address (toval
);
2401 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2402 fromval
= value_cast (type
, fromval
);
2404 read_memory (to_addr
, buffer
, len
);
2405 from_size
= value_bitsize (fromval
);
2407 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2408 if (gdbarch_bits_big_endian (get_type_arch (type
)))
2409 move_bits (buffer
, value_bitpos (toval
),
2410 value_contents (fromval
), from_size
- bits
, bits
, 1);
2412 move_bits (buffer
, value_bitpos (toval
),
2413 value_contents (fromval
), 0, bits
, 0);
2414 write_memory (to_addr
, buffer
, len
);
2415 observer_notify_memory_changed (to_addr
, len
, buffer
);
2417 val
= value_copy (toval
);
2418 memcpy (value_contents_raw (val
), value_contents (fromval
),
2419 TYPE_LENGTH (type
));
2420 deprecated_set_value_type (val
, type
);
2425 return value_assign (toval
, fromval
);
2429 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2430 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2431 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2432 * COMPONENT, and not the inferior's memory. The current contents
2433 * of COMPONENT are ignored. */
2435 value_assign_to_component (struct value
*container
, struct value
*component
,
2438 LONGEST offset_in_container
=
2439 (LONGEST
) (value_address (component
) - value_address (container
));
2440 int bit_offset_in_container
=
2441 value_bitpos (component
) - value_bitpos (container
);
2444 val
= value_cast (value_type (component
), val
);
2446 if (value_bitsize (component
) == 0)
2447 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2449 bits
= value_bitsize (component
);
2451 if (gdbarch_bits_big_endian (get_type_arch (value_type (container
))))
2452 move_bits (value_contents_writeable (container
) + offset_in_container
,
2453 value_bitpos (container
) + bit_offset_in_container
,
2454 value_contents (val
),
2455 TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
,
2458 move_bits (value_contents_writeable (container
) + offset_in_container
,
2459 value_bitpos (container
) + bit_offset_in_container
,
2460 value_contents (val
), 0, bits
, 0);
2463 /* The value of the element of array ARR at the ARITY indices given in IND.
2464 ARR may be either a simple array, GNAT array descriptor, or pointer
2468 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2472 struct type
*elt_type
;
2474 elt
= ada_coerce_to_simple_array (arr
);
2476 elt_type
= ada_check_typedef (value_type (elt
));
2477 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2478 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2479 return value_subscript_packed (elt
, arity
, ind
);
2481 for (k
= 0; k
< arity
; k
+= 1)
2483 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2484 error (_("too many subscripts (%d expected)"), k
);
2485 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2490 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2491 value of the element of *ARR at the ARITY indices given in
2492 IND. Does not read the entire array into memory. */
2494 static struct value
*
2495 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2500 for (k
= 0; k
< arity
; k
+= 1)
2504 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2505 error (_("too many subscripts (%d expected)"), k
);
2506 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2508 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2509 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2510 type
= TYPE_TARGET_TYPE (type
);
2513 return value_ind (arr
);
2516 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2517 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2518 elements starting at index LOW. The lower bound of this array is LOW, as
2520 static struct value
*
2521 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2524 CORE_ADDR base
= value_as_address (array_ptr
)
2525 + ((low
- ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type
)))
2526 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2527 struct type
*index_type
=
2528 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2530 struct type
*slice_type
=
2531 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2533 return value_at_lazy (slice_type
, base
);
2537 static struct value
*
2538 ada_value_slice (struct value
*array
, int low
, int high
)
2540 struct type
*type
= value_type (array
);
2541 struct type
*index_type
=
2542 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2543 struct type
*slice_type
=
2544 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2546 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2549 /* If type is a record type in the form of a standard GNAT array
2550 descriptor, returns the number of dimensions for type. If arr is a
2551 simple array, returns the number of "array of"s that prefix its
2552 type designation. Otherwise, returns 0. */
2555 ada_array_arity (struct type
*type
)
2562 type
= desc_base_type (type
);
2565 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2566 return desc_arity (desc_bounds_type (type
));
2568 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2571 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2577 /* If TYPE is a record type in the form of a standard GNAT array
2578 descriptor or a simple array type, returns the element type for
2579 TYPE after indexing by NINDICES indices, or by all indices if
2580 NINDICES is -1. Otherwise, returns NULL. */
2583 ada_array_element_type (struct type
*type
, int nindices
)
2585 type
= desc_base_type (type
);
2587 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2590 struct type
*p_array_type
;
2592 p_array_type
= desc_data_target_type (type
);
2594 k
= ada_array_arity (type
);
2598 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2599 if (nindices
>= 0 && k
> nindices
)
2601 while (k
> 0 && p_array_type
!= NULL
)
2603 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2606 return p_array_type
;
2608 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2610 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2612 type
= TYPE_TARGET_TYPE (type
);
2621 /* The type of nth index in arrays of given type (n numbering from 1).
2622 Does not examine memory. Throws an error if N is invalid or TYPE
2623 is not an array type. NAME is the name of the Ada attribute being
2624 evaluated ('range, 'first, 'last, or 'length); it is used in building
2625 the error message. */
2627 static struct type
*
2628 ada_index_type (struct type
*type
, int n
, const char *name
)
2630 struct type
*result_type
;
2632 type
= desc_base_type (type
);
2634 if (n
< 0 || n
> ada_array_arity (type
))
2635 error (_("invalid dimension number to '%s"), name
);
2637 if (ada_is_simple_array_type (type
))
2641 for (i
= 1; i
< n
; i
+= 1)
2642 type
= TYPE_TARGET_TYPE (type
);
2643 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2644 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2645 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2646 perhaps stabsread.c would make more sense. */
2647 if (result_type
&& TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2652 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2653 if (result_type
== NULL
)
2654 error (_("attempt to take bound of something that is not an array"));
2660 /* Given that arr is an array type, returns the lower bound of the
2661 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2662 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2663 array-descriptor type. It works for other arrays with bounds supplied
2664 by run-time quantities other than discriminants. */
2667 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
)
2669 struct type
*type
, *elt_type
, *index_type_desc
, *index_type
;
2672 gdb_assert (which
== 0 || which
== 1);
2674 if (ada_is_constrained_packed_array_type (arr_type
))
2675 arr_type
= decode_constrained_packed_array_type (arr_type
);
2677 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2678 return (LONGEST
) - which
;
2680 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2681 type
= TYPE_TARGET_TYPE (arr_type
);
2686 for (i
= n
; i
> 1; i
--)
2687 elt_type
= TYPE_TARGET_TYPE (type
);
2689 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2690 ada_fixup_array_indexes_type (index_type_desc
);
2691 if (index_type_desc
!= NULL
)
2692 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, n
- 1),
2695 index_type
= TYPE_INDEX_TYPE (elt_type
);
2698 (LONGEST
) (which
== 0
2699 ? ada_discrete_type_low_bound (index_type
)
2700 : ada_discrete_type_high_bound (index_type
));
2703 /* Given that arr is an array value, returns the lower bound of the
2704 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2705 WHICH is 1. This routine will also work for arrays with bounds
2706 supplied by run-time quantities other than discriminants. */
2709 ada_array_bound (struct value
*arr
, int n
, int which
)
2711 struct type
*arr_type
= value_type (arr
);
2713 if (ada_is_constrained_packed_array_type (arr_type
))
2714 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
2715 else if (ada_is_simple_array_type (arr_type
))
2716 return ada_array_bound_from_type (arr_type
, n
, which
);
2718 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
2721 /* Given that arr is an array value, returns the length of the
2722 nth index. This routine will also work for arrays with bounds
2723 supplied by run-time quantities other than discriminants.
2724 Does not work for arrays indexed by enumeration types with representation
2725 clauses at the moment. */
2728 ada_array_length (struct value
*arr
, int n
)
2730 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2732 if (ada_is_constrained_packed_array_type (arr_type
))
2733 return ada_array_length (decode_constrained_packed_array (arr
), n
);
2735 if (ada_is_simple_array_type (arr_type
))
2736 return (ada_array_bound_from_type (arr_type
, n
, 1)
2737 - ada_array_bound_from_type (arr_type
, n
, 0) + 1);
2739 return (value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1))
2740 - value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0)) + 1);
2743 /* An empty array whose type is that of ARR_TYPE (an array type),
2744 with bounds LOW to LOW-1. */
2746 static struct value
*
2747 empty_array (struct type
*arr_type
, int low
)
2749 struct type
*index_type
=
2750 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2752 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2754 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2758 /* Name resolution */
2760 /* The "decoded" name for the user-definable Ada operator corresponding
2764 ada_decoded_op_name (enum exp_opcode op
)
2768 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2770 if (ada_opname_table
[i
].op
== op
)
2771 return ada_opname_table
[i
].decoded
;
2773 error (_("Could not find operator name for opcode"));
2777 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2778 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2779 undefined namespace) and converts operators that are
2780 user-defined into appropriate function calls. If CONTEXT_TYPE is
2781 non-null, it provides a preferred result type [at the moment, only
2782 type void has any effect---causing procedures to be preferred over
2783 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2784 return type is preferred. May change (expand) *EXP. */
2787 resolve (struct expression
**expp
, int void_context_p
)
2789 struct type
*context_type
= NULL
;
2793 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
2795 resolve_subexp (expp
, &pc
, 1, context_type
);
2798 /* Resolve the operator of the subexpression beginning at
2799 position *POS of *EXPP. "Resolving" consists of replacing
2800 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2801 with their resolutions, replacing built-in operators with
2802 function calls to user-defined operators, where appropriate, and,
2803 when DEPROCEDURE_P is non-zero, converting function-valued variables
2804 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2805 are as in ada_resolve, above. */
2807 static struct value
*
2808 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2809 struct type
*context_type
)
2813 struct expression
*exp
; /* Convenience: == *expp. */
2814 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2815 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2816 int nargs
; /* Number of operands. */
2823 /* Pass one: resolve operands, saving their types and updating *pos,
2828 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2829 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2834 resolve_subexp (expp
, pos
, 0, NULL
);
2836 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2841 resolve_subexp (expp
, pos
, 0, NULL
);
2846 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
));
2849 case OP_ATR_MODULUS
:
2859 case TERNOP_IN_RANGE
:
2860 case BINOP_IN_BOUNDS
:
2866 case OP_DISCRETE_RANGE
:
2868 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
2877 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2879 resolve_subexp (expp
, pos
, 1, NULL
);
2881 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2898 case BINOP_LOGICAL_AND
:
2899 case BINOP_LOGICAL_OR
:
2900 case BINOP_BITWISE_AND
:
2901 case BINOP_BITWISE_IOR
:
2902 case BINOP_BITWISE_XOR
:
2905 case BINOP_NOTEQUAL
:
2912 case BINOP_SUBSCRIPT
:
2920 case UNOP_LOGICAL_NOT
:
2936 case OP_INTERNALVAR
:
2946 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2949 case STRUCTOP_STRUCT
:
2950 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2963 error (_("Unexpected operator during name resolution"));
2966 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2967 for (i
= 0; i
< nargs
; i
+= 1)
2968 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2972 /* Pass two: perform any resolution on principal operator. */
2979 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2981 struct ada_symbol_info
*candidates
;
2985 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2986 (exp
->elts
[pc
+ 2].symbol
),
2987 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2990 if (n_candidates
> 1)
2992 /* Types tend to get re-introduced locally, so if there
2993 are any local symbols that are not types, first filter
2996 for (j
= 0; j
< n_candidates
; j
+= 1)
2997 switch (SYMBOL_CLASS (candidates
[j
].sym
))
3002 case LOC_REGPARM_ADDR
:
3010 if (j
< n_candidates
)
3013 while (j
< n_candidates
)
3015 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
3017 candidates
[j
] = candidates
[n_candidates
- 1];
3026 if (n_candidates
== 0)
3027 error (_("No definition found for %s"),
3028 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3029 else if (n_candidates
== 1)
3031 else if (deprocedure_p
3032 && !is_nonfunction (candidates
, n_candidates
))
3034 i
= ada_resolve_function
3035 (candidates
, n_candidates
, NULL
, 0,
3036 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
3039 error (_("Could not find a match for %s"),
3040 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3044 printf_filtered (_("Multiple matches for %s\n"),
3045 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3046 user_select_syms (candidates
, n_candidates
, 1);
3050 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3051 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
3052 if (innermost_block
== NULL
3053 || contained_in (candidates
[i
].block
, innermost_block
))
3054 innermost_block
= candidates
[i
].block
;
3058 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
3061 replace_operator_with_call (expp
, pc
, 0, 0,
3062 exp
->elts
[pc
+ 2].symbol
,
3063 exp
->elts
[pc
+ 1].block
);
3070 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3071 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3073 struct ada_symbol_info
*candidates
;
3077 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3078 (exp
->elts
[pc
+ 5].symbol
),
3079 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3081 if (n_candidates
== 1)
3085 i
= ada_resolve_function
3086 (candidates
, n_candidates
,
3088 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
3091 error (_("Could not find a match for %s"),
3092 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
3095 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3096 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
3097 if (innermost_block
== NULL
3098 || contained_in (candidates
[i
].block
, innermost_block
))
3099 innermost_block
= candidates
[i
].block
;
3110 case BINOP_BITWISE_AND
:
3111 case BINOP_BITWISE_IOR
:
3112 case BINOP_BITWISE_XOR
:
3114 case BINOP_NOTEQUAL
:
3122 case UNOP_LOGICAL_NOT
:
3124 if (possible_user_operator_p (op
, argvec
))
3126 struct ada_symbol_info
*candidates
;
3130 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
3131 (struct block
*) NULL
, VAR_DOMAIN
,
3133 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
3134 ada_decoded_op_name (op
), NULL
);
3138 replace_operator_with_call (expp
, pc
, nargs
, 1,
3139 candidates
[i
].sym
, candidates
[i
].block
);
3150 return evaluate_subexp_type (exp
, pos
);
3153 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3154 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3156 /* The term "match" here is rather loose. The match is heuristic and
3160 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3162 ftype
= ada_check_typedef (ftype
);
3163 atype
= ada_check_typedef (atype
);
3165 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3166 ftype
= TYPE_TARGET_TYPE (ftype
);
3167 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3168 atype
= TYPE_TARGET_TYPE (atype
);
3170 switch (TYPE_CODE (ftype
))
3173 return TYPE_CODE (ftype
) == TYPE_CODE (atype
);
3175 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3176 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3177 TYPE_TARGET_TYPE (atype
), 0);
3180 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3182 case TYPE_CODE_ENUM
:
3183 case TYPE_CODE_RANGE
:
3184 switch (TYPE_CODE (atype
))
3187 case TYPE_CODE_ENUM
:
3188 case TYPE_CODE_RANGE
:
3194 case TYPE_CODE_ARRAY
:
3195 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3196 || ada_is_array_descriptor_type (atype
));
3198 case TYPE_CODE_STRUCT
:
3199 if (ada_is_array_descriptor_type (ftype
))
3200 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3201 || ada_is_array_descriptor_type (atype
));
3203 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3204 && !ada_is_array_descriptor_type (atype
));
3206 case TYPE_CODE_UNION
:
3208 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3212 /* Return non-zero if the formals of FUNC "sufficiently match" the
3213 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3214 may also be an enumeral, in which case it is treated as a 0-
3215 argument function. */
3218 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3221 struct type
*func_type
= SYMBOL_TYPE (func
);
3223 if (SYMBOL_CLASS (func
) == LOC_CONST
3224 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3225 return (n_actuals
== 0);
3226 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3229 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3232 for (i
= 0; i
< n_actuals
; i
+= 1)
3234 if (actuals
[i
] == NULL
)
3238 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
,
3240 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3242 if (!ada_type_match (ftype
, atype
, 1))
3249 /* False iff function type FUNC_TYPE definitely does not produce a value
3250 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3251 FUNC_TYPE is not a valid function type with a non-null return type
3252 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3255 return_match (struct type
*func_type
, struct type
*context_type
)
3257 struct type
*return_type
;
3259 if (func_type
== NULL
)
3262 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3263 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
3265 return_type
= base_type (func_type
);
3266 if (return_type
== NULL
)
3269 context_type
= base_type (context_type
);
3271 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3272 return context_type
== NULL
|| return_type
== context_type
;
3273 else if (context_type
== NULL
)
3274 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3276 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3280 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3281 function (if any) that matches the types of the NARGS arguments in
3282 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3283 that returns that type, then eliminate matches that don't. If
3284 CONTEXT_TYPE is void and there is at least one match that does not
3285 return void, eliminate all matches that do.
3287 Asks the user if there is more than one match remaining. Returns -1
3288 if there is no such symbol or none is selected. NAME is used
3289 solely for messages. May re-arrange and modify SYMS in
3290 the process; the index returned is for the modified vector. */
3293 ada_resolve_function (struct ada_symbol_info syms
[],
3294 int nsyms
, struct value
**args
, int nargs
,
3295 const char *name
, struct type
*context_type
)
3299 int m
; /* Number of hits */
3302 /* In the first pass of the loop, we only accept functions matching
3303 context_type. If none are found, we add a second pass of the loop
3304 where every function is accepted. */
3305 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3307 for (k
= 0; k
< nsyms
; k
+= 1)
3309 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3311 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3312 && (fallback
|| return_match (type
, context_type
)))
3324 printf_filtered (_("Multiple matches for %s\n"), name
);
3325 user_select_syms (syms
, m
, 1);
3331 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3332 in a listing of choices during disambiguation (see sort_choices, below).
3333 The idea is that overloadings of a subprogram name from the
3334 same package should sort in their source order. We settle for ordering
3335 such symbols by their trailing number (__N or $N). */
3338 encoded_ordered_before (char *N0
, char *N1
)
3342 else if (N0
== NULL
)
3348 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3350 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3352 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3353 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3358 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3361 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3363 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3364 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3366 return (strcmp (N0
, N1
) < 0);
3370 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3374 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3378 for (i
= 1; i
< nsyms
; i
+= 1)
3380 struct ada_symbol_info sym
= syms
[i
];
3383 for (j
= i
- 1; j
>= 0; j
-= 1)
3385 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3386 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3388 syms
[j
+ 1] = syms
[j
];
3394 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3395 by asking the user (if necessary), returning the number selected,
3396 and setting the first elements of SYMS items. Error if no symbols
3399 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3400 to be re-integrated one of these days. */
3403 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3406 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3408 int first_choice
= (max_results
== 1) ? 1 : 2;
3409 const char *select_mode
= multiple_symbols_select_mode ();
3411 if (max_results
< 1)
3412 error (_("Request to select 0 symbols!"));
3416 if (select_mode
== multiple_symbols_cancel
)
3418 canceled because the command is ambiguous\n\
3419 See set/show multiple-symbol."));
3421 /* If select_mode is "all", then return all possible symbols.
3422 Only do that if more than one symbol can be selected, of course.
3423 Otherwise, display the menu as usual. */
3424 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3427 printf_unfiltered (_("[0] cancel\n"));
3428 if (max_results
> 1)
3429 printf_unfiltered (_("[1] all\n"));
3431 sort_choices (syms
, nsyms
);
3433 for (i
= 0; i
< nsyms
; i
+= 1)
3435 if (syms
[i
].sym
== NULL
)
3438 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3440 struct symtab_and_line sal
=
3441 find_function_start_sal (syms
[i
].sym
, 1);
3443 if (sal
.symtab
== NULL
)
3444 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3446 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3449 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3450 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3451 sal
.symtab
->filename
, sal
.line
);
3457 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3458 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3459 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3460 struct symtab
*symtab
= syms
[i
].sym
->symtab
;
3462 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3463 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3465 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3466 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3467 else if (is_enumeral
3468 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3470 printf_unfiltered (("[%d] "), i
+ first_choice
);
3471 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3473 printf_unfiltered (_("'(%s) (enumeral)\n"),
3474 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3476 else if (symtab
!= NULL
)
3477 printf_unfiltered (is_enumeral
3478 ? _("[%d] %s in %s (enumeral)\n")
3479 : _("[%d] %s at %s:?\n"),
3481 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3484 printf_unfiltered (is_enumeral
3485 ? _("[%d] %s (enumeral)\n")
3486 : _("[%d] %s at ?\n"),
3488 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3492 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3495 for (i
= 0; i
< n_chosen
; i
+= 1)
3496 syms
[i
] = syms
[chosen
[i
]];
3501 /* Read and validate a set of numeric choices from the user in the
3502 range 0 .. N_CHOICES-1. Place the results in increasing
3503 order in CHOICES[0 .. N-1], and return N.
3505 The user types choices as a sequence of numbers on one line
3506 separated by blanks, encoding them as follows:
3508 + A choice of 0 means to cancel the selection, throwing an error.
3509 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3510 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3512 The user is not allowed to choose more than MAX_RESULTS values.
3514 ANNOTATION_SUFFIX, if present, is used to annotate the input
3515 prompts (for use with the -f switch). */
3518 get_selections (int *choices
, int n_choices
, int max_results
,
3519 int is_all_choice
, char *annotation_suffix
)
3524 int first_choice
= is_all_choice
? 2 : 1;
3526 prompt
= getenv ("PS2");
3530 args
= command_line_input (prompt
, 0, annotation_suffix
);
3533 error_no_arg (_("one or more choice numbers"));
3537 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3538 order, as given in args. Choices are validated. */
3544 while (isspace (*args
))
3546 if (*args
== '\0' && n_chosen
== 0)
3547 error_no_arg (_("one or more choice numbers"));
3548 else if (*args
== '\0')
3551 choice
= strtol (args
, &args2
, 10);
3552 if (args
== args2
|| choice
< 0
3553 || choice
> n_choices
+ first_choice
- 1)
3554 error (_("Argument must be choice number"));
3558 error (_("cancelled"));
3560 if (choice
< first_choice
)
3562 n_chosen
= n_choices
;
3563 for (j
= 0; j
< n_choices
; j
+= 1)
3567 choice
-= first_choice
;
3569 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3573 if (j
< 0 || choice
!= choices
[j
])
3577 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3578 choices
[k
+ 1] = choices
[k
];
3579 choices
[j
+ 1] = choice
;
3584 if (n_chosen
> max_results
)
3585 error (_("Select no more than %d of the above"), max_results
);
3590 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3591 on the function identified by SYM and BLOCK, and taking NARGS
3592 arguments. Update *EXPP as needed to hold more space. */
3595 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3596 int oplen
, struct symbol
*sym
,
3597 struct block
*block
)
3599 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3600 symbol, -oplen for operator being replaced). */
3601 struct expression
*newexp
= (struct expression
*)
3602 xmalloc (sizeof (struct expression
)
3603 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3604 struct expression
*exp
= *expp
;
3606 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3607 newexp
->language_defn
= exp
->language_defn
;
3608 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3609 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3610 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3612 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3613 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3615 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3616 newexp
->elts
[pc
+ 4].block
= block
;
3617 newexp
->elts
[pc
+ 5].symbol
= sym
;
3623 /* Type-class predicates */
3625 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3629 numeric_type_p (struct type
*type
)
3635 switch (TYPE_CODE (type
))
3640 case TYPE_CODE_RANGE
:
3641 return (type
== TYPE_TARGET_TYPE (type
)
3642 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3649 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3652 integer_type_p (struct type
*type
)
3658 switch (TYPE_CODE (type
))
3662 case TYPE_CODE_RANGE
:
3663 return (type
== TYPE_TARGET_TYPE (type
)
3664 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3671 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3674 scalar_type_p (struct type
*type
)
3680 switch (TYPE_CODE (type
))
3683 case TYPE_CODE_RANGE
:
3684 case TYPE_CODE_ENUM
:
3693 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3696 discrete_type_p (struct type
*type
)
3702 switch (TYPE_CODE (type
))
3705 case TYPE_CODE_RANGE
:
3706 case TYPE_CODE_ENUM
:
3707 case TYPE_CODE_BOOL
:
3715 /* Returns non-zero if OP with operands in the vector ARGS could be
3716 a user-defined function. Errs on the side of pre-defined operators
3717 (i.e., result 0). */
3720 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3722 struct type
*type0
=
3723 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3724 struct type
*type1
=
3725 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3739 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3743 case BINOP_BITWISE_AND
:
3744 case BINOP_BITWISE_IOR
:
3745 case BINOP_BITWISE_XOR
:
3746 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3749 case BINOP_NOTEQUAL
:
3754 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3757 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
3760 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3764 case UNOP_LOGICAL_NOT
:
3766 return (!numeric_type_p (type0
));
3775 1. In the following, we assume that a renaming type's name may
3776 have an ___XD suffix. It would be nice if this went away at some
3778 2. We handle both the (old) purely type-based representation of
3779 renamings and the (new) variable-based encoding. At some point,
3780 it is devoutly to be hoped that the former goes away
3781 (FIXME: hilfinger-2007-07-09).
3782 3. Subprogram renamings are not implemented, although the XRS
3783 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3785 /* If SYM encodes a renaming,
3787 <renaming> renames <renamed entity>,
3789 sets *LEN to the length of the renamed entity's name,
3790 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3791 the string describing the subcomponent selected from the renamed
3792 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3793 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3794 are undefined). Otherwise, returns a value indicating the category
3795 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3796 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3797 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3798 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3799 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3800 may be NULL, in which case they are not assigned.
3802 [Currently, however, GCC does not generate subprogram renamings.] */
3804 enum ada_renaming_category
3805 ada_parse_renaming (struct symbol
*sym
,
3806 const char **renamed_entity
, int *len
,
3807 const char **renaming_expr
)
3809 enum ada_renaming_category kind
;
3814 return ADA_NOT_RENAMING
;
3815 switch (SYMBOL_CLASS (sym
))
3818 return ADA_NOT_RENAMING
;
3820 return parse_old_style_renaming (SYMBOL_TYPE (sym
),
3821 renamed_entity
, len
, renaming_expr
);
3825 case LOC_OPTIMIZED_OUT
:
3826 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
3828 return ADA_NOT_RENAMING
;
3832 kind
= ADA_OBJECT_RENAMING
;
3836 kind
= ADA_EXCEPTION_RENAMING
;
3840 kind
= ADA_PACKAGE_RENAMING
;
3844 kind
= ADA_SUBPROGRAM_RENAMING
;
3848 return ADA_NOT_RENAMING
;
3852 if (renamed_entity
!= NULL
)
3853 *renamed_entity
= info
;
3854 suffix
= strstr (info
, "___XE");
3855 if (suffix
== NULL
|| suffix
== info
)
3856 return ADA_NOT_RENAMING
;
3858 *len
= strlen (info
) - strlen (suffix
);
3860 if (renaming_expr
!= NULL
)
3861 *renaming_expr
= suffix
;
3865 /* Assuming TYPE encodes a renaming according to the old encoding in
3866 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3867 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3868 ADA_NOT_RENAMING otherwise. */
3869 static enum ada_renaming_category
3870 parse_old_style_renaming (struct type
*type
,
3871 const char **renamed_entity
, int *len
,
3872 const char **renaming_expr
)
3874 enum ada_renaming_category kind
;
3879 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
3880 || TYPE_NFIELDS (type
) != 1)
3881 return ADA_NOT_RENAMING
;
3883 name
= type_name_no_tag (type
);
3885 return ADA_NOT_RENAMING
;
3887 name
= strstr (name
, "___XR");
3889 return ADA_NOT_RENAMING
;
3894 kind
= ADA_OBJECT_RENAMING
;
3897 kind
= ADA_EXCEPTION_RENAMING
;
3900 kind
= ADA_PACKAGE_RENAMING
;
3903 kind
= ADA_SUBPROGRAM_RENAMING
;
3906 return ADA_NOT_RENAMING
;
3909 info
= TYPE_FIELD_NAME (type
, 0);
3911 return ADA_NOT_RENAMING
;
3912 if (renamed_entity
!= NULL
)
3913 *renamed_entity
= info
;
3914 suffix
= strstr (info
, "___XE");
3915 if (renaming_expr
!= NULL
)
3916 *renaming_expr
= suffix
+ 5;
3917 if (suffix
== NULL
|| suffix
== info
)
3918 return ADA_NOT_RENAMING
;
3920 *len
= suffix
- info
;
3926 /* Evaluation: Function Calls */
3928 /* Return an lvalue containing the value VAL. This is the identity on
3929 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3930 on the stack, using and updating *SP as the stack pointer, and
3931 returning an lvalue whose value_address points to the copy. */
3933 static struct value
*
3934 ensure_lval (struct value
*val
, struct gdbarch
*gdbarch
, CORE_ADDR
*sp
)
3936 if (! VALUE_LVAL (val
))
3938 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3940 /* The following is taken from the structure-return code in
3941 call_function_by_hand. FIXME: Therefore, some refactoring seems
3943 if (gdbarch_inner_than (gdbarch
, 1, 2))
3945 /* Stack grows downward. Align SP and value_address (val) after
3946 reserving sufficient space. */
3948 if (gdbarch_frame_align_p (gdbarch
))
3949 *sp
= gdbarch_frame_align (gdbarch
, *sp
);
3950 set_value_address (val
, *sp
);
3954 /* Stack grows upward. Align the frame, allocate space, and
3955 then again, re-align the frame. */
3956 if (gdbarch_frame_align_p (gdbarch
))
3957 *sp
= gdbarch_frame_align (gdbarch
, *sp
);
3958 set_value_address (val
, *sp
);
3960 if (gdbarch_frame_align_p (gdbarch
))
3961 *sp
= gdbarch_frame_align (gdbarch
, *sp
);
3963 VALUE_LVAL (val
) = lval_memory
;
3965 write_memory (value_address (val
), value_contents (val
), len
);
3971 /* Return the value ACTUAL, converted to be an appropriate value for a
3972 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3973 allocating any necessary descriptors (fat pointers), or copies of
3974 values not residing in memory, updating it as needed. */
3977 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
,
3978 struct gdbarch
*gdbarch
, CORE_ADDR
*sp
)
3980 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3981 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3982 struct type
*formal_target
=
3983 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3984 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3985 struct type
*actual_target
=
3986 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3987 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3989 if (ada_is_array_descriptor_type (formal_target
)
3990 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3991 return make_array_descriptor (formal_type
, actual
, gdbarch
, sp
);
3992 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3993 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
3995 struct value
*result
;
3997 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3998 && ada_is_array_descriptor_type (actual_target
))
3999 result
= desc_data (actual
);
4000 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
4002 if (VALUE_LVAL (actual
) != lval_memory
)
4006 actual_type
= ada_check_typedef (value_type (actual
));
4007 val
= allocate_value (actual_type
);
4008 memcpy ((char *) value_contents_raw (val
),
4009 (char *) value_contents (actual
),
4010 TYPE_LENGTH (actual_type
));
4011 actual
= ensure_lval (val
, gdbarch
, sp
);
4013 result
= value_addr (actual
);
4017 return value_cast_pointers (formal_type
, result
);
4019 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
4020 return ada_value_ind (actual
);
4025 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4026 type TYPE. This is usually an inefficient no-op except on some targets
4027 (such as AVR) where the representation of a pointer and an address
4031 value_pointer (struct value
*value
, struct type
*type
)
4033 struct gdbarch
*gdbarch
= get_type_arch (type
);
4034 unsigned len
= TYPE_LENGTH (type
);
4035 gdb_byte
*buf
= alloca (len
);
4038 addr
= value_address (value
);
4039 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4040 addr
= extract_unsigned_integer (buf
, len
, gdbarch_byte_order (gdbarch
));
4045 /* Push a descriptor of type TYPE for array value ARR on the stack at
4046 *SP, updating *SP to reflect the new descriptor. Return either
4047 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4048 to-descriptor type rather than a descriptor type), a struct value *
4049 representing a pointer to this descriptor. */
4051 static struct value
*
4052 make_array_descriptor (struct type
*type
, struct value
*arr
,
4053 struct gdbarch
*gdbarch
, CORE_ADDR
*sp
)
4055 struct type
*bounds_type
= desc_bounds_type (type
);
4056 struct type
*desc_type
= desc_base_type (type
);
4057 struct value
*descriptor
= allocate_value (desc_type
);
4058 struct value
*bounds
= allocate_value (bounds_type
);
4061 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
4063 modify_general_field (value_type (bounds
),
4064 value_contents_writeable (bounds
),
4065 ada_array_bound (arr
, i
, 0),
4066 desc_bound_bitpos (bounds_type
, i
, 0),
4067 desc_bound_bitsize (bounds_type
, i
, 0));
4068 modify_general_field (value_type (bounds
),
4069 value_contents_writeable (bounds
),
4070 ada_array_bound (arr
, i
, 1),
4071 desc_bound_bitpos (bounds_type
, i
, 1),
4072 desc_bound_bitsize (bounds_type
, i
, 1));
4075 bounds
= ensure_lval (bounds
, gdbarch
, sp
);
4077 modify_general_field (value_type (descriptor
),
4078 value_contents_writeable (descriptor
),
4079 value_pointer (ensure_lval (arr
, gdbarch
, sp
),
4080 TYPE_FIELD_TYPE (desc_type
, 0)),
4081 fat_pntr_data_bitpos (desc_type
),
4082 fat_pntr_data_bitsize (desc_type
));
4084 modify_general_field (value_type (descriptor
),
4085 value_contents_writeable (descriptor
),
4086 value_pointer (bounds
,
4087 TYPE_FIELD_TYPE (desc_type
, 1)),
4088 fat_pntr_bounds_bitpos (desc_type
),
4089 fat_pntr_bounds_bitsize (desc_type
));
4091 descriptor
= ensure_lval (descriptor
, gdbarch
, sp
);
4093 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
4094 return value_addr (descriptor
);
4099 /* Dummy definitions for an experimental caching module that is not
4100 * used in the public sources. */
4103 lookup_cached_symbol (const char *name
, domain_enum
namespace,
4104 struct symbol
**sym
, struct block
**block
)
4110 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
4111 struct block
*block
)
4117 /* Return the result of a standard (literal, C-like) lookup of NAME in
4118 given DOMAIN, visible from lexical block BLOCK. */
4120 static struct symbol
*
4121 standard_lookup (const char *name
, const struct block
*block
,
4126 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
))
4128 sym
= lookup_symbol_in_language (name
, block
, domain
, language_c
, 0);
4129 cache_symbol (name
, domain
, sym
, block_found
);
4134 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4135 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4136 since they contend in overloading in the same way. */
4138 is_nonfunction (struct ada_symbol_info syms
[], int n
)
4142 for (i
= 0; i
< n
; i
+= 1)
4143 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
4144 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
4145 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
4151 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4152 struct types. Otherwise, they may not. */
4155 equiv_types (struct type
*type0
, struct type
*type1
)
4159 if (type0
== NULL
|| type1
== NULL
4160 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
4162 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
4163 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
4164 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4165 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4171 /* True iff SYM0 represents the same entity as SYM1, or one that is
4172 no more defined than that of SYM1. */
4175 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4179 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4180 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4183 switch (SYMBOL_CLASS (sym0
))
4189 struct type
*type0
= SYMBOL_TYPE (sym0
);
4190 struct type
*type1
= SYMBOL_TYPE (sym1
);
4191 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4192 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4193 int len0
= strlen (name0
);
4196 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4197 && (equiv_types (type0
, type1
)
4198 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4199 && strncmp (name1
+ len0
, "___XV", 5) == 0));
4202 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4203 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4209 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4210 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4213 add_defn_to_vec (struct obstack
*obstackp
,
4215 struct block
*block
)
4218 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
4220 /* Do not try to complete stub types, as the debugger is probably
4221 already scanning all symbols matching a certain name at the
4222 time when this function is called. Trying to replace the stub
4223 type by its associated full type will cause us to restart a scan
4224 which may lead to an infinite recursion. Instead, the client
4225 collecting the matching symbols will end up collecting several
4226 matches, with at least one of them complete. It can then filter
4227 out the stub ones if needed. */
4229 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4231 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
4233 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
4235 prevDefns
[i
].sym
= sym
;
4236 prevDefns
[i
].block
= block
;
4242 struct ada_symbol_info info
;
4246 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
4250 /* Number of ada_symbol_info structures currently collected in
4251 current vector in *OBSTACKP. */
4254 num_defns_collected (struct obstack
*obstackp
)
4256 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
4259 /* Vector of ada_symbol_info structures currently collected in current
4260 vector in *OBSTACKP. If FINISH, close off the vector and return
4261 its final address. */
4263 static struct ada_symbol_info
*
4264 defns_collected (struct obstack
*obstackp
, int finish
)
4267 return obstack_finish (obstackp
);
4269 return (struct ada_symbol_info
*) obstack_base (obstackp
);
4272 /* Return a minimal symbol matching NAME according to Ada decoding
4273 rules. Returns NULL if there is no such minimal symbol. Names
4274 prefixed with "standard__" are handled specially: "standard__" is
4275 first stripped off, and only static and global symbols are searched. */
4277 struct minimal_symbol
*
4278 ada_lookup_simple_minsym (const char *name
)
4280 struct objfile
*objfile
;
4281 struct minimal_symbol
*msymbol
;
4284 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4286 name
+= sizeof ("standard__") - 1;
4290 wild_match
= (strstr (name
, "__") == NULL
);
4292 ALL_MSYMBOLS (objfile
, msymbol
)
4294 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4295 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4302 /* For all subprograms that statically enclose the subprogram of the
4303 selected frame, add symbols matching identifier NAME in DOMAIN
4304 and their blocks to the list of data in OBSTACKP, as for
4305 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4309 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4310 const char *name
, domain_enum
namespace,
4315 /* True if TYPE is definitely an artificial type supplied to a symbol
4316 for which no debugging information was given in the symbol file. */
4319 is_nondebugging_type (struct type
*type
)
4321 char *name
= ada_type_name (type
);
4323 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4326 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4327 duplicate other symbols in the list (The only case I know of where
4328 this happens is when object files containing stabs-in-ecoff are
4329 linked with files containing ordinary ecoff debugging symbols (or no
4330 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4331 Returns the number of items in the modified list. */
4334 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4343 /* If two symbols have the same name and one of them is a stub type,
4344 the get rid of the stub. */
4346 if (TYPE_STUB (SYMBOL_TYPE (syms
[i
].sym
))
4347 && SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
)
4349 for (j
= 0; j
< nsyms
; j
++)
4352 && !TYPE_STUB (SYMBOL_TYPE (syms
[j
].sym
))
4353 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4354 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4355 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0)
4360 /* Two symbols with the same name, same class and same address
4361 should be identical. */
4363 else if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4364 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4365 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4367 for (j
= 0; j
< nsyms
; j
+= 1)
4370 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4371 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4372 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4373 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4374 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4375 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4382 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4383 syms
[j
- 1] = syms
[j
];
4392 /* Given a type that corresponds to a renaming entity, use the type name
4393 to extract the scope (package name or function name, fully qualified,
4394 and following the GNAT encoding convention) where this renaming has been
4395 defined. The string returned needs to be deallocated after use. */
4398 xget_renaming_scope (struct type
*renaming_type
)
4400 /* The renaming types adhere to the following convention:
4401 <scope>__<rename>___<XR extension>.
4402 So, to extract the scope, we search for the "___XR" extension,
4403 and then backtrack until we find the first "__". */
4405 const char *name
= type_name_no_tag (renaming_type
);
4406 char *suffix
= strstr (name
, "___XR");
4411 /* Now, backtrack a bit until we find the first "__". Start looking
4412 at suffix - 3, as the <rename> part is at least one character long. */
4414 for (last
= suffix
- 3; last
> name
; last
--)
4415 if (last
[0] == '_' && last
[1] == '_')
4418 /* Make a copy of scope and return it. */
4420 scope_len
= last
- name
;
4421 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4423 strncpy (scope
, name
, scope_len
);
4424 scope
[scope_len
] = '\0';
4429 /* Return nonzero if NAME corresponds to a package name. */
4432 is_package_name (const char *name
)
4434 /* Here, We take advantage of the fact that no symbols are generated
4435 for packages, while symbols are generated for each function.
4436 So the condition for NAME represent a package becomes equivalent
4437 to NAME not existing in our list of symbols. There is only one
4438 small complication with library-level functions (see below). */
4442 /* If it is a function that has not been defined at library level,
4443 then we should be able to look it up in the symbols. */
4444 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4447 /* Library-level function names start with "_ada_". See if function
4448 "_ada_" followed by NAME can be found. */
4450 /* Do a quick check that NAME does not contain "__", since library-level
4451 functions names cannot contain "__" in them. */
4452 if (strstr (name
, "__") != NULL
)
4455 fun_name
= xstrprintf ("_ada_%s", name
);
4457 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4460 /* Return nonzero if SYM corresponds to a renaming entity that is
4461 not visible from FUNCTION_NAME. */
4464 old_renaming_is_invisible (const struct symbol
*sym
, char *function_name
)
4468 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
4471 scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4473 make_cleanup (xfree
, scope
);
4475 /* If the rename has been defined in a package, then it is visible. */
4476 if (is_package_name (scope
))
4479 /* Check that the rename is in the current function scope by checking
4480 that its name starts with SCOPE. */
4482 /* If the function name starts with "_ada_", it means that it is
4483 a library-level function. Strip this prefix before doing the
4484 comparison, as the encoding for the renaming does not contain
4486 if (strncmp (function_name
, "_ada_", 5) == 0)
4489 return (strncmp (function_name
, scope
, strlen (scope
)) != 0);
4492 /* Remove entries from SYMS that corresponds to a renaming entity that
4493 is not visible from the function associated with CURRENT_BLOCK or
4494 that is superfluous due to the presence of more specific renaming
4495 information. Places surviving symbols in the initial entries of
4496 SYMS and returns the number of surviving symbols.
4499 First, in cases where an object renaming is implemented as a
4500 reference variable, GNAT may produce both the actual reference
4501 variable and the renaming encoding. In this case, we discard the
4504 Second, GNAT emits a type following a specified encoding for each renaming
4505 entity. Unfortunately, STABS currently does not support the definition
4506 of types that are local to a given lexical block, so all renamings types
4507 are emitted at library level. As a consequence, if an application
4508 contains two renaming entities using the same name, and a user tries to
4509 print the value of one of these entities, the result of the ada symbol
4510 lookup will also contain the wrong renaming type.
4512 This function partially covers for this limitation by attempting to
4513 remove from the SYMS list renaming symbols that should be visible
4514 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4515 method with the current information available. The implementation
4516 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4518 - When the user tries to print a rename in a function while there
4519 is another rename entity defined in a package: Normally, the
4520 rename in the function has precedence over the rename in the
4521 package, so the latter should be removed from the list. This is
4522 currently not the case.
4524 - This function will incorrectly remove valid renames if
4525 the CURRENT_BLOCK corresponds to a function which symbol name
4526 has been changed by an "Export" pragma. As a consequence,
4527 the user will be unable to print such rename entities. */
4530 remove_irrelevant_renamings (struct ada_symbol_info
*syms
,
4531 int nsyms
, const struct block
*current_block
)
4533 struct symbol
*current_function
;
4534 char *current_function_name
;
4536 int is_new_style_renaming
;
4538 /* If there is both a renaming foo___XR... encoded as a variable and
4539 a simple variable foo in the same block, discard the latter.
4540 First, zero out such symbols, then compress. */
4541 is_new_style_renaming
= 0;
4542 for (i
= 0; i
< nsyms
; i
+= 1)
4544 struct symbol
*sym
= syms
[i
].sym
;
4545 struct block
*block
= syms
[i
].block
;
4549 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
4551 name
= SYMBOL_LINKAGE_NAME (sym
);
4552 suffix
= strstr (name
, "___XR");
4556 int name_len
= suffix
- name
;
4559 is_new_style_renaming
= 1;
4560 for (j
= 0; j
< nsyms
; j
+= 1)
4561 if (i
!= j
&& syms
[j
].sym
!= NULL
4562 && strncmp (name
, SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
4564 && block
== syms
[j
].block
)
4568 if (is_new_style_renaming
)
4572 for (j
= k
= 0; j
< nsyms
; j
+= 1)
4573 if (syms
[j
].sym
!= NULL
)
4581 /* Extract the function name associated to CURRENT_BLOCK.
4582 Abort if unable to do so. */
4584 if (current_block
== NULL
)
4587 current_function
= block_linkage_function (current_block
);
4588 if (current_function
== NULL
)
4591 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4592 if (current_function_name
== NULL
)
4595 /* Check each of the symbols, and remove it from the list if it is
4596 a type corresponding to a renaming that is out of the scope of
4597 the current block. */
4602 if (ada_parse_renaming (syms
[i
].sym
, NULL
, NULL
, NULL
)
4603 == ADA_OBJECT_RENAMING
4604 && old_renaming_is_invisible (syms
[i
].sym
, current_function_name
))
4608 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4609 syms
[j
- 1] = syms
[j
];
4619 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4620 whose name and domain match NAME and DOMAIN respectively.
4621 If no match was found, then extend the search to "enclosing"
4622 routines (in other words, if we're inside a nested function,
4623 search the symbols defined inside the enclosing functions).
4625 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4628 ada_add_local_symbols (struct obstack
*obstackp
, const char *name
,
4629 struct block
*block
, domain_enum domain
,
4632 int block_depth
= 0;
4634 while (block
!= NULL
)
4637 ada_add_block_symbols (obstackp
, block
, name
, domain
, NULL
, wild_match
);
4639 /* If we found a non-function match, assume that's the one. */
4640 if (is_nonfunction (defns_collected (obstackp
, 0),
4641 num_defns_collected (obstackp
)))
4644 block
= BLOCK_SUPERBLOCK (block
);
4647 /* If no luck so far, try to find NAME as a local symbol in some lexically
4648 enclosing subprogram. */
4649 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
4650 add_symbols_from_enclosing_procs (obstackp
, name
, domain
, wild_match
);
4653 /* An object of this type is used as the user_data argument when
4654 calling the map_ada_symtabs method. */
4656 struct ada_psym_data
4658 struct obstack
*obstackp
;
4665 /* Callback function for map_ada_symtabs. */
4668 ada_add_psyms (struct objfile
*objfile
, struct symtab
*s
, void *user_data
)
4670 struct ada_psym_data
*data
= user_data
;
4671 const int block_kind
= data
->global
? GLOBAL_BLOCK
: STATIC_BLOCK
;
4673 ada_add_block_symbols (data
->obstackp
,
4674 BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), block_kind
),
4675 data
->name
, data
->domain
, objfile
, data
->wild_match
);
4678 /* Add to OBSTACKP all non-local symbols whose name and domain match
4679 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
4680 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
4683 ada_add_non_local_symbols (struct obstack
*obstackp
, const char *name
,
4684 domain_enum domain
, int global
,
4687 struct objfile
*objfile
;
4688 struct ada_psym_data data
;
4690 data
.obstackp
= obstackp
;
4692 data
.domain
= domain
;
4693 data
.global
= global
;
4694 data
.wild_match
= is_wild_match
;
4696 ALL_OBJFILES (objfile
)
4699 objfile
->sf
->qf
->map_ada_symtabs (objfile
, wild_match
, is_name_suffix
,
4700 ada_add_psyms
, name
,
4702 is_wild_match
, &data
);
4706 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4707 scope and in global scopes, returning the number of matches. Sets
4708 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4709 indicating the symbols found and the blocks and symbol tables (if
4710 any) in which they were found. This vector are transient---good only to
4711 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4712 symbol match within the nest of blocks whose innermost member is BLOCK0,
4713 is the one match returned (no other matches in that or
4714 enclosing blocks is returned). If there are any matches in or
4715 surrounding BLOCK0, then these alone are returned. Otherwise, the
4716 search extends to global and file-scope (static) symbol tables.
4717 Names prefixed with "standard__" are handled specially: "standard__"
4718 is first stripped off, and only static and global symbols are searched. */
4721 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4722 domain_enum
namespace,
4723 struct ada_symbol_info
**results
)
4726 struct block
*block
;
4732 obstack_free (&symbol_list_obstack
, NULL
);
4733 obstack_init (&symbol_list_obstack
);
4737 /* Search specified block and its superiors. */
4739 wild_match
= (strstr (name0
, "__") == NULL
);
4741 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4742 needed, but adding const will
4743 have a cascade effect. */
4745 /* Special case: If the user specifies a symbol name inside package
4746 Standard, do a non-wild matching of the symbol name without
4747 the "standard__" prefix. This was primarily introduced in order
4748 to allow the user to specifically access the standard exceptions
4749 using, for instance, Standard.Constraint_Error when Constraint_Error
4750 is ambiguous (due to the user defining its own Constraint_Error
4751 entity inside its program). */
4752 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4756 name
= name0
+ sizeof ("standard__") - 1;
4759 /* Check the non-global symbols. If we have ANY match, then we're done. */
4761 ada_add_local_symbols (&symbol_list_obstack
, name
, block
, namespace,
4763 if (num_defns_collected (&symbol_list_obstack
) > 0)
4766 /* No non-global symbols found. Check our cache to see if we have
4767 already performed this search before. If we have, then return
4771 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
))
4774 add_defn_to_vec (&symbol_list_obstack
, sym
, block
);
4778 /* Search symbols from all global blocks. */
4780 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 1,
4783 /* Now add symbols from all per-file blocks if we've gotten no hits
4784 (not strictly correct, but perhaps better than an error). */
4786 if (num_defns_collected (&symbol_list_obstack
) == 0)
4787 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 0,
4791 ndefns
= num_defns_collected (&symbol_list_obstack
);
4792 *results
= defns_collected (&symbol_list_obstack
, 1);
4794 ndefns
= remove_extra_symbols (*results
, ndefns
);
4797 cache_symbol (name0
, namespace, NULL
, NULL
);
4799 if (ndefns
== 1 && cacheIfUnique
)
4800 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
);
4802 ndefns
= remove_irrelevant_renamings (*results
, ndefns
, block0
);
4808 ada_lookup_encoded_symbol (const char *name
, const struct block
*block0
,
4809 domain_enum
namespace, struct block
**block_found
)
4811 struct ada_symbol_info
*candidates
;
4814 n_candidates
= ada_lookup_symbol_list (name
, block0
, namespace, &candidates
);
4816 if (n_candidates
== 0)
4819 if (block_found
!= NULL
)
4820 *block_found
= candidates
[0].block
;
4822 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4825 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4826 scope and in global scopes, or NULL if none. NAME is folded and
4827 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4828 choosing the first symbol if there are multiple choices.
4829 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4830 table in which the symbol was found (in both cases, these
4831 assignments occur only if the pointers are non-null). */
4833 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4834 domain_enum
namespace, int *is_a_field_of_this
)
4836 if (is_a_field_of_this
!= NULL
)
4837 *is_a_field_of_this
= 0;
4840 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name
)),
4841 block0
, namespace, NULL
);
4844 static struct symbol
*
4845 ada_lookup_symbol_nonlocal (const char *name
,
4846 const struct block
*block
,
4847 const domain_enum domain
)
4849 return ada_lookup_symbol (name
, block_static_block (block
), domain
, NULL
);
4853 /* True iff STR is a possible encoded suffix of a normal Ada name
4854 that is to be ignored for matching purposes. Suffixes of parallel
4855 names (e.g., XVE) are not included here. Currently, the possible suffixes
4856 are given by any of the regular expressions:
4858 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
4859 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4860 _E[0-9]+[bs]$ [protected object entry suffixes]
4861 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4863 Also, any leading "__[0-9]+" sequence is skipped before the suffix
4864 match is performed. This sequence is used to differentiate homonyms,
4865 is an optional part of a valid name suffix. */
4868 is_name_suffix (const char *str
)
4871 const char *matching
;
4872 const int len
= strlen (str
);
4874 /* Skip optional leading __[0-9]+. */
4876 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4879 while (isdigit (str
[0]))
4885 if (str
[0] == '.' || str
[0] == '$')
4888 while (isdigit (matching
[0]))
4890 if (matching
[0] == '\0')
4896 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4899 while (isdigit (matching
[0]))
4901 if (matching
[0] == '\0')
4906 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4907 with a N at the end. Unfortunately, the compiler uses the same
4908 convention for other internal types it creates. So treating
4909 all entity names that end with an "N" as a name suffix causes
4910 some regressions. For instance, consider the case of an enumerated
4911 type. To support the 'Image attribute, it creates an array whose
4913 Having a single character like this as a suffix carrying some
4914 information is a bit risky. Perhaps we should change the encoding
4915 to be something like "_N" instead. In the meantime, do not do
4916 the following check. */
4917 /* Protected Object Subprograms */
4918 if (len
== 1 && str
[0] == 'N')
4923 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
4926 while (isdigit (matching
[0]))
4928 if ((matching
[0] == 'b' || matching
[0] == 's')
4929 && matching
[1] == '\0')
4933 /* ??? We should not modify STR directly, as we are doing below. This
4934 is fine in this case, but may become problematic later if we find
4935 that this alternative did not work, and want to try matching
4936 another one from the begining of STR. Since we modified it, we
4937 won't be able to find the begining of the string anymore! */
4941 while (str
[0] != '_' && str
[0] != '\0')
4943 if (str
[0] != 'n' && str
[0] != 'b')
4949 if (str
[0] == '\000')
4954 if (str
[1] != '_' || str
[2] == '\000')
4958 if (strcmp (str
+ 3, "JM") == 0)
4960 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4961 the LJM suffix in favor of the JM one. But we will
4962 still accept LJM as a valid suffix for a reasonable
4963 amount of time, just to allow ourselves to debug programs
4964 compiled using an older version of GNAT. */
4965 if (strcmp (str
+ 3, "LJM") == 0)
4969 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4970 || str
[4] == 'U' || str
[4] == 'P')
4972 if (str
[4] == 'R' && str
[5] != 'T')
4976 if (!isdigit (str
[2]))
4978 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4979 if (!isdigit (str
[k
]) && str
[k
] != '_')
4983 if (str
[0] == '$' && isdigit (str
[1]))
4985 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4986 if (!isdigit (str
[k
]) && str
[k
] != '_')
4993 /* Return non-zero if the string starting at NAME and ending before
4994 NAME_END contains no capital letters. */
4997 is_valid_name_for_wild_match (const char *name0
)
4999 const char *decoded_name
= ada_decode (name0
);
5002 /* If the decoded name starts with an angle bracket, it means that
5003 NAME0 does not follow the GNAT encoding format. It should then
5004 not be allowed as a possible wild match. */
5005 if (decoded_name
[0] == '<')
5008 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5009 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5015 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
5016 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
5017 informational suffixes of NAME (i.e., for which is_name_suffix is
5021 wild_match (const char *patn0
, int patn_len
, const char *name0
)
5029 match
= strstr (start
, patn0
);
5034 || (match
> name0
+ 1 && match
[-1] == '_' && match
[-2] == '_')
5035 || (match
== name0
+ 5 && strncmp ("_ada_", name0
, 5) == 0))
5036 && is_name_suffix (match
+ patn_len
))
5037 return (match
== name0
|| is_valid_name_for_wild_match (name0
));
5042 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5043 vector *defn_symbols, updating the list of symbols in OBSTACKP
5044 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5045 OBJFILE is the section containing BLOCK.
5046 SYMTAB is recorded with each symbol added. */
5049 ada_add_block_symbols (struct obstack
*obstackp
,
5050 struct block
*block
, const char *name
,
5051 domain_enum domain
, struct objfile
*objfile
,
5054 struct dict_iterator iter
;
5055 int name_len
= strlen (name
);
5056 /* A matching argument symbol, if any. */
5057 struct symbol
*arg_sym
;
5058 /* Set true when we find a matching non-argument symbol. */
5068 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5070 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5071 SYMBOL_DOMAIN (sym
), domain
)
5072 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
5074 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5076 else if (SYMBOL_IS_ARGUMENT (sym
))
5081 add_defn_to_vec (obstackp
,
5082 fixup_symbol_section (sym
, objfile
),
5090 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5092 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5093 SYMBOL_DOMAIN (sym
), domain
))
5095 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
5098 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5100 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5102 if (SYMBOL_IS_ARGUMENT (sym
))
5107 add_defn_to_vec (obstackp
,
5108 fixup_symbol_section (sym
, objfile
),
5117 if (!found_sym
&& arg_sym
!= NULL
)
5119 add_defn_to_vec (obstackp
,
5120 fixup_symbol_section (arg_sym
, objfile
),
5129 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5131 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5132 SYMBOL_DOMAIN (sym
), domain
))
5136 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5139 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5141 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5146 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5148 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5150 if (SYMBOL_IS_ARGUMENT (sym
))
5155 add_defn_to_vec (obstackp
,
5156 fixup_symbol_section (sym
, objfile
),
5164 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5165 They aren't parameters, right? */
5166 if (!found_sym
&& arg_sym
!= NULL
)
5168 add_defn_to_vec (obstackp
,
5169 fixup_symbol_section (arg_sym
, objfile
),
5176 /* Symbol Completion */
5178 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5179 name in a form that's appropriate for the completion. The result
5180 does not need to be deallocated, but is only good until the next call.
5182 TEXT_LEN is equal to the length of TEXT.
5183 Perform a wild match if WILD_MATCH is set.
5184 ENCODED should be set if TEXT represents the start of a symbol name
5185 in its encoded form. */
5188 symbol_completion_match (const char *sym_name
,
5189 const char *text
, int text_len
,
5190 int wild_match
, int encoded
)
5192 const int verbatim_match
= (text
[0] == '<');
5197 /* Strip the leading angle bracket. */
5202 /* First, test against the fully qualified name of the symbol. */
5204 if (strncmp (sym_name
, text
, text_len
) == 0)
5207 if (match
&& !encoded
)
5209 /* One needed check before declaring a positive match is to verify
5210 that iff we are doing a verbatim match, the decoded version
5211 of the symbol name starts with '<'. Otherwise, this symbol name
5212 is not a suitable completion. */
5213 const char *sym_name_copy
= sym_name
;
5214 int has_angle_bracket
;
5216 sym_name
= ada_decode (sym_name
);
5217 has_angle_bracket
= (sym_name
[0] == '<');
5218 match
= (has_angle_bracket
== verbatim_match
);
5219 sym_name
= sym_name_copy
;
5222 if (match
&& !verbatim_match
)
5224 /* When doing non-verbatim match, another check that needs to
5225 be done is to verify that the potentially matching symbol name
5226 does not include capital letters, because the ada-mode would
5227 not be able to understand these symbol names without the
5228 angle bracket notation. */
5231 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
5236 /* Second: Try wild matching... */
5238 if (!match
&& wild_match
)
5240 /* Since we are doing wild matching, this means that TEXT
5241 may represent an unqualified symbol name. We therefore must
5242 also compare TEXT against the unqualified name of the symbol. */
5243 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
5245 if (strncmp (sym_name
, text
, text_len
) == 0)
5249 /* Finally: If we found a mach, prepare the result to return. */
5255 sym_name
= add_angle_brackets (sym_name
);
5258 sym_name
= ada_decode (sym_name
);
5263 DEF_VEC_P (char_ptr
);
5265 /* A companion function to ada_make_symbol_completion_list().
5266 Check if SYM_NAME represents a symbol which name would be suitable
5267 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5268 it is appended at the end of the given string vector SV.
5270 ORIG_TEXT is the string original string from the user command
5271 that needs to be completed. WORD is the entire command on which
5272 completion should be performed. These two parameters are used to
5273 determine which part of the symbol name should be added to the
5275 if WILD_MATCH is set, then wild matching is performed.
5276 ENCODED should be set if TEXT represents a symbol name in its
5277 encoded formed (in which case the completion should also be
5281 symbol_completion_add (VEC(char_ptr
) **sv
,
5282 const char *sym_name
,
5283 const char *text
, int text_len
,
5284 const char *orig_text
, const char *word
,
5285 int wild_match
, int encoded
)
5287 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
5288 wild_match
, encoded
);
5294 /* We found a match, so add the appropriate completion to the given
5297 if (word
== orig_text
)
5299 completion
= xmalloc (strlen (match
) + 5);
5300 strcpy (completion
, match
);
5302 else if (word
> orig_text
)
5304 /* Return some portion of sym_name. */
5305 completion
= xmalloc (strlen (match
) + 5);
5306 strcpy (completion
, match
+ (word
- orig_text
));
5310 /* Return some of ORIG_TEXT plus sym_name. */
5311 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
5312 strncpy (completion
, word
, orig_text
- word
);
5313 completion
[orig_text
- word
] = '\0';
5314 strcat (completion
, match
);
5317 VEC_safe_push (char_ptr
, *sv
, completion
);
5320 /* An object of this type is passed as the user_data argument to the
5321 map_partial_symbol_names method. */
5322 struct add_partial_datum
5324 VEC(char_ptr
) **completions
;
5333 /* A callback for map_partial_symbol_names. */
5335 ada_add_partial_symbol_completions (const char *name
, void *user_data
)
5337 struct add_partial_datum
*data
= user_data
;
5339 symbol_completion_add (data
->completions
, name
,
5340 data
->text
, data
->text_len
, data
->text0
, data
->word
,
5341 data
->wild_match
, data
->encoded
);
5344 /* Return a list of possible symbol names completing TEXT0. The list
5345 is NULL terminated. WORD is the entire command on which completion
5349 ada_make_symbol_completion_list (char *text0
, char *word
)
5355 VEC(char_ptr
) *completions
= VEC_alloc (char_ptr
, 128);
5358 struct minimal_symbol
*msymbol
;
5359 struct objfile
*objfile
;
5360 struct block
*b
, *surrounding_static_block
= 0;
5362 struct dict_iterator iter
;
5364 if (text0
[0] == '<')
5366 text
= xstrdup (text0
);
5367 make_cleanup (xfree
, text
);
5368 text_len
= strlen (text
);
5374 text
= xstrdup (ada_encode (text0
));
5375 make_cleanup (xfree
, text
);
5376 text_len
= strlen (text
);
5377 for (i
= 0; i
< text_len
; i
++)
5378 text
[i
] = tolower (text
[i
]);
5380 encoded
= (strstr (text0
, "__") != NULL
);
5381 /* If the name contains a ".", then the user is entering a fully
5382 qualified entity name, and the match must not be done in wild
5383 mode. Similarly, if the user wants to complete what looks like
5384 an encoded name, the match must not be done in wild mode. */
5385 wild_match
= (strchr (text0
, '.') == NULL
&& !encoded
);
5388 /* First, look at the partial symtab symbols. */
5390 struct add_partial_datum data
;
5392 data
.completions
= &completions
;
5394 data
.text_len
= text_len
;
5397 data
.wild_match
= wild_match
;
5398 data
.encoded
= encoded
;
5399 map_partial_symbol_names (ada_add_partial_symbol_completions
, &data
);
5402 /* At this point scan through the misc symbol vectors and add each
5403 symbol you find to the list. Eventually we want to ignore
5404 anything that isn't a text symbol (everything else will be
5405 handled by the psymtab code above). */
5407 ALL_MSYMBOLS (objfile
, msymbol
)
5410 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (msymbol
),
5411 text
, text_len
, text0
, word
, wild_match
, encoded
);
5414 /* Search upwards from currently selected frame (so that we can
5415 complete on local vars. */
5417 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
5419 if (!BLOCK_SUPERBLOCK (b
))
5420 surrounding_static_block
= b
; /* For elmin of dups */
5422 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5424 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5425 text
, text_len
, text0
, word
,
5426 wild_match
, encoded
);
5430 /* Go through the symtabs and check the externs and statics for
5431 symbols which match. */
5433 ALL_SYMTABS (objfile
, s
)
5436 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
5437 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5439 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5440 text
, text_len
, text0
, word
,
5441 wild_match
, encoded
);
5445 ALL_SYMTABS (objfile
, s
)
5448 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
5449 /* Don't do this block twice. */
5450 if (b
== surrounding_static_block
)
5452 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5454 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5455 text
, text_len
, text0
, word
,
5456 wild_match
, encoded
);
5460 /* Append the closing NULL entry. */
5461 VEC_safe_push (char_ptr
, completions
, NULL
);
5463 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5464 return the copy. It's unfortunate that we have to make a copy
5465 of an array that we're about to destroy, but there is nothing much
5466 we can do about it. Fortunately, it's typically not a very large
5469 const size_t completions_size
=
5470 VEC_length (char_ptr
, completions
) * sizeof (char *);
5471 char **result
= malloc (completions_size
);
5473 memcpy (result
, VEC_address (char_ptr
, completions
), completions_size
);
5475 VEC_free (char_ptr
, completions
);
5482 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5483 for tagged types. */
5486 ada_is_dispatch_table_ptr_type (struct type
*type
)
5490 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
5493 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
5497 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
5500 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5501 to be invisible to users. */
5504 ada_is_ignored_field (struct type
*type
, int field_num
)
5506 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5509 /* Check the name of that field. */
5511 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5513 /* Anonymous field names should not be printed.
5514 brobecker/2007-02-20: I don't think this can actually happen
5515 but we don't want to print the value of annonymous fields anyway. */
5519 /* A field named "_parent" is internally generated by GNAT for
5520 tagged types, and should not be printed either. */
5521 if (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0)
5525 /* If this is the dispatch table of a tagged type, then ignore. */
5526 if (ada_is_tagged_type (type
, 1)
5527 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
)))
5530 /* Not a special field, so it should not be ignored. */
5534 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5535 pointer or reference type whose ultimate target has a tag field. */
5538 ada_is_tagged_type (struct type
*type
, int refok
)
5540 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
5543 /* True iff TYPE represents the type of X'Tag */
5546 ada_is_tag_type (struct type
*type
)
5548 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
5552 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
5554 return (name
!= NULL
5555 && strcmp (name
, "ada__tags__dispatch_table") == 0);
5559 /* The type of the tag on VAL. */
5562 ada_tag_type (struct value
*val
)
5564 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
5567 /* The value of the tag on VAL. */
5570 ada_value_tag (struct value
*val
)
5572 return ada_value_struct_elt (val
, "_tag", 0);
5575 /* The value of the tag on the object of type TYPE whose contents are
5576 saved at VALADDR, if it is non-null, or is at memory address
5579 static struct value
*
5580 value_tag_from_contents_and_address (struct type
*type
,
5581 const gdb_byte
*valaddr
,
5584 int tag_byte_offset
;
5585 struct type
*tag_type
;
5587 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5590 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
5592 : valaddr
+ tag_byte_offset
);
5593 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5595 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5600 static struct type
*
5601 type_from_tag (struct value
*tag
)
5603 const char *type_name
= ada_tag_name (tag
);
5605 if (type_name
!= NULL
)
5606 return ada_find_any_type (ada_encode (type_name
));
5617 static int ada_tag_name_1 (void *);
5618 static int ada_tag_name_2 (struct tag_args
*);
5620 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5621 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5622 The value stored in ARGS->name is valid until the next call to
5626 ada_tag_name_1 (void *args0
)
5628 struct tag_args
*args
= (struct tag_args
*) args0
;
5629 static char name
[1024];
5634 val
= ada_value_struct_elt (args
->tag
, "tsd", 1);
5636 return ada_tag_name_2 (args
);
5637 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5640 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5641 for (p
= name
; *p
!= '\0'; p
+= 1)
5648 /* Return the "ada__tags__type_specific_data" type. */
5650 static struct type
*
5651 ada_get_tsd_type (struct inferior
*inf
)
5653 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
5655 if (data
->tsd_type
== 0)
5656 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
5657 return data
->tsd_type
;
5660 /* Utility function for ada_tag_name_1 that tries the second
5661 representation for the dispatch table (in which there is no
5662 explicit 'tsd' field in the referent of the tag pointer, and instead
5663 the tsd pointer is stored just before the dispatch table. */
5666 ada_tag_name_2 (struct tag_args
*args
)
5668 struct type
*info_type
;
5669 static char name
[1024];
5671 struct value
*val
, *valp
;
5674 info_type
= ada_get_tsd_type (current_inferior());
5675 if (info_type
== NULL
)
5677 info_type
= lookup_pointer_type (lookup_pointer_type (info_type
));
5678 valp
= value_cast (info_type
, args
->tag
);
5681 val
= value_ind (value_ptradd (valp
, -1));
5684 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5687 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5688 for (p
= name
; *p
!= '\0'; p
+= 1)
5695 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5699 ada_tag_name (struct value
*tag
)
5701 struct tag_args args
;
5703 if (!ada_is_tag_type (value_type (tag
)))
5707 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5711 /* The parent type of TYPE, or NULL if none. */
5714 ada_parent_type (struct type
*type
)
5718 type
= ada_check_typedef (type
);
5720 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5723 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5724 if (ada_is_parent_field (type
, i
))
5726 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
5728 /* If the _parent field is a pointer, then dereference it. */
5729 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
5730 parent_type
= TYPE_TARGET_TYPE (parent_type
);
5731 /* If there is a parallel XVS type, get the actual base type. */
5732 parent_type
= ada_get_base_type (parent_type
);
5734 return ada_check_typedef (parent_type
);
5740 /* True iff field number FIELD_NUM of structure type TYPE contains the
5741 parent-type (inherited) fields of a derived type. Assumes TYPE is
5742 a structure type with at least FIELD_NUM+1 fields. */
5745 ada_is_parent_field (struct type
*type
, int field_num
)
5747 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5749 return (name
!= NULL
5750 && (strncmp (name
, "PARENT", 6) == 0
5751 || strncmp (name
, "_parent", 7) == 0));
5754 /* True iff field number FIELD_NUM of structure type TYPE is a
5755 transparent wrapper field (which should be silently traversed when doing
5756 field selection and flattened when printing). Assumes TYPE is a
5757 structure type with at least FIELD_NUM+1 fields. Such fields are always
5761 ada_is_wrapper_field (struct type
*type
, int field_num
)
5763 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5765 return (name
!= NULL
5766 && (strncmp (name
, "PARENT", 6) == 0
5767 || strcmp (name
, "REP") == 0
5768 || strncmp (name
, "_parent", 7) == 0
5769 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5772 /* True iff field number FIELD_NUM of structure or union type TYPE
5773 is a variant wrapper. Assumes TYPE is a structure type with at least
5774 FIELD_NUM+1 fields. */
5777 ada_is_variant_part (struct type
*type
, int field_num
)
5779 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5781 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5782 || (is_dynamic_field (type
, field_num
)
5783 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5784 == TYPE_CODE_UNION
)));
5787 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5788 whose discriminants are contained in the record type OUTER_TYPE,
5789 returns the type of the controlling discriminant for the variant.
5790 May return NULL if the type could not be found. */
5793 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5795 char *name
= ada_variant_discrim_name (var_type
);
5797 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5800 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5801 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5802 represents a 'when others' clause; otherwise 0. */
5805 ada_is_others_clause (struct type
*type
, int field_num
)
5807 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5809 return (name
!= NULL
&& name
[0] == 'O');
5812 /* Assuming that TYPE0 is the type of the variant part of a record,
5813 returns the name of the discriminant controlling the variant.
5814 The value is valid until the next call to ada_variant_discrim_name. */
5817 ada_variant_discrim_name (struct type
*type0
)
5819 static char *result
= NULL
;
5820 static size_t result_len
= 0;
5823 const char *discrim_end
;
5824 const char *discrim_start
;
5826 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5827 type
= TYPE_TARGET_TYPE (type0
);
5831 name
= ada_type_name (type
);
5833 if (name
== NULL
|| name
[0] == '\000')
5836 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5839 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5842 if (discrim_end
== name
)
5845 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5848 if (discrim_start
== name
+ 1)
5850 if ((discrim_start
> name
+ 3
5851 && strncmp (discrim_start
- 3, "___", 3) == 0)
5852 || discrim_start
[-1] == '.')
5856 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5857 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5858 result
[discrim_end
- discrim_start
] = '\0';
5862 /* Scan STR for a subtype-encoded number, beginning at position K.
5863 Put the position of the character just past the number scanned in
5864 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5865 Return 1 if there was a valid number at the given position, and 0
5866 otherwise. A "subtype-encoded" number consists of the absolute value
5867 in decimal, followed by the letter 'm' to indicate a negative number.
5868 Assumes 0m does not occur. */
5871 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5875 if (!isdigit (str
[k
]))
5878 /* Do it the hard way so as not to make any assumption about
5879 the relationship of unsigned long (%lu scan format code) and
5882 while (isdigit (str
[k
]))
5884 RU
= RU
* 10 + (str
[k
] - '0');
5891 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5897 /* NOTE on the above: Technically, C does not say what the results of
5898 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5899 number representable as a LONGEST (although either would probably work
5900 in most implementations). When RU>0, the locution in the then branch
5901 above is always equivalent to the negative of RU. */
5908 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5909 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5910 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5913 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5915 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5929 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5939 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5940 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5942 if (val
>= L
&& val
<= U
)
5954 /* FIXME: Lots of redundancy below. Try to consolidate. */
5956 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5957 ARG_TYPE, extract and return the value of one of its (non-static)
5958 fields. FIELDNO says which field. Differs from value_primitive_field
5959 only in that it can handle packed values of arbitrary type. */
5961 static struct value
*
5962 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5963 struct type
*arg_type
)
5967 arg_type
= ada_check_typedef (arg_type
);
5968 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5970 /* Handle packed fields. */
5972 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5974 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5975 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5977 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
5978 offset
+ bit_pos
/ 8,
5979 bit_pos
% 8, bit_size
, type
);
5982 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5985 /* Find field with name NAME in object of type TYPE. If found,
5986 set the following for each argument that is non-null:
5987 - *FIELD_TYPE_P to the field's type;
5988 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
5989 an object of that type;
5990 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
5991 - *BIT_SIZE_P to its size in bits if the field is packed, and
5993 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
5994 fields up to but not including the desired field, or by the total
5995 number of fields if not found. A NULL value of NAME never
5996 matches; the function just counts visible fields in this case.
5998 Returns 1 if found, 0 otherwise. */
6001 find_struct_field (char *name
, struct type
*type
, int offset
,
6002 struct type
**field_type_p
,
6003 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
6008 type
= ada_check_typedef (type
);
6010 if (field_type_p
!= NULL
)
6011 *field_type_p
= NULL
;
6012 if (byte_offset_p
!= NULL
)
6014 if (bit_offset_p
!= NULL
)
6016 if (bit_size_p
!= NULL
)
6019 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6021 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6022 int fld_offset
= offset
+ bit_pos
/ 8;
6023 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6025 if (t_field_name
== NULL
)
6028 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
6030 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6032 if (field_type_p
!= NULL
)
6033 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6034 if (byte_offset_p
!= NULL
)
6035 *byte_offset_p
= fld_offset
;
6036 if (bit_offset_p
!= NULL
)
6037 *bit_offset_p
= bit_pos
% 8;
6038 if (bit_size_p
!= NULL
)
6039 *bit_size_p
= bit_size
;
6042 else if (ada_is_wrapper_field (type
, i
))
6044 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6045 field_type_p
, byte_offset_p
, bit_offset_p
,
6046 bit_size_p
, index_p
))
6049 else if (ada_is_variant_part (type
, i
))
6051 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6054 struct type
*field_type
6055 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6057 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6059 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
6061 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6062 field_type_p
, byte_offset_p
,
6063 bit_offset_p
, bit_size_p
, index_p
))
6067 else if (index_p
!= NULL
)
6073 /* Number of user-visible fields in record type TYPE. */
6076 num_visible_fields (struct type
*type
)
6081 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
6085 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6086 and search in it assuming it has (class) type TYPE.
6087 If found, return value, else return NULL.
6089 Searches recursively through wrapper fields (e.g., '_parent'). */
6091 static struct value
*
6092 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
6097 type
= ada_check_typedef (type
);
6098 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6100 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6102 if (t_field_name
== NULL
)
6105 else if (field_name_match (t_field_name
, name
))
6106 return ada_value_primitive_field (arg
, offset
, i
, type
);
6108 else if (ada_is_wrapper_field (type
, i
))
6110 struct value
*v
= /* Do not let indent join lines here. */
6111 ada_search_struct_field (name
, arg
,
6112 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6113 TYPE_FIELD_TYPE (type
, i
));
6119 else if (ada_is_variant_part (type
, i
))
6121 /* PNH: Do we ever get here? See find_struct_field. */
6123 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
6125 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6127 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6129 struct value
*v
= ada_search_struct_field
/* Force line break. */
6131 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6132 TYPE_FIELD_TYPE (field_type
, j
));
6142 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
6143 int, struct type
*);
6146 /* Return field #INDEX in ARG, where the index is that returned by
6147 * find_struct_field through its INDEX_P argument. Adjust the address
6148 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6149 * If found, return value, else return NULL. */
6151 static struct value
*
6152 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
6155 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
6159 /* Auxiliary function for ada_index_struct_field. Like
6160 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6163 static struct value
*
6164 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
6168 type
= ada_check_typedef (type
);
6170 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6172 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
6174 else if (ada_is_wrapper_field (type
, i
))
6176 struct value
*v
= /* Do not let indent join lines here. */
6177 ada_index_struct_field_1 (index_p
, arg
,
6178 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6179 TYPE_FIELD_TYPE (type
, i
));
6185 else if (ada_is_variant_part (type
, i
))
6187 /* PNH: Do we ever get here? See ada_search_struct_field,
6188 find_struct_field. */
6189 error (_("Cannot assign this kind of variant record"));
6191 else if (*index_p
== 0)
6192 return ada_value_primitive_field (arg
, offset
, i
, type
);
6199 /* Given ARG, a value of type (pointer or reference to a)*
6200 structure/union, extract the component named NAME from the ultimate
6201 target structure/union and return it as a value with its
6204 The routine searches for NAME among all members of the structure itself
6205 and (recursively) among all members of any wrapper members
6208 If NO_ERR, then simply return NULL in case of error, rather than
6212 ada_value_struct_elt (struct value
*arg
, char *name
, int no_err
)
6214 struct type
*t
, *t1
;
6218 t1
= t
= ada_check_typedef (value_type (arg
));
6219 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6221 t1
= TYPE_TARGET_TYPE (t
);
6224 t1
= ada_check_typedef (t1
);
6225 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6227 arg
= coerce_ref (arg
);
6232 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6234 t1
= TYPE_TARGET_TYPE (t
);
6237 t1
= ada_check_typedef (t1
);
6238 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6240 arg
= value_ind (arg
);
6247 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
6251 v
= ada_search_struct_field (name
, arg
, 0, t
);
6254 int bit_offset
, bit_size
, byte_offset
;
6255 struct type
*field_type
;
6258 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6259 address
= value_as_address (arg
);
6261 address
= unpack_pointer (t
, value_contents (arg
));
6263 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
, 1);
6264 if (find_struct_field (name
, t1
, 0,
6265 &field_type
, &byte_offset
, &bit_offset
,
6270 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6271 arg
= ada_coerce_ref (arg
);
6273 arg
= ada_value_ind (arg
);
6274 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
6275 bit_offset
, bit_size
,
6279 v
= value_at_lazy (field_type
, address
+ byte_offset
);
6283 if (v
!= NULL
|| no_err
)
6286 error (_("There is no member named %s."), name
);
6292 error (_("Attempt to extract a component of a value that is not a record."));
6295 /* Given a type TYPE, look up the type of the component of type named NAME.
6296 If DISPP is non-null, add its byte displacement from the beginning of a
6297 structure (pointed to by a value) of type TYPE to *DISPP (does not
6298 work for packed fields).
6300 Matches any field whose name has NAME as a prefix, possibly
6303 TYPE can be either a struct or union. If REFOK, TYPE may also
6304 be a (pointer or reference)+ to a struct or union, and the
6305 ultimate target type will be searched.
6307 Looks recursively into variant clauses and parent types.
6309 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6310 TYPE is not a type of the right kind. */
6312 static struct type
*
6313 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
6314 int noerr
, int *dispp
)
6321 if (refok
&& type
!= NULL
)
6324 type
= ada_check_typedef (type
);
6325 if (TYPE_CODE (type
) != TYPE_CODE_PTR
6326 && TYPE_CODE (type
) != TYPE_CODE_REF
)
6328 type
= TYPE_TARGET_TYPE (type
);
6332 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
6333 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
6339 target_terminal_ours ();
6340 gdb_flush (gdb_stdout
);
6342 error (_("Type (null) is not a structure or union type"));
6345 /* XXX: type_sprint */
6346 fprintf_unfiltered (gdb_stderr
, _("Type "));
6347 type_print (type
, "", gdb_stderr
, -1);
6348 error (_(" is not a structure or union type"));
6353 type
= to_static_fixed_type (type
);
6355 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6357 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6361 if (t_field_name
== NULL
)
6364 else if (field_name_match (t_field_name
, name
))
6367 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
6368 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6371 else if (ada_is_wrapper_field (type
, i
))
6374 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
6379 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6384 else if (ada_is_variant_part (type
, i
))
6387 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
6390 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
6392 /* FIXME pnh 2008/01/26: We check for a field that is
6393 NOT wrapped in a struct, since the compiler sometimes
6394 generates these for unchecked variant types. Revisit
6395 if the compiler changes this practice. */
6396 char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
6398 if (v_field_name
!= NULL
6399 && field_name_match (v_field_name
, name
))
6400 t
= ada_check_typedef (TYPE_FIELD_TYPE (field_type
, j
));
6402 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
6408 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6419 target_terminal_ours ();
6420 gdb_flush (gdb_stdout
);
6423 /* XXX: type_sprint */
6424 fprintf_unfiltered (gdb_stderr
, _("Type "));
6425 type_print (type
, "", gdb_stderr
, -1);
6426 error (_(" has no component named <null>"));
6430 /* XXX: type_sprint */
6431 fprintf_unfiltered (gdb_stderr
, _("Type "));
6432 type_print (type
, "", gdb_stderr
, -1);
6433 error (_(" has no component named %s"), name
);
6440 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6441 within a value of type OUTER_TYPE, return true iff VAR_TYPE
6442 represents an unchecked union (that is, the variant part of a
6443 record that is named in an Unchecked_Union pragma). */
6446 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
6448 char *discrim_name
= ada_variant_discrim_name (var_type
);
6450 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1, NULL
)
6455 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6456 within a value of type OUTER_TYPE that is stored in GDB at
6457 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6458 numbering from 0) is applicable. Returns -1 if none are. */
6461 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
6462 const gdb_byte
*outer_valaddr
)
6466 char *discrim_name
= ada_variant_discrim_name (var_type
);
6467 struct value
*outer
;
6468 struct value
*discrim
;
6469 LONGEST discrim_val
;
6471 outer
= value_from_contents_and_address (outer_type
, outer_valaddr
, 0);
6472 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
6473 if (discrim
== NULL
)
6475 discrim_val
= value_as_long (discrim
);
6478 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
6480 if (ada_is_others_clause (var_type
, i
))
6482 else if (ada_in_variant (discrim_val
, var_type
, i
))
6486 return others_clause
;
6491 /* Dynamic-Sized Records */
6493 /* Strategy: The type ostensibly attached to a value with dynamic size
6494 (i.e., a size that is not statically recorded in the debugging
6495 data) does not accurately reflect the size or layout of the value.
6496 Our strategy is to convert these values to values with accurate,
6497 conventional types that are constructed on the fly. */
6499 /* There is a subtle and tricky problem here. In general, we cannot
6500 determine the size of dynamic records without its data. However,
6501 the 'struct value' data structure, which GDB uses to represent
6502 quantities in the inferior process (the target), requires the size
6503 of the type at the time of its allocation in order to reserve space
6504 for GDB's internal copy of the data. That's why the
6505 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6506 rather than struct value*s.
6508 However, GDB's internal history variables ($1, $2, etc.) are
6509 struct value*s containing internal copies of the data that are not, in
6510 general, the same as the data at their corresponding addresses in
6511 the target. Fortunately, the types we give to these values are all
6512 conventional, fixed-size types (as per the strategy described
6513 above), so that we don't usually have to perform the
6514 'to_fixed_xxx_type' conversions to look at their values.
6515 Unfortunately, there is one exception: if one of the internal
6516 history variables is an array whose elements are unconstrained
6517 records, then we will need to create distinct fixed types for each
6518 element selected. */
6520 /* The upshot of all of this is that many routines take a (type, host
6521 address, target address) triple as arguments to represent a value.
6522 The host address, if non-null, is supposed to contain an internal
6523 copy of the relevant data; otherwise, the program is to consult the
6524 target at the target address. */
6526 /* Assuming that VAL0 represents a pointer value, the result of
6527 dereferencing it. Differs from value_ind in its treatment of
6528 dynamic-sized types. */
6531 ada_value_ind (struct value
*val0
)
6533 struct value
*val
= unwrap_value (value_ind (val0
));
6535 return ada_to_fixed_value (val
);
6538 /* The value resulting from dereferencing any "reference to"
6539 qualifiers on VAL0. */
6541 static struct value
*
6542 ada_coerce_ref (struct value
*val0
)
6544 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
6546 struct value
*val
= val0
;
6548 val
= coerce_ref (val
);
6549 val
= unwrap_value (val
);
6550 return ada_to_fixed_value (val
);
6556 /* Return OFF rounded upward if necessary to a multiple of
6557 ALIGNMENT (a power of 2). */
6560 align_value (unsigned int off
, unsigned int alignment
)
6562 return (off
+ alignment
- 1) & ~(alignment
- 1);
6565 /* Return the bit alignment required for field #F of template type TYPE. */
6568 field_alignment (struct type
*type
, int f
)
6570 const char *name
= TYPE_FIELD_NAME (type
, f
);
6574 /* The field name should never be null, unless the debugging information
6575 is somehow malformed. In this case, we assume the field does not
6576 require any alignment. */
6580 len
= strlen (name
);
6582 if (!isdigit (name
[len
- 1]))
6585 if (isdigit (name
[len
- 2]))
6586 align_offset
= len
- 2;
6588 align_offset
= len
- 1;
6590 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
6591 return TARGET_CHAR_BIT
;
6593 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
6596 /* Find a symbol named NAME. Ignores ambiguity. */
6599 ada_find_any_symbol (const char *name
)
6603 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
6604 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
6607 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
6611 /* Find a type named NAME. Ignores ambiguity. This routine will look
6612 solely for types defined by debug info, it will not search the GDB
6616 ada_find_any_type (const char *name
)
6618 struct symbol
*sym
= ada_find_any_symbol (name
);
6621 return SYMBOL_TYPE (sym
);
6626 /* Given NAME and an associated BLOCK, search all symbols for
6627 NAME suffixed with "___XR", which is the ``renaming'' symbol
6628 associated to NAME. Return this symbol if found, return
6632 ada_find_renaming_symbol (const char *name
, struct block
*block
)
6636 sym
= find_old_style_renaming_symbol (name
, block
);
6641 /* Not right yet. FIXME pnh 7/20/2007. */
6642 sym
= ada_find_any_symbol (name
);
6643 if (sym
!= NULL
&& strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR") != NULL
)
6649 static struct symbol
*
6650 find_old_style_renaming_symbol (const char *name
, struct block
*block
)
6652 const struct symbol
*function_sym
= block_linkage_function (block
);
6655 if (function_sym
!= NULL
)
6657 /* If the symbol is defined inside a function, NAME is not fully
6658 qualified. This means we need to prepend the function name
6659 as well as adding the ``___XR'' suffix to build the name of
6660 the associated renaming symbol. */
6661 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
6662 /* Function names sometimes contain suffixes used
6663 for instance to qualify nested subprograms. When building
6664 the XR type name, we need to make sure that this suffix is
6665 not included. So do not include any suffix in the function
6666 name length below. */
6667 int function_name_len
= ada_name_prefix_len (function_name
);
6668 const int rename_len
= function_name_len
+ 2 /* "__" */
6669 + strlen (name
) + 6 /* "___XR\0" */ ;
6671 /* Strip the suffix if necessary. */
6672 ada_remove_trailing_digits (function_name
, &function_name_len
);
6673 ada_remove_po_subprogram_suffix (function_name
, &function_name_len
);
6674 ada_remove_Xbn_suffix (function_name
, &function_name_len
);
6676 /* Library-level functions are a special case, as GNAT adds
6677 a ``_ada_'' prefix to the function name to avoid namespace
6678 pollution. However, the renaming symbols themselves do not
6679 have this prefix, so we need to skip this prefix if present. */
6680 if (function_name_len
> 5 /* "_ada_" */
6681 && strstr (function_name
, "_ada_") == function_name
)
6684 function_name_len
-= 5;
6687 rename
= (char *) alloca (rename_len
* sizeof (char));
6688 strncpy (rename
, function_name
, function_name_len
);
6689 xsnprintf (rename
+ function_name_len
, rename_len
- function_name_len
,
6694 const int rename_len
= strlen (name
) + 6;
6696 rename
= (char *) alloca (rename_len
* sizeof (char));
6697 xsnprintf (rename
, rename_len
* sizeof (char), "%s___XR", name
);
6700 return ada_find_any_symbol (rename
);
6703 /* Because of GNAT encoding conventions, several GDB symbols may match a
6704 given type name. If the type denoted by TYPE0 is to be preferred to
6705 that of TYPE1 for purposes of type printing, return non-zero;
6706 otherwise return 0. */
6709 ada_prefer_type (struct type
*type0
, struct type
*type1
)
6713 else if (type0
== NULL
)
6715 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
6717 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
6719 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
6721 else if (ada_is_constrained_packed_array_type (type0
))
6723 else if (ada_is_array_descriptor_type (type0
)
6724 && !ada_is_array_descriptor_type (type1
))
6728 const char *type0_name
= type_name_no_tag (type0
);
6729 const char *type1_name
= type_name_no_tag (type1
);
6731 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
6732 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
6738 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6739 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6742 ada_type_name (struct type
*type
)
6746 else if (TYPE_NAME (type
) != NULL
)
6747 return TYPE_NAME (type
);
6749 return TYPE_TAG_NAME (type
);
6752 /* Search the list of "descriptive" types associated to TYPE for a type
6753 whose name is NAME. */
6755 static struct type
*
6756 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
6758 struct type
*result
;
6760 /* If there no descriptive-type info, then there is no parallel type
6762 if (!HAVE_GNAT_AUX_INFO (type
))
6765 result
= TYPE_DESCRIPTIVE_TYPE (type
);
6766 while (result
!= NULL
)
6768 char *result_name
= ada_type_name (result
);
6770 if (result_name
== NULL
)
6772 warning (_("unexpected null name on descriptive type"));
6776 /* If the names match, stop. */
6777 if (strcmp (result_name
, name
) == 0)
6780 /* Otherwise, look at the next item on the list, if any. */
6781 if (HAVE_GNAT_AUX_INFO (result
))
6782 result
= TYPE_DESCRIPTIVE_TYPE (result
);
6787 /* If we didn't find a match, see whether this is a packed array. With
6788 older compilers, the descriptive type information is either absent or
6789 irrelevant when it comes to packed arrays so the above lookup fails.
6790 Fall back to using a parallel lookup by name in this case. */
6791 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
6792 return ada_find_any_type (name
);
6797 /* Find a parallel type to TYPE with the specified NAME, using the
6798 descriptive type taken from the debugging information, if available,
6799 and otherwise using the (slower) name-based method. */
6801 static struct type
*
6802 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
6804 struct type
*result
= NULL
;
6806 if (HAVE_GNAT_AUX_INFO (type
))
6807 result
= find_parallel_type_by_descriptive_type (type
, name
);
6809 result
= ada_find_any_type (name
);
6814 /* Same as above, but specify the name of the parallel type by appending
6815 SUFFIX to the name of TYPE. */
6818 ada_find_parallel_type (struct type
*type
, const char *suffix
)
6820 char *name
, *typename
= ada_type_name (type
);
6823 if (typename
== NULL
)
6826 len
= strlen (typename
);
6828 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
6830 strcpy (name
, typename
);
6831 strcpy (name
+ len
, suffix
);
6833 return ada_find_parallel_type_with_name (type
, name
);
6836 /* If TYPE is a variable-size record type, return the corresponding template
6837 type describing its fields. Otherwise, return NULL. */
6839 static struct type
*
6840 dynamic_template_type (struct type
*type
)
6842 type
= ada_check_typedef (type
);
6844 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
6845 || ada_type_name (type
) == NULL
)
6849 int len
= strlen (ada_type_name (type
));
6851 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
6854 return ada_find_parallel_type (type
, "___XVE");
6858 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6859 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6862 is_dynamic_field (struct type
*templ_type
, int field_num
)
6864 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
6867 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
6868 && strstr (name
, "___XVL") != NULL
;
6871 /* The index of the variant field of TYPE, or -1 if TYPE does not
6872 represent a variant record type. */
6875 variant_field_index (struct type
*type
)
6879 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6882 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6884 if (ada_is_variant_part (type
, f
))
6890 /* A record type with no fields. */
6892 static struct type
*
6893 empty_record (struct type
*template)
6895 struct type
*type
= alloc_type_copy (template);
6897 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6898 TYPE_NFIELDS (type
) = 0;
6899 TYPE_FIELDS (type
) = NULL
;
6900 INIT_CPLUS_SPECIFIC (type
);
6901 TYPE_NAME (type
) = "<empty>";
6902 TYPE_TAG_NAME (type
) = NULL
;
6903 TYPE_LENGTH (type
) = 0;
6907 /* An ordinary record type (with fixed-length fields) that describes
6908 the value of type TYPE at VALADDR or ADDRESS (see comments at
6909 the beginning of this section) VAL according to GNAT conventions.
6910 DVAL0 should describe the (portion of a) record that contains any
6911 necessary discriminants. It should be NULL if value_type (VAL) is
6912 an outer-level type (i.e., as opposed to a branch of a variant.) A
6913 variant field (unless unchecked) is replaced by a particular branch
6916 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6917 length are not statically known are discarded. As a consequence,
6918 VALADDR, ADDRESS and DVAL0 are ignored.
6920 NOTE: Limitations: For now, we assume that dynamic fields and
6921 variants occupy whole numbers of bytes. However, they need not be
6925 ada_template_to_fixed_record_type_1 (struct type
*type
,
6926 const gdb_byte
*valaddr
,
6927 CORE_ADDR address
, struct value
*dval0
,
6928 int keep_dynamic_fields
)
6930 struct value
*mark
= value_mark ();
6933 int nfields
, bit_len
;
6936 int fld_bit_len
, bit_incr
;
6939 /* Compute the number of fields in this record type that are going
6940 to be processed: unless keep_dynamic_fields, this includes only
6941 fields whose position and length are static will be processed. */
6942 if (keep_dynamic_fields
)
6943 nfields
= TYPE_NFIELDS (type
);
6947 while (nfields
< TYPE_NFIELDS (type
)
6948 && !ada_is_variant_part (type
, nfields
)
6949 && !is_dynamic_field (type
, nfields
))
6953 rtype
= alloc_type_copy (type
);
6954 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6955 INIT_CPLUS_SPECIFIC (rtype
);
6956 TYPE_NFIELDS (rtype
) = nfields
;
6957 TYPE_FIELDS (rtype
) = (struct field
*)
6958 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6959 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6960 TYPE_NAME (rtype
) = ada_type_name (type
);
6961 TYPE_TAG_NAME (rtype
) = NULL
;
6962 TYPE_FIXED_INSTANCE (rtype
) = 1;
6968 for (f
= 0; f
< nfields
; f
+= 1)
6970 off
= align_value (off
, field_alignment (type
, f
))
6971 + TYPE_FIELD_BITPOS (type
, f
);
6972 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6973 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6975 if (ada_is_variant_part (type
, f
))
6978 fld_bit_len
= bit_incr
= 0;
6980 else if (is_dynamic_field (type
, f
))
6982 const gdb_byte
*field_valaddr
= valaddr
;
6983 CORE_ADDR field_address
= address
;
6984 struct type
*field_type
=
6985 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
));
6989 /* rtype's length is computed based on the run-time
6990 value of discriminants. If the discriminants are not
6991 initialized, the type size may be completely bogus and
6992 GDB may fail to allocate a value for it. So check the
6993 size first before creating the value. */
6995 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7000 /* If the type referenced by this field is an aligner type, we need
7001 to unwrap that aligner type, because its size might not be set.
7002 Keeping the aligner type would cause us to compute the wrong
7003 size for this field, impacting the offset of the all the fields
7004 that follow this one. */
7005 if (ada_is_aligner_type (field_type
))
7007 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7009 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7010 field_address
= cond_offset_target (field_address
, field_offset
);
7011 field_type
= ada_aligned_type (field_type
);
7014 field_valaddr
= cond_offset_host (field_valaddr
,
7015 off
/ TARGET_CHAR_BIT
);
7016 field_address
= cond_offset_target (field_address
,
7017 off
/ TARGET_CHAR_BIT
);
7019 /* Get the fixed type of the field. Note that, in this case,
7020 we do not want to get the real type out of the tag: if
7021 the current field is the parent part of a tagged record,
7022 we will get the tag of the object. Clearly wrong: the real
7023 type of the parent is not the real type of the child. We
7024 would end up in an infinite loop. */
7025 field_type
= ada_get_base_type (field_type
);
7026 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7027 field_address
, dval
, 0);
7029 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
7030 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7031 bit_incr
= fld_bit_len
=
7032 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
7036 struct type
*field_type
= TYPE_FIELD_TYPE (type
, f
);
7038 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
7039 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7040 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7041 bit_incr
= fld_bit_len
=
7042 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7044 bit_incr
= fld_bit_len
=
7045 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
7047 if (off
+ fld_bit_len
> bit_len
)
7048 bit_len
= off
+ fld_bit_len
;
7050 TYPE_LENGTH (rtype
) =
7051 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7054 /* We handle the variant part, if any, at the end because of certain
7055 odd cases in which it is re-ordered so as NOT to be the last field of
7056 the record. This can happen in the presence of representation
7058 if (variant_field
>= 0)
7060 struct type
*branch_type
;
7062 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
7065 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7070 to_fixed_variant_branch_type
7071 (TYPE_FIELD_TYPE (type
, variant_field
),
7072 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7073 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7074 if (branch_type
== NULL
)
7076 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
7077 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7078 TYPE_NFIELDS (rtype
) -= 1;
7082 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7083 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7085 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
7087 if (off
+ fld_bit_len
> bit_len
)
7088 bit_len
= off
+ fld_bit_len
;
7089 TYPE_LENGTH (rtype
) =
7090 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7094 /* According to exp_dbug.ads, the size of TYPE for variable-size records
7095 should contain the alignment of that record, which should be a strictly
7096 positive value. If null or negative, then something is wrong, most
7097 probably in the debug info. In that case, we don't round up the size
7098 of the resulting type. If this record is not part of another structure,
7099 the current RTYPE length might be good enough for our purposes. */
7100 if (TYPE_LENGTH (type
) <= 0)
7102 if (TYPE_NAME (rtype
))
7103 warning (_("Invalid type size for `%s' detected: %d."),
7104 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
7106 warning (_("Invalid type size for <unnamed> detected: %d."),
7107 TYPE_LENGTH (type
));
7111 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
7112 TYPE_LENGTH (type
));
7115 value_free_to_mark (mark
);
7116 if (TYPE_LENGTH (rtype
) > varsize_limit
)
7117 error (_("record type with dynamic size is larger than varsize-limit"));
7121 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7124 static struct type
*
7125 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
7126 CORE_ADDR address
, struct value
*dval0
)
7128 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
7132 /* An ordinary record type in which ___XVL-convention fields and
7133 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7134 static approximations, containing all possible fields. Uses
7135 no runtime values. Useless for use in values, but that's OK,
7136 since the results are used only for type determinations. Works on both
7137 structs and unions. Representation note: to save space, we memorize
7138 the result of this function in the TYPE_TARGET_TYPE of the
7141 static struct type
*
7142 template_to_static_fixed_type (struct type
*type0
)
7148 if (TYPE_TARGET_TYPE (type0
) != NULL
)
7149 return TYPE_TARGET_TYPE (type0
);
7151 nfields
= TYPE_NFIELDS (type0
);
7154 for (f
= 0; f
< nfields
; f
+= 1)
7156 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
7157 struct type
*new_type
;
7159 if (is_dynamic_field (type0
, f
))
7160 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
7162 new_type
= static_unwrap_type (field_type
);
7163 if (type
== type0
&& new_type
!= field_type
)
7165 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
7166 TYPE_CODE (type
) = TYPE_CODE (type0
);
7167 INIT_CPLUS_SPECIFIC (type
);
7168 TYPE_NFIELDS (type
) = nfields
;
7169 TYPE_FIELDS (type
) = (struct field
*)
7170 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
7171 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
7172 sizeof (struct field
) * nfields
);
7173 TYPE_NAME (type
) = ada_type_name (type0
);
7174 TYPE_TAG_NAME (type
) = NULL
;
7175 TYPE_FIXED_INSTANCE (type
) = 1;
7176 TYPE_LENGTH (type
) = 0;
7178 TYPE_FIELD_TYPE (type
, f
) = new_type
;
7179 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
7184 /* Given an object of type TYPE whose contents are at VALADDR and
7185 whose address in memory is ADDRESS, returns a revision of TYPE,
7186 which should be a non-dynamic-sized record, in which the variant
7187 part, if any, is replaced with the appropriate branch. Looks
7188 for discriminant values in DVAL0, which can be NULL if the record
7189 contains the necessary discriminant values. */
7191 static struct type
*
7192 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
7193 CORE_ADDR address
, struct value
*dval0
)
7195 struct value
*mark
= value_mark ();
7198 struct type
*branch_type
;
7199 int nfields
= TYPE_NFIELDS (type
);
7200 int variant_field
= variant_field_index (type
);
7202 if (variant_field
== -1)
7206 dval
= value_from_contents_and_address (type
, valaddr
, address
);
7210 rtype
= alloc_type_copy (type
);
7211 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7212 INIT_CPLUS_SPECIFIC (rtype
);
7213 TYPE_NFIELDS (rtype
) = nfields
;
7214 TYPE_FIELDS (rtype
) =
7215 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7216 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
7217 sizeof (struct field
) * nfields
);
7218 TYPE_NAME (rtype
) = ada_type_name (type
);
7219 TYPE_TAG_NAME (rtype
) = NULL
;
7220 TYPE_FIXED_INSTANCE (rtype
) = 1;
7221 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
7223 branch_type
= to_fixed_variant_branch_type
7224 (TYPE_FIELD_TYPE (type
, variant_field
),
7225 cond_offset_host (valaddr
,
7226 TYPE_FIELD_BITPOS (type
, variant_field
)
7228 cond_offset_target (address
,
7229 TYPE_FIELD_BITPOS (type
, variant_field
)
7230 / TARGET_CHAR_BIT
), dval
);
7231 if (branch_type
== NULL
)
7235 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
7236 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7237 TYPE_NFIELDS (rtype
) -= 1;
7241 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7242 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7243 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
7244 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
7246 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
7248 value_free_to_mark (mark
);
7252 /* An ordinary record type (with fixed-length fields) that describes
7253 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7254 beginning of this section]. Any necessary discriminants' values
7255 should be in DVAL, a record value; it may be NULL if the object
7256 at ADDR itself contains any necessary discriminant values.
7257 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7258 values from the record are needed. Except in the case that DVAL,
7259 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7260 unchecked) is replaced by a particular branch of the variant.
7262 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7263 is questionable and may be removed. It can arise during the
7264 processing of an unconstrained-array-of-record type where all the
7265 variant branches have exactly the same size. This is because in
7266 such cases, the compiler does not bother to use the XVS convention
7267 when encoding the record. I am currently dubious of this
7268 shortcut and suspect the compiler should be altered. FIXME. */
7270 static struct type
*
7271 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
7272 CORE_ADDR address
, struct value
*dval
)
7274 struct type
*templ_type
;
7276 if (TYPE_FIXED_INSTANCE (type0
))
7279 templ_type
= dynamic_template_type (type0
);
7281 if (templ_type
!= NULL
)
7282 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
7283 else if (variant_field_index (type0
) >= 0)
7285 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
7287 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
7292 TYPE_FIXED_INSTANCE (type0
) = 1;
7298 /* An ordinary record type (with fixed-length fields) that describes
7299 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7300 union type. Any necessary discriminants' values should be in DVAL,
7301 a record value. That is, this routine selects the appropriate
7302 branch of the union at ADDR according to the discriminant value
7303 indicated in the union's type name. Returns VAR_TYPE0 itself if
7304 it represents a variant subject to a pragma Unchecked_Union. */
7306 static struct type
*
7307 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
7308 CORE_ADDR address
, struct value
*dval
)
7311 struct type
*templ_type
;
7312 struct type
*var_type
;
7314 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
7315 var_type
= TYPE_TARGET_TYPE (var_type0
);
7317 var_type
= var_type0
;
7319 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
7321 if (templ_type
!= NULL
)
7322 var_type
= templ_type
;
7324 if (is_unchecked_variant (var_type
, value_type (dval
)))
7327 ada_which_variant_applies (var_type
,
7328 value_type (dval
), value_contents (dval
));
7331 return empty_record (var_type
);
7332 else if (is_dynamic_field (var_type
, which
))
7333 return to_fixed_record_type
7334 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
7335 valaddr
, address
, dval
);
7336 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
7338 to_fixed_record_type
7339 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
7341 return TYPE_FIELD_TYPE (var_type
, which
);
7344 /* Assuming that TYPE0 is an array type describing the type of a value
7345 at ADDR, and that DVAL describes a record containing any
7346 discriminants used in TYPE0, returns a type for the value that
7347 contains no dynamic components (that is, no components whose sizes
7348 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7349 true, gives an error message if the resulting type's size is over
7352 static struct type
*
7353 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
7356 struct type
*index_type_desc
;
7357 struct type
*result
;
7358 int constrained_packed_array_p
;
7360 if (TYPE_FIXED_INSTANCE (type0
))
7363 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
7364 if (constrained_packed_array_p
)
7365 type0
= decode_constrained_packed_array_type (type0
);
7367 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
7368 ada_fixup_array_indexes_type (index_type_desc
);
7369 if (index_type_desc
== NULL
)
7371 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
7373 /* NOTE: elt_type---the fixed version of elt_type0---should never
7374 depend on the contents of the array in properly constructed
7376 /* Create a fixed version of the array element type.
7377 We're not providing the address of an element here,
7378 and thus the actual object value cannot be inspected to do
7379 the conversion. This should not be a problem, since arrays of
7380 unconstrained objects are not allowed. In particular, all
7381 the elements of an array of a tagged type should all be of
7382 the same type specified in the debugging info. No need to
7383 consult the object tag. */
7384 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
7386 /* Make sure we always create a new array type when dealing with
7387 packed array types, since we're going to fix-up the array
7388 type length and element bitsize a little further down. */
7389 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
7392 result
= create_array_type (alloc_type_copy (type0
),
7393 elt_type
, TYPE_INDEX_TYPE (type0
));
7398 struct type
*elt_type0
;
7401 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
7402 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
7404 /* NOTE: result---the fixed version of elt_type0---should never
7405 depend on the contents of the array in properly constructed
7407 /* Create a fixed version of the array element type.
7408 We're not providing the address of an element here,
7409 and thus the actual object value cannot be inspected to do
7410 the conversion. This should not be a problem, since arrays of
7411 unconstrained objects are not allowed. In particular, all
7412 the elements of an array of a tagged type should all be of
7413 the same type specified in the debugging info. No need to
7414 consult the object tag. */
7416 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
7419 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
7421 struct type
*range_type
=
7422 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, i
), dval
);
7424 result
= create_array_type (alloc_type_copy (elt_type0
),
7425 result
, range_type
);
7426 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
7428 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
7429 error (_("array type with dynamic size is larger than varsize-limit"));
7432 if (constrained_packed_array_p
)
7434 /* So far, the resulting type has been created as if the original
7435 type was a regular (non-packed) array type. As a result, the
7436 bitsize of the array elements needs to be set again, and the array
7437 length needs to be recomputed based on that bitsize. */
7438 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
7439 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
7441 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
7442 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
7443 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
7444 TYPE_LENGTH (result
)++;
7447 TYPE_FIXED_INSTANCE (result
) = 1;
7452 /* A standard type (containing no dynamically sized components)
7453 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7454 DVAL describes a record containing any discriminants used in TYPE0,
7455 and may be NULL if there are none, or if the object of type TYPE at
7456 ADDRESS or in VALADDR contains these discriminants.
7458 If CHECK_TAG is not null, in the case of tagged types, this function
7459 attempts to locate the object's tag and use it to compute the actual
7460 type. However, when ADDRESS is null, we cannot use it to determine the
7461 location of the tag, and therefore compute the tagged type's actual type.
7462 So we return the tagged type without consulting the tag. */
7464 static struct type
*
7465 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
7466 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7468 type
= ada_check_typedef (type
);
7469 switch (TYPE_CODE (type
))
7473 case TYPE_CODE_STRUCT
:
7475 struct type
*static_type
= to_static_fixed_type (type
);
7476 struct type
*fixed_record_type
=
7477 to_fixed_record_type (type
, valaddr
, address
, NULL
);
7479 /* If STATIC_TYPE is a tagged type and we know the object's address,
7480 then we can determine its tag, and compute the object's actual
7481 type from there. Note that we have to use the fixed record
7482 type (the parent part of the record may have dynamic fields
7483 and the way the location of _tag is expressed may depend on
7486 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
7488 struct type
*real_type
=
7489 type_from_tag (value_tag_from_contents_and_address
7494 if (real_type
!= NULL
)
7495 return to_fixed_record_type (real_type
, valaddr
, address
, NULL
);
7498 /* Check to see if there is a parallel ___XVZ variable.
7499 If there is, then it provides the actual size of our type. */
7500 else if (ada_type_name (fixed_record_type
) != NULL
)
7502 char *name
= ada_type_name (fixed_record_type
);
7503 char *xvz_name
= alloca (strlen (name
) + 7 /* "___XVZ\0" */);
7507 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
7508 size
= get_int_var_value (xvz_name
, &xvz_found
);
7509 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
7511 fixed_record_type
= copy_type (fixed_record_type
);
7512 TYPE_LENGTH (fixed_record_type
) = size
;
7514 /* The FIXED_RECORD_TYPE may have be a stub. We have
7515 observed this when the debugging info is STABS, and
7516 apparently it is something that is hard to fix.
7518 In practice, we don't need the actual type definition
7519 at all, because the presence of the XVZ variable allows us
7520 to assume that there must be a XVS type as well, which we
7521 should be able to use later, when we need the actual type
7524 In the meantime, pretend that the "fixed" type we are
7525 returning is NOT a stub, because this can cause trouble
7526 when using this type to create new types targeting it.
7527 Indeed, the associated creation routines often check
7528 whether the target type is a stub and will try to replace
7529 it, thus using a type with the wrong size. This, in turn,
7530 might cause the new type to have the wrong size too.
7531 Consider the case of an array, for instance, where the size
7532 of the array is computed from the number of elements in
7533 our array multiplied by the size of its element. */
7534 TYPE_STUB (fixed_record_type
) = 0;
7537 return fixed_record_type
;
7539 case TYPE_CODE_ARRAY
:
7540 return to_fixed_array_type (type
, dval
, 1);
7541 case TYPE_CODE_UNION
:
7545 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
7549 /* The same as ada_to_fixed_type_1, except that it preserves the type
7550 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7551 ada_to_fixed_type_1 would return the type referenced by TYPE. */
7554 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
7555 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7558 struct type
*fixed_type
=
7559 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
7561 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
7562 && TYPE_TARGET_TYPE (type
) == fixed_type
)
7568 /* A standard (static-sized) type corresponding as well as possible to
7569 TYPE0, but based on no runtime data. */
7571 static struct type
*
7572 to_static_fixed_type (struct type
*type0
)
7579 if (TYPE_FIXED_INSTANCE (type0
))
7582 type0
= ada_check_typedef (type0
);
7584 switch (TYPE_CODE (type0
))
7588 case TYPE_CODE_STRUCT
:
7589 type
= dynamic_template_type (type0
);
7591 return template_to_static_fixed_type (type
);
7593 return template_to_static_fixed_type (type0
);
7594 case TYPE_CODE_UNION
:
7595 type
= ada_find_parallel_type (type0
, "___XVU");
7597 return template_to_static_fixed_type (type
);
7599 return template_to_static_fixed_type (type0
);
7603 /* A static approximation of TYPE with all type wrappers removed. */
7605 static struct type
*
7606 static_unwrap_type (struct type
*type
)
7608 if (ada_is_aligner_type (type
))
7610 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
7611 if (ada_type_name (type1
) == NULL
)
7612 TYPE_NAME (type1
) = ada_type_name (type
);
7614 return static_unwrap_type (type1
);
7618 struct type
*raw_real_type
= ada_get_base_type (type
);
7620 if (raw_real_type
== type
)
7623 return to_static_fixed_type (raw_real_type
);
7627 /* In some cases, incomplete and private types require
7628 cross-references that are not resolved as records (for example,
7630 type FooP is access Foo;
7632 type Foo is array ...;
7633 ). In these cases, since there is no mechanism for producing
7634 cross-references to such types, we instead substitute for FooP a
7635 stub enumeration type that is nowhere resolved, and whose tag is
7636 the name of the actual type. Call these types "non-record stubs". */
7638 /* A type equivalent to TYPE that is not a non-record stub, if one
7639 exists, otherwise TYPE. */
7642 ada_check_typedef (struct type
*type
)
7647 CHECK_TYPEDEF (type
);
7648 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
7649 || !TYPE_STUB (type
)
7650 || TYPE_TAG_NAME (type
) == NULL
)
7654 char *name
= TYPE_TAG_NAME (type
);
7655 struct type
*type1
= ada_find_any_type (name
);
7660 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
7661 stubs pointing to arrays, as we don't create symbols for array
7662 types, only for the typedef-to-array types). This is why
7663 we process TYPE1 with ada_check_typedef before returning
7665 return ada_check_typedef (type1
);
7669 /* A value representing the data at VALADDR/ADDRESS as described by
7670 type TYPE0, but with a standard (static-sized) type that correctly
7671 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7672 type, then return VAL0 [this feature is simply to avoid redundant
7673 creation of struct values]. */
7675 static struct value
*
7676 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
7679 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
7681 if (type
== type0
&& val0
!= NULL
)
7684 return value_from_contents_and_address (type
, 0, address
);
7687 /* A value representing VAL, but with a standard (static-sized) type
7688 that correctly describes it. Does not necessarily create a new
7692 ada_to_fixed_value (struct value
*val
)
7694 return ada_to_fixed_value_create (value_type (val
),
7695 value_address (val
),
7702 /* Table mapping attribute numbers to names.
7703 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7705 static const char *attribute_names
[] = {
7723 ada_attribute_name (enum exp_opcode n
)
7725 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
7726 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
7728 return attribute_names
[0];
7731 /* Evaluate the 'POS attribute applied to ARG. */
7734 pos_atr (struct value
*arg
)
7736 struct value
*val
= coerce_ref (arg
);
7737 struct type
*type
= value_type (val
);
7739 if (!discrete_type_p (type
))
7740 error (_("'POS only defined on discrete types"));
7742 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7745 LONGEST v
= value_as_long (val
);
7747 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7749 if (v
== TYPE_FIELD_BITPOS (type
, i
))
7752 error (_("enumeration value is invalid: can't find 'POS"));
7755 return value_as_long (val
);
7758 static struct value
*
7759 value_pos_atr (struct type
*type
, struct value
*arg
)
7761 return value_from_longest (type
, pos_atr (arg
));
7764 /* Evaluate the TYPE'VAL attribute applied to ARG. */
7766 static struct value
*
7767 value_val_atr (struct type
*type
, struct value
*arg
)
7769 if (!discrete_type_p (type
))
7770 error (_("'VAL only defined on discrete types"));
7771 if (!integer_type_p (value_type (arg
)))
7772 error (_("'VAL requires integral argument"));
7774 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7776 long pos
= value_as_long (arg
);
7778 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
7779 error (_("argument to 'VAL out of range"));
7780 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
7783 return value_from_longest (type
, value_as_long (arg
));
7789 /* True if TYPE appears to be an Ada character type.
7790 [At the moment, this is true only for Character and Wide_Character;
7791 It is a heuristic test that could stand improvement]. */
7794 ada_is_character_type (struct type
*type
)
7798 /* If the type code says it's a character, then assume it really is,
7799 and don't check any further. */
7800 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
7803 /* Otherwise, assume it's a character type iff it is a discrete type
7804 with a known character type name. */
7805 name
= ada_type_name (type
);
7806 return (name
!= NULL
7807 && (TYPE_CODE (type
) == TYPE_CODE_INT
7808 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7809 && (strcmp (name
, "character") == 0
7810 || strcmp (name
, "wide_character") == 0
7811 || strcmp (name
, "wide_wide_character") == 0
7812 || strcmp (name
, "unsigned char") == 0));
7815 /* True if TYPE appears to be an Ada string type. */
7818 ada_is_string_type (struct type
*type
)
7820 type
= ada_check_typedef (type
);
7822 && TYPE_CODE (type
) != TYPE_CODE_PTR
7823 && (ada_is_simple_array_type (type
)
7824 || ada_is_array_descriptor_type (type
))
7825 && ada_array_arity (type
) == 1)
7827 struct type
*elttype
= ada_array_element_type (type
, 1);
7829 return ada_is_character_type (elttype
);
7835 /* The compiler sometimes provides a parallel XVS type for a given
7836 PAD type. Normally, it is safe to follow the PAD type directly,
7837 but older versions of the compiler have a bug that causes the offset
7838 of its "F" field to be wrong. Following that field in that case
7839 would lead to incorrect results, but this can be worked around
7840 by ignoring the PAD type and using the associated XVS type instead.
7842 Set to True if the debugger should trust the contents of PAD types.
7843 Otherwise, ignore the PAD type if there is a parallel XVS type. */
7844 static int trust_pad_over_xvs
= 1;
7846 /* True if TYPE is a struct type introduced by the compiler to force the
7847 alignment of a value. Such types have a single field with a
7848 distinctive name. */
7851 ada_is_aligner_type (struct type
*type
)
7853 type
= ada_check_typedef (type
);
7855 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
7858 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
7859 && TYPE_NFIELDS (type
) == 1
7860 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
7863 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7864 the parallel type. */
7867 ada_get_base_type (struct type
*raw_type
)
7869 struct type
*real_type_namer
;
7870 struct type
*raw_real_type
;
7872 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
7875 if (ada_is_aligner_type (raw_type
))
7876 /* The encoding specifies that we should always use the aligner type.
7877 So, even if this aligner type has an associated XVS type, we should
7880 According to the compiler gurus, an XVS type parallel to an aligner
7881 type may exist because of a stabs limitation. In stabs, aligner
7882 types are empty because the field has a variable-sized type, and
7883 thus cannot actually be used as an aligner type. As a result,
7884 we need the associated parallel XVS type to decode the type.
7885 Since the policy in the compiler is to not change the internal
7886 representation based on the debugging info format, we sometimes
7887 end up having a redundant XVS type parallel to the aligner type. */
7890 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
7891 if (real_type_namer
== NULL
7892 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
7893 || TYPE_NFIELDS (real_type_namer
) != 1)
7896 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer
, 0)) != TYPE_CODE_REF
)
7898 /* This is an older encoding form where the base type needs to be
7899 looked up by name. We prefer the newer enconding because it is
7901 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
7902 if (raw_real_type
== NULL
)
7905 return raw_real_type
;
7908 /* The field in our XVS type is a reference to the base type. */
7909 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer
, 0));
7912 /* The type of value designated by TYPE, with all aligners removed. */
7915 ada_aligned_type (struct type
*type
)
7917 if (ada_is_aligner_type (type
))
7918 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
7920 return ada_get_base_type (type
);
7924 /* The address of the aligned value in an object at address VALADDR
7925 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7928 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
7930 if (ada_is_aligner_type (type
))
7931 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
7933 TYPE_FIELD_BITPOS (type
,
7934 0) / TARGET_CHAR_BIT
);
7941 /* The printed representation of an enumeration literal with encoded
7942 name NAME. The value is good to the next call of ada_enum_name. */
7944 ada_enum_name (const char *name
)
7946 static char *result
;
7947 static size_t result_len
= 0;
7950 /* First, unqualify the enumeration name:
7951 1. Search for the last '.' character. If we find one, then skip
7952 all the preceeding characters, the unqualified name starts
7953 right after that dot.
7954 2. Otherwise, we may be debugging on a target where the compiler
7955 translates dots into "__". Search forward for double underscores,
7956 but stop searching when we hit an overloading suffix, which is
7957 of the form "__" followed by digits. */
7959 tmp
= strrchr (name
, '.');
7964 while ((tmp
= strstr (name
, "__")) != NULL
)
7966 if (isdigit (tmp
[2]))
7977 if (name
[1] == 'U' || name
[1] == 'W')
7979 if (sscanf (name
+ 2, "%x", &v
) != 1)
7985 GROW_VECT (result
, result_len
, 16);
7986 if (isascii (v
) && isprint (v
))
7987 xsnprintf (result
, result_len
, "'%c'", v
);
7988 else if (name
[1] == 'U')
7989 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
7991 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
7997 tmp
= strstr (name
, "__");
7999 tmp
= strstr (name
, "$");
8002 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
8003 strncpy (result
, name
, tmp
- name
);
8004 result
[tmp
- name
] = '\0';
8012 /* Evaluate the subexpression of EXP starting at *POS as for
8013 evaluate_type, updating *POS to point just past the evaluated
8016 static struct value
*
8017 evaluate_subexp_type (struct expression
*exp
, int *pos
)
8019 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8022 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8025 static struct value
*
8026 unwrap_value (struct value
*val
)
8028 struct type
*type
= ada_check_typedef (value_type (val
));
8030 if (ada_is_aligner_type (type
))
8032 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
8033 struct type
*val_type
= ada_check_typedef (value_type (v
));
8035 if (ada_type_name (val_type
) == NULL
)
8036 TYPE_NAME (val_type
) = ada_type_name (type
);
8038 return unwrap_value (v
);
8042 struct type
*raw_real_type
=
8043 ada_check_typedef (ada_get_base_type (type
));
8045 /* If there is no parallel XVS or XVE type, then the value is
8046 already unwrapped. Return it without further modification. */
8047 if ((type
== raw_real_type
)
8048 && ada_find_parallel_type (type
, "___XVE") == NULL
)
8052 coerce_unspec_val_to_type
8053 (val
, ada_to_fixed_type (raw_real_type
, 0,
8054 value_address (val
),
8059 static struct value
*
8060 cast_to_fixed (struct type
*type
, struct value
*arg
)
8064 if (type
== value_type (arg
))
8066 else if (ada_is_fixed_point_type (value_type (arg
)))
8067 val
= ada_float_to_fixed (type
,
8068 ada_fixed_to_float (value_type (arg
),
8069 value_as_long (arg
)));
8072 DOUBLEST argd
= value_as_double (arg
);
8074 val
= ada_float_to_fixed (type
, argd
);
8077 return value_from_longest (type
, val
);
8080 static struct value
*
8081 cast_from_fixed (struct type
*type
, struct value
*arg
)
8083 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
8084 value_as_long (arg
));
8086 return value_from_double (type
, val
);
8089 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8090 return the converted value. */
8092 static struct value
*
8093 coerce_for_assign (struct type
*type
, struct value
*val
)
8095 struct type
*type2
= value_type (val
);
8100 type2
= ada_check_typedef (type2
);
8101 type
= ada_check_typedef (type
);
8103 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
8104 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8106 val
= ada_value_ind (val
);
8107 type2
= value_type (val
);
8110 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
8111 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8113 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
8114 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
8115 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
8116 error (_("Incompatible types in assignment"));
8117 deprecated_set_value_type (val
, type
);
8122 static struct value
*
8123 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
8126 struct type
*type1
, *type2
;
8129 arg1
= coerce_ref (arg1
);
8130 arg2
= coerce_ref (arg2
);
8131 type1
= base_type (ada_check_typedef (value_type (arg1
)));
8132 type2
= base_type (ada_check_typedef (value_type (arg2
)));
8134 if (TYPE_CODE (type1
) != TYPE_CODE_INT
8135 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
8136 return value_binop (arg1
, arg2
, op
);
8145 return value_binop (arg1
, arg2
, op
);
8148 v2
= value_as_long (arg2
);
8150 error (_("second operand of %s must not be zero."), op_string (op
));
8152 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
8153 return value_binop (arg1
, arg2
, op
);
8155 v1
= value_as_long (arg1
);
8160 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
8161 v
+= v
> 0 ? -1 : 1;
8169 /* Should not reach this point. */
8173 val
= allocate_value (type1
);
8174 store_unsigned_integer (value_contents_raw (val
),
8175 TYPE_LENGTH (value_type (val
)),
8176 gdbarch_byte_order (get_type_arch (type1
)), v
);
8181 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
8183 if (ada_is_direct_array_type (value_type (arg1
))
8184 || ada_is_direct_array_type (value_type (arg2
)))
8186 /* Automatically dereference any array reference before
8187 we attempt to perform the comparison. */
8188 arg1
= ada_coerce_ref (arg1
);
8189 arg2
= ada_coerce_ref (arg2
);
8191 arg1
= ada_coerce_to_simple_array (arg1
);
8192 arg2
= ada_coerce_to_simple_array (arg2
);
8193 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
8194 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
8195 error (_("Attempt to compare array with non-array"));
8196 /* FIXME: The following works only for types whose
8197 representations use all bits (no padding or undefined bits)
8198 and do not have user-defined equality. */
8200 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
8201 && memcmp (value_contents (arg1
), value_contents (arg2
),
8202 TYPE_LENGTH (value_type (arg1
))) == 0;
8204 return value_equal (arg1
, arg2
);
8207 /* Total number of component associations in the aggregate starting at
8208 index PC in EXP. Assumes that index PC is the start of an
8212 num_component_specs (struct expression
*exp
, int pc
)
8216 m
= exp
->elts
[pc
+ 1].longconst
;
8219 for (i
= 0; i
< m
; i
+= 1)
8221 switch (exp
->elts
[pc
].opcode
)
8227 n
+= exp
->elts
[pc
+ 1].longconst
;
8230 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
8235 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
8236 component of LHS (a simple array or a record), updating *POS past
8237 the expression, assuming that LHS is contained in CONTAINER. Does
8238 not modify the inferior's memory, nor does it modify LHS (unless
8239 LHS == CONTAINER). */
8242 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
8243 struct expression
*exp
, int *pos
)
8245 struct value
*mark
= value_mark ();
8248 if (TYPE_CODE (value_type (lhs
)) == TYPE_CODE_ARRAY
)
8250 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
8251 struct value
*index_val
= value_from_longest (index_type
, index
);
8253 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
8257 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
8258 elt
= ada_to_fixed_value (unwrap_value (elt
));
8261 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8262 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
8264 value_assign_to_component (container
, elt
,
8265 ada_evaluate_subexp (NULL
, exp
, pos
,
8268 value_free_to_mark (mark
);
8271 /* Assuming that LHS represents an lvalue having a record or array
8272 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8273 of that aggregate's value to LHS, advancing *POS past the
8274 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8275 lvalue containing LHS (possibly LHS itself). Does not modify
8276 the inferior's memory, nor does it modify the contents of
8277 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
8279 static struct value
*
8280 assign_aggregate (struct value
*container
,
8281 struct value
*lhs
, struct expression
*exp
,
8282 int *pos
, enum noside noside
)
8284 struct type
*lhs_type
;
8285 int n
= exp
->elts
[*pos
+1].longconst
;
8286 LONGEST low_index
, high_index
;
8289 int max_indices
, num_indices
;
8290 int is_array_aggregate
;
8294 if (noside
!= EVAL_NORMAL
)
8298 for (i
= 0; i
< n
; i
+= 1)
8299 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
8303 container
= ada_coerce_ref (container
);
8304 if (ada_is_direct_array_type (value_type (container
)))
8305 container
= ada_coerce_to_simple_array (container
);
8306 lhs
= ada_coerce_ref (lhs
);
8307 if (!deprecated_value_modifiable (lhs
))
8308 error (_("Left operand of assignment is not a modifiable lvalue."));
8310 lhs_type
= value_type (lhs
);
8311 if (ada_is_direct_array_type (lhs_type
))
8313 lhs
= ada_coerce_to_simple_array (lhs
);
8314 lhs_type
= value_type (lhs
);
8315 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
8316 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
8317 is_array_aggregate
= 1;
8319 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
8322 high_index
= num_visible_fields (lhs_type
) - 1;
8323 is_array_aggregate
= 0;
8326 error (_("Left-hand side must be array or record."));
8328 num_specs
= num_component_specs (exp
, *pos
- 3);
8329 max_indices
= 4 * num_specs
+ 4;
8330 indices
= alloca (max_indices
* sizeof (indices
[0]));
8331 indices
[0] = indices
[1] = low_index
- 1;
8332 indices
[2] = indices
[3] = high_index
+ 1;
8335 for (i
= 0; i
< n
; i
+= 1)
8337 switch (exp
->elts
[*pos
].opcode
)
8340 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
8341 &num_indices
, max_indices
,
8342 low_index
, high_index
);
8345 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
8346 &num_indices
, max_indices
,
8347 low_index
, high_index
);
8351 error (_("Misplaced 'others' clause"));
8352 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
8353 num_indices
, low_index
, high_index
);
8356 error (_("Internal error: bad aggregate clause"));
8363 /* Assign into the component of LHS indexed by the OP_POSITIONAL
8364 construct at *POS, updating *POS past the construct, given that
8365 the positions are relative to lower bound LOW, where HIGH is the
8366 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8367 updating *NUM_INDICES as needed. CONTAINER is as for
8368 assign_aggregate. */
8370 aggregate_assign_positional (struct value
*container
,
8371 struct value
*lhs
, struct expression
*exp
,
8372 int *pos
, LONGEST
*indices
, int *num_indices
,
8373 int max_indices
, LONGEST low
, LONGEST high
)
8375 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
8377 if (ind
- 1 == high
)
8378 warning (_("Extra components in aggregate ignored."));
8381 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
8383 assign_component (container
, lhs
, ind
, exp
, pos
);
8386 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8389 /* Assign into the components of LHS indexed by the OP_CHOICES
8390 construct at *POS, updating *POS past the construct, given that
8391 the allowable indices are LOW..HIGH. Record the indices assigned
8392 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8393 needed. CONTAINER is as for assign_aggregate. */
8395 aggregate_assign_from_choices (struct value
*container
,
8396 struct value
*lhs
, struct expression
*exp
,
8397 int *pos
, LONGEST
*indices
, int *num_indices
,
8398 int max_indices
, LONGEST low
, LONGEST high
)
8401 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
8402 int choice_pos
, expr_pc
;
8403 int is_array
= ada_is_direct_array_type (value_type (lhs
));
8405 choice_pos
= *pos
+= 3;
8407 for (j
= 0; j
< n_choices
; j
+= 1)
8408 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8410 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8412 for (j
= 0; j
< n_choices
; j
+= 1)
8414 LONGEST lower
, upper
;
8415 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
8417 if (op
== OP_DISCRETE_RANGE
)
8420 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8422 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8427 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
8439 name
= &exp
->elts
[choice_pos
+ 2].string
;
8442 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
8445 error (_("Invalid record component association."));
8447 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
8449 if (! find_struct_field (name
, value_type (lhs
), 0,
8450 NULL
, NULL
, NULL
, NULL
, &ind
))
8451 error (_("Unknown component name: %s."), name
);
8452 lower
= upper
= ind
;
8455 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
8456 error (_("Index in component association out of bounds."));
8458 add_component_interval (lower
, upper
, indices
, num_indices
,
8460 while (lower
<= upper
)
8465 assign_component (container
, lhs
, lower
, exp
, &pos1
);
8471 /* Assign the value of the expression in the OP_OTHERS construct in
8472 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8473 have not been previously assigned. The index intervals already assigned
8474 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8475 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
8477 aggregate_assign_others (struct value
*container
,
8478 struct value
*lhs
, struct expression
*exp
,
8479 int *pos
, LONGEST
*indices
, int num_indices
,
8480 LONGEST low
, LONGEST high
)
8483 int expr_pc
= *pos
+1;
8485 for (i
= 0; i
< num_indices
- 2; i
+= 2)
8489 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
8494 assign_component (container
, lhs
, ind
, exp
, &pos
);
8497 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8500 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
8501 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8502 modifying *SIZE as needed. It is an error if *SIZE exceeds
8503 MAX_SIZE. The resulting intervals do not overlap. */
8505 add_component_interval (LONGEST low
, LONGEST high
,
8506 LONGEST
* indices
, int *size
, int max_size
)
8510 for (i
= 0; i
< *size
; i
+= 2) {
8511 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
8515 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
8516 if (high
< indices
[kh
])
8518 if (low
< indices
[i
])
8520 indices
[i
+ 1] = indices
[kh
- 1];
8521 if (high
> indices
[i
+ 1])
8522 indices
[i
+ 1] = high
;
8523 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
8524 *size
-= kh
- i
- 2;
8527 else if (high
< indices
[i
])
8531 if (*size
== max_size
)
8532 error (_("Internal error: miscounted aggregate components."));
8534 for (j
= *size
-1; j
>= i
+2; j
-= 1)
8535 indices
[j
] = indices
[j
- 2];
8537 indices
[i
+ 1] = high
;
8540 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8543 static struct value
*
8544 ada_value_cast (struct type
*type
, struct value
*arg2
, enum noside noside
)
8546 if (type
== ada_check_typedef (value_type (arg2
)))
8549 if (ada_is_fixed_point_type (type
))
8550 return (cast_to_fixed (type
, arg2
));
8552 if (ada_is_fixed_point_type (value_type (arg2
)))
8553 return cast_from_fixed (type
, arg2
);
8555 return value_cast (type
, arg2
);
8558 /* Evaluating Ada expressions, and printing their result.
8559 ------------------------------------------------------
8564 We usually evaluate an Ada expression in order to print its value.
8565 We also evaluate an expression in order to print its type, which
8566 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
8567 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
8568 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
8569 the evaluation compared to the EVAL_NORMAL, but is otherwise very
8572 Evaluating expressions is a little more complicated for Ada entities
8573 than it is for entities in languages such as C. The main reason for
8574 this is that Ada provides types whose definition might be dynamic.
8575 One example of such types is variant records. Or another example
8576 would be an array whose bounds can only be known at run time.
8578 The following description is a general guide as to what should be
8579 done (and what should NOT be done) in order to evaluate an expression
8580 involving such types, and when. This does not cover how the semantic
8581 information is encoded by GNAT as this is covered separatly. For the
8582 document used as the reference for the GNAT encoding, see exp_dbug.ads
8583 in the GNAT sources.
8585 Ideally, we should embed each part of this description next to its
8586 associated code. Unfortunately, the amount of code is so vast right
8587 now that it's hard to see whether the code handling a particular
8588 situation might be duplicated or not. One day, when the code is
8589 cleaned up, this guide might become redundant with the comments
8590 inserted in the code, and we might want to remove it.
8592 2. ``Fixing'' an Entity, the Simple Case:
8593 -----------------------------------------
8595 When evaluating Ada expressions, the tricky issue is that they may
8596 reference entities whose type contents and size are not statically
8597 known. Consider for instance a variant record:
8599 type Rec (Empty : Boolean := True) is record
8602 when False => Value : Integer;
8605 Yes : Rec := (Empty => False, Value => 1);
8606 No : Rec := (empty => True);
8608 The size and contents of that record depends on the value of the
8609 descriminant (Rec.Empty). At this point, neither the debugging
8610 information nor the associated type structure in GDB are able to
8611 express such dynamic types. So what the debugger does is to create
8612 "fixed" versions of the type that applies to the specific object.
8613 We also informally refer to this opperation as "fixing" an object,
8614 which means creating its associated fixed type.
8616 Example: when printing the value of variable "Yes" above, its fixed
8617 type would look like this:
8624 On the other hand, if we printed the value of "No", its fixed type
8631 Things become a little more complicated when trying to fix an entity
8632 with a dynamic type that directly contains another dynamic type,
8633 such as an array of variant records, for instance. There are
8634 two possible cases: Arrays, and records.
8636 3. ``Fixing'' Arrays:
8637 ---------------------
8639 The type structure in GDB describes an array in terms of its bounds,
8640 and the type of its elements. By design, all elements in the array
8641 have the same type and we cannot represent an array of variant elements
8642 using the current type structure in GDB. When fixing an array,
8643 we cannot fix the array element, as we would potentially need one
8644 fixed type per element of the array. As a result, the best we can do
8645 when fixing an array is to produce an array whose bounds and size
8646 are correct (allowing us to read it from memory), but without having
8647 touched its element type. Fixing each element will be done later,
8648 when (if) necessary.
8650 Arrays are a little simpler to handle than records, because the same
8651 amount of memory is allocated for each element of the array, even if
8652 the amount of space actually used by each element differs from element
8653 to element. Consider for instance the following array of type Rec:
8655 type Rec_Array is array (1 .. 2) of Rec;
8657 The actual amount of memory occupied by each element might be different
8658 from element to element, depending on the value of their discriminant.
8659 But the amount of space reserved for each element in the array remains
8660 fixed regardless. So we simply need to compute that size using
8661 the debugging information available, from which we can then determine
8662 the array size (we multiply the number of elements of the array by
8663 the size of each element).
8665 The simplest case is when we have an array of a constrained element
8666 type. For instance, consider the following type declarations:
8668 type Bounded_String (Max_Size : Integer) is
8670 Buffer : String (1 .. Max_Size);
8672 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
8674 In this case, the compiler describes the array as an array of
8675 variable-size elements (identified by its XVS suffix) for which
8676 the size can be read in the parallel XVZ variable.
8678 In the case of an array of an unconstrained element type, the compiler
8679 wraps the array element inside a private PAD type. This type should not
8680 be shown to the user, and must be "unwrap"'ed before printing. Note
8681 that we also use the adjective "aligner" in our code to designate
8682 these wrapper types.
8684 In some cases, the size allocated for each element is statically
8685 known. In that case, the PAD type already has the correct size,
8686 and the array element should remain unfixed.
8688 But there are cases when this size is not statically known.
8689 For instance, assuming that "Five" is an integer variable:
8691 type Dynamic is array (1 .. Five) of Integer;
8692 type Wrapper (Has_Length : Boolean := False) is record
8695 when True => Length : Integer;
8699 type Wrapper_Array is array (1 .. 2) of Wrapper;
8701 Hello : Wrapper_Array := (others => (Has_Length => True,
8702 Data => (others => 17),
8706 The debugging info would describe variable Hello as being an
8707 array of a PAD type. The size of that PAD type is not statically
8708 known, but can be determined using a parallel XVZ variable.
8709 In that case, a copy of the PAD type with the correct size should
8710 be used for the fixed array.
8712 3. ``Fixing'' record type objects:
8713 ----------------------------------
8715 Things are slightly different from arrays in the case of dynamic
8716 record types. In this case, in order to compute the associated
8717 fixed type, we need to determine the size and offset of each of
8718 its components. This, in turn, requires us to compute the fixed
8719 type of each of these components.
8721 Consider for instance the example:
8723 type Bounded_String (Max_Size : Natural) is record
8724 Str : String (1 .. Max_Size);
8727 My_String : Bounded_String (Max_Size => 10);
8729 In that case, the position of field "Length" depends on the size
8730 of field Str, which itself depends on the value of the Max_Size
8731 discriminant. In order to fix the type of variable My_String,
8732 we need to fix the type of field Str. Therefore, fixing a variant
8733 record requires us to fix each of its components.
8735 However, if a component does not have a dynamic size, the component
8736 should not be fixed. In particular, fields that use a PAD type
8737 should not fixed. Here is an example where this might happen
8738 (assuming type Rec above):
8740 type Container (Big : Boolean) is record
8744 when True => Another : Integer;
8748 My_Container : Container := (Big => False,
8749 First => (Empty => True),
8752 In that example, the compiler creates a PAD type for component First,
8753 whose size is constant, and then positions the component After just
8754 right after it. The offset of component After is therefore constant
8757 The debugger computes the position of each field based on an algorithm
8758 that uses, among other things, the actual position and size of the field
8759 preceding it. Let's now imagine that the user is trying to print
8760 the value of My_Container. If the type fixing was recursive, we would
8761 end up computing the offset of field After based on the size of the
8762 fixed version of field First. And since in our example First has
8763 only one actual field, the size of the fixed type is actually smaller
8764 than the amount of space allocated to that field, and thus we would
8765 compute the wrong offset of field After.
8767 To make things more complicated, we need to watch out for dynamic
8768 components of variant records (identified by the ___XVL suffix in
8769 the component name). Even if the target type is a PAD type, the size
8770 of that type might not be statically known. So the PAD type needs
8771 to be unwrapped and the resulting type needs to be fixed. Otherwise,
8772 we might end up with the wrong size for our component. This can be
8773 observed with the following type declarations:
8775 type Octal is new Integer range 0 .. 7;
8776 type Octal_Array is array (Positive range <>) of Octal;
8777 pragma Pack (Octal_Array);
8779 type Octal_Buffer (Size : Positive) is record
8780 Buffer : Octal_Array (1 .. Size);
8784 In that case, Buffer is a PAD type whose size is unset and needs
8785 to be computed by fixing the unwrapped type.
8787 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
8788 ----------------------------------------------------------
8790 Lastly, when should the sub-elements of an entity that remained unfixed
8791 thus far, be actually fixed?
8793 The answer is: Only when referencing that element. For instance
8794 when selecting one component of a record, this specific component
8795 should be fixed at that point in time. Or when printing the value
8796 of a record, each component should be fixed before its value gets
8797 printed. Similarly for arrays, the element of the array should be
8798 fixed when printing each element of the array, or when extracting
8799 one element out of that array. On the other hand, fixing should
8800 not be performed on the elements when taking a slice of an array!
8802 Note that one of the side-effects of miscomputing the offset and
8803 size of each field is that we end up also miscomputing the size
8804 of the containing type. This can have adverse results when computing
8805 the value of an entity. GDB fetches the value of an entity based
8806 on the size of its type, and thus a wrong size causes GDB to fetch
8807 the wrong amount of memory. In the case where the computed size is
8808 too small, GDB fetches too little data to print the value of our
8809 entiry. Results in this case as unpredicatble, as we usually read
8810 past the buffer containing the data =:-o. */
8812 /* Implement the evaluate_exp routine in the exp_descriptor structure
8813 for the Ada language. */
8815 static struct value
*
8816 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
8817 int *pos
, enum noside noside
)
8822 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
8825 struct value
**argvec
;
8829 op
= exp
->elts
[pc
].opcode
;
8835 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8836 arg1
= unwrap_value (arg1
);
8838 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8839 then we need to perform the conversion manually, because
8840 evaluate_subexp_standard doesn't do it. This conversion is
8841 necessary in Ada because the different kinds of float/fixed
8842 types in Ada have different representations.
8844 Similarly, we need to perform the conversion from OP_LONG
8846 if ((op
== OP_DOUBLE
|| op
== OP_LONG
) && expect_type
!= NULL
)
8847 arg1
= ada_value_cast (expect_type
, arg1
, noside
);
8853 struct value
*result
;
8856 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8857 /* The result type will have code OP_STRING, bashed there from
8858 OP_ARRAY. Bash it back. */
8859 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
8860 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
8866 type
= exp
->elts
[pc
+ 1].type
;
8867 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
8868 if (noside
== EVAL_SKIP
)
8870 arg1
= ada_value_cast (type
, arg1
, noside
);
8875 type
= exp
->elts
[pc
+ 1].type
;
8876 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
8879 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8880 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8882 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
8883 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8885 return ada_value_assign (arg1
, arg1
);
8887 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8888 except if the lhs of our assignment is a convenience variable.
8889 In the case of assigning to a convenience variable, the lhs
8890 should be exactly the result of the evaluation of the rhs. */
8891 type
= value_type (arg1
);
8892 if (VALUE_LVAL (arg1
) == lval_internalvar
)
8894 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
8895 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8897 if (ada_is_fixed_point_type (value_type (arg1
)))
8898 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
8899 else if (ada_is_fixed_point_type (value_type (arg2
)))
8901 (_("Fixed-point values must be assigned to fixed-point variables"));
8903 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
8904 return ada_value_assign (arg1
, arg2
);
8907 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8908 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8909 if (noside
== EVAL_SKIP
)
8911 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8912 return (value_from_longest
8914 value_as_long (arg1
) + value_as_long (arg2
)));
8915 if ((ada_is_fixed_point_type (value_type (arg1
))
8916 || ada_is_fixed_point_type (value_type (arg2
)))
8917 && value_type (arg1
) != value_type (arg2
))
8918 error (_("Operands of fixed-point addition must have the same type"));
8919 /* Do the addition, and cast the result to the type of the first
8920 argument. We cannot cast the result to a reference type, so if
8921 ARG1 is a reference type, find its underlying type. */
8922 type
= value_type (arg1
);
8923 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8924 type
= TYPE_TARGET_TYPE (type
);
8925 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8926 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
8929 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8930 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8931 if (noside
== EVAL_SKIP
)
8933 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8934 return (value_from_longest
8936 value_as_long (arg1
) - value_as_long (arg2
)));
8937 if ((ada_is_fixed_point_type (value_type (arg1
))
8938 || ada_is_fixed_point_type (value_type (arg2
)))
8939 && value_type (arg1
) != value_type (arg2
))
8940 error (_("Operands of fixed-point subtraction must have the same type"));
8941 /* Do the substraction, and cast the result to the type of the first
8942 argument. We cannot cast the result to a reference type, so if
8943 ARG1 is a reference type, find its underlying type. */
8944 type
= value_type (arg1
);
8945 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8946 type
= TYPE_TARGET_TYPE (type
);
8947 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8948 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
8954 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8955 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8956 if (noside
== EVAL_SKIP
)
8958 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8960 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8961 return value_zero (value_type (arg1
), not_lval
);
8965 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
8966 if (ada_is_fixed_point_type (value_type (arg1
)))
8967 arg1
= cast_from_fixed (type
, arg1
);
8968 if (ada_is_fixed_point_type (value_type (arg2
)))
8969 arg2
= cast_from_fixed (type
, arg2
);
8970 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8971 return ada_value_binop (arg1
, arg2
, op
);
8975 case BINOP_NOTEQUAL
:
8976 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8977 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
8978 if (noside
== EVAL_SKIP
)
8980 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8984 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8985 tem
= ada_value_equal (arg1
, arg2
);
8987 if (op
== BINOP_NOTEQUAL
)
8989 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8990 return value_from_longest (type
, (LONGEST
) tem
);
8993 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8994 if (noside
== EVAL_SKIP
)
8996 else if (ada_is_fixed_point_type (value_type (arg1
)))
8997 return value_cast (value_type (arg1
), value_neg (arg1
));
9000 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9001 return value_neg (arg1
);
9004 case BINOP_LOGICAL_AND
:
9005 case BINOP_LOGICAL_OR
:
9006 case UNOP_LOGICAL_NOT
:
9011 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9012 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9013 return value_cast (type
, val
);
9016 case BINOP_BITWISE_AND
:
9017 case BINOP_BITWISE_IOR
:
9018 case BINOP_BITWISE_XOR
:
9022 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9024 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9026 return value_cast (value_type (arg1
), val
);
9032 if (noside
== EVAL_SKIP
)
9037 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
9038 /* Only encountered when an unresolved symbol occurs in a
9039 context other than a function call, in which case, it is
9041 error (_("Unexpected unresolved symbol, %s, during evaluation"),
9042 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
9043 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9045 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
9046 /* Check to see if this is a tagged type. We also need to handle
9047 the case where the type is a reference to a tagged type, but
9048 we have to be careful to exclude pointers to tagged types.
9049 The latter should be shown as usual (as a pointer), whereas
9050 a reference should mostly be transparent to the user. */
9051 if (ada_is_tagged_type (type
, 0)
9052 || (TYPE_CODE(type
) == TYPE_CODE_REF
9053 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
9055 /* Tagged types are a little special in the fact that the real
9056 type is dynamic and can only be determined by inspecting the
9057 object's tag. This means that we need to get the object's
9058 value first (EVAL_NORMAL) and then extract the actual object
9061 Note that we cannot skip the final step where we extract
9062 the object type from its tag, because the EVAL_NORMAL phase
9063 results in dynamic components being resolved into fixed ones.
9064 This can cause problems when trying to print the type
9065 description of tagged types whose parent has a dynamic size:
9066 We use the type name of the "_parent" component in order
9067 to print the name of the ancestor type in the type description.
9068 If that component had a dynamic size, the resolution into
9069 a fixed type would result in the loss of that type name,
9070 thus preventing us from printing the name of the ancestor
9071 type in the type description. */
9072 struct type
*actual_type
;
9074 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
9075 actual_type
= type_from_tag (ada_value_tag (arg1
));
9076 if (actual_type
== NULL
)
9077 /* If, for some reason, we were unable to determine
9078 the actual type from the tag, then use the static
9079 approximation that we just computed as a fallback.
9080 This can happen if the debugging information is
9081 incomplete, for instance. */
9084 return value_zero (actual_type
, not_lval
);
9089 (to_static_fixed_type
9090 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
9095 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9096 arg1
= unwrap_value (arg1
);
9097 return ada_to_fixed_value (arg1
);
9103 /* Allocate arg vector, including space for the function to be
9104 called in argvec[0] and a terminating NULL. */
9105 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9107 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
9109 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
9110 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
9111 error (_("Unexpected unresolved symbol, %s, during evaluation"),
9112 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
9115 for (tem
= 0; tem
<= nargs
; tem
+= 1)
9116 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9119 if (noside
== EVAL_SKIP
)
9123 if (ada_is_constrained_packed_array_type
9124 (desc_base_type (value_type (argvec
[0]))))
9125 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
9126 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
9127 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
9128 /* This is a packed array that has already been fixed, and
9129 therefore already coerced to a simple array. Nothing further
9132 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
9133 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
9134 && VALUE_LVAL (argvec
[0]) == lval_memory
))
9135 argvec
[0] = value_addr (argvec
[0]);
9137 type
= ada_check_typedef (value_type (argvec
[0]));
9138 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
9140 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
9142 case TYPE_CODE_FUNC
:
9143 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
9145 case TYPE_CODE_ARRAY
:
9147 case TYPE_CODE_STRUCT
:
9148 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
9149 argvec
[0] = ada_value_ind (argvec
[0]);
9150 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
9153 error (_("cannot subscript or call something of type `%s'"),
9154 ada_type_name (value_type (argvec
[0])));
9159 switch (TYPE_CODE (type
))
9161 case TYPE_CODE_FUNC
:
9162 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9163 return allocate_value (TYPE_TARGET_TYPE (type
));
9164 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
9165 case TYPE_CODE_STRUCT
:
9169 arity
= ada_array_arity (type
);
9170 type
= ada_array_element_type (type
, nargs
);
9172 error (_("cannot subscript or call a record"));
9174 error (_("wrong number of subscripts; expecting %d"), arity
);
9175 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9176 return value_zero (ada_aligned_type (type
), lval_memory
);
9178 unwrap_value (ada_value_subscript
9179 (argvec
[0], nargs
, argvec
+ 1));
9181 case TYPE_CODE_ARRAY
:
9182 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9184 type
= ada_array_element_type (type
, nargs
);
9186 error (_("element type of array unknown"));
9188 return value_zero (ada_aligned_type (type
), lval_memory
);
9191 unwrap_value (ada_value_subscript
9192 (ada_coerce_to_simple_array (argvec
[0]),
9193 nargs
, argvec
+ 1));
9194 case TYPE_CODE_PTR
: /* Pointer to array */
9195 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
9196 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9198 type
= ada_array_element_type (type
, nargs
);
9200 error (_("element type of array unknown"));
9202 return value_zero (ada_aligned_type (type
), lval_memory
);
9205 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
9206 nargs
, argvec
+ 1));
9209 error (_("Attempt to index or call something other than an "
9210 "array or function"));
9215 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9216 struct value
*low_bound_val
=
9217 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9218 struct value
*high_bound_val
=
9219 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9223 low_bound_val
= coerce_ref (low_bound_val
);
9224 high_bound_val
= coerce_ref (high_bound_val
);
9225 low_bound
= pos_atr (low_bound_val
);
9226 high_bound
= pos_atr (high_bound_val
);
9228 if (noside
== EVAL_SKIP
)
9231 /* If this is a reference to an aligner type, then remove all
9233 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
9234 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
9235 TYPE_TARGET_TYPE (value_type (array
)) =
9236 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
9238 if (ada_is_constrained_packed_array_type (value_type (array
)))
9239 error (_("cannot slice a packed array"));
9241 /* If this is a reference to an array or an array lvalue,
9242 convert to a pointer. */
9243 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
9244 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
9245 && VALUE_LVAL (array
) == lval_memory
))
9246 array
= value_addr (array
);
9248 if (noside
== EVAL_AVOID_SIDE_EFFECTS
9249 && ada_is_array_descriptor_type (ada_check_typedef
9250 (value_type (array
))))
9251 return empty_array (ada_type_of_array (array
, 0), low_bound
);
9253 array
= ada_coerce_to_simple_array_ptr (array
);
9255 /* If we have more than one level of pointer indirection,
9256 dereference the value until we get only one level. */
9257 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
9258 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
9260 array
= value_ind (array
);
9262 /* Make sure we really do have an array type before going further,
9263 to avoid a SEGV when trying to get the index type or the target
9264 type later down the road if the debug info generated by
9265 the compiler is incorrect or incomplete. */
9266 if (!ada_is_simple_array_type (value_type (array
)))
9267 error (_("cannot take slice of non-array"));
9269 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
9271 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
9272 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
9276 struct type
*arr_type0
=
9277 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
9280 return ada_value_slice_from_ptr (array
, arr_type0
,
9281 longest_to_int (low_bound
),
9282 longest_to_int (high_bound
));
9285 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9287 else if (high_bound
< low_bound
)
9288 return empty_array (value_type (array
), low_bound
);
9290 return ada_value_slice (array
, longest_to_int (low_bound
),
9291 longest_to_int (high_bound
));
9296 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9297 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
9299 if (noside
== EVAL_SKIP
)
9302 switch (TYPE_CODE (type
))
9305 lim_warning (_("Membership test incompletely implemented; "
9306 "always returns true"));
9307 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9308 return value_from_longest (type
, (LONGEST
) 1);
9310 case TYPE_CODE_RANGE
:
9311 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
9312 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
9313 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9314 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
9315 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9317 value_from_longest (type
,
9318 (value_less (arg1
, arg3
)
9319 || value_equal (arg1
, arg3
))
9320 && (value_less (arg2
, arg1
)
9321 || value_equal (arg2
, arg1
)));
9324 case BINOP_IN_BOUNDS
:
9326 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9327 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9329 if (noside
== EVAL_SKIP
)
9332 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9334 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9335 return value_zero (type
, not_lval
);
9338 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9340 type
= ada_index_type (value_type (arg2
), tem
, "range");
9342 type
= value_type (arg1
);
9344 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
9345 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
9347 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9348 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
9349 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9351 value_from_longest (type
,
9352 (value_less (arg1
, arg3
)
9353 || value_equal (arg1
, arg3
))
9354 && (value_less (arg2
, arg1
)
9355 || value_equal (arg2
, arg1
)));
9357 case TERNOP_IN_RANGE
:
9358 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9359 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9360 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9362 if (noside
== EVAL_SKIP
)
9365 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9366 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
9367 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
9369 value_from_longest (type
,
9370 (value_less (arg1
, arg3
)
9371 || value_equal (arg1
, arg3
))
9372 && (value_less (arg2
, arg1
)
9373 || value_equal (arg2
, arg1
)));
9379 struct type
*type_arg
;
9381 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
9383 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9385 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
9389 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9393 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
9394 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
9395 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
9398 if (noside
== EVAL_SKIP
)
9401 if (type_arg
== NULL
)
9403 arg1
= ada_coerce_ref (arg1
);
9405 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
9406 arg1
= ada_coerce_to_simple_array (arg1
);
9408 type
= ada_index_type (value_type (arg1
), tem
,
9409 ada_attribute_name (op
));
9411 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9413 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9414 return allocate_value (type
);
9418 default: /* Should never happen. */
9419 error (_("unexpected attribute encountered"));
9421 return value_from_longest
9422 (type
, ada_array_bound (arg1
, tem
, 0));
9424 return value_from_longest
9425 (type
, ada_array_bound (arg1
, tem
, 1));
9427 return value_from_longest
9428 (type
, ada_array_length (arg1
, tem
));
9431 else if (discrete_type_p (type_arg
))
9433 struct type
*range_type
;
9434 char *name
= ada_type_name (type_arg
);
9437 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
9438 range_type
= to_fixed_range_type (type_arg
, NULL
);
9439 if (range_type
== NULL
)
9440 range_type
= type_arg
;
9444 error (_("unexpected attribute encountered"));
9446 return value_from_longest
9447 (range_type
, ada_discrete_type_low_bound (range_type
));
9449 return value_from_longest
9450 (range_type
, ada_discrete_type_high_bound (range_type
));
9452 error (_("the 'length attribute applies only to array types"));
9455 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
9456 error (_("unimplemented type attribute"));
9461 if (ada_is_constrained_packed_array_type (type_arg
))
9462 type_arg
= decode_constrained_packed_array_type (type_arg
);
9464 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
9466 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9468 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9469 return allocate_value (type
);
9474 error (_("unexpected attribute encountered"));
9476 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
9477 return value_from_longest (type
, low
);
9479 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
9480 return value_from_longest (type
, high
);
9482 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
9483 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
9484 return value_from_longest (type
, high
- low
+ 1);
9490 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9491 if (noside
== EVAL_SKIP
)
9494 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9495 return value_zero (ada_tag_type (arg1
), not_lval
);
9497 return ada_value_tag (arg1
);
9501 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9502 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9503 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9504 if (noside
== EVAL_SKIP
)
9506 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9507 return value_zero (value_type (arg1
), not_lval
);
9510 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9511 return value_binop (arg1
, arg2
,
9512 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
9515 case OP_ATR_MODULUS
:
9517 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
9519 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9520 if (noside
== EVAL_SKIP
)
9523 if (!ada_is_modular_type (type_arg
))
9524 error (_("'modulus must be applied to modular type"));
9526 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
9527 ada_modulus (type_arg
));
9532 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9533 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9534 if (noside
== EVAL_SKIP
)
9536 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9537 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9538 return value_zero (type
, not_lval
);
9540 return value_pos_atr (type
, arg1
);
9543 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9544 type
= value_type (arg1
);
9546 /* If the argument is a reference, then dereference its type, since
9547 the user is really asking for the size of the actual object,
9548 not the size of the pointer. */
9549 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
9550 type
= TYPE_TARGET_TYPE (type
);
9552 if (noside
== EVAL_SKIP
)
9554 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9555 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
9557 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
9558 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
9561 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9562 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9563 type
= exp
->elts
[pc
+ 2].type
;
9564 if (noside
== EVAL_SKIP
)
9566 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9567 return value_zero (type
, not_lval
);
9569 return value_val_atr (type
, arg1
);
9572 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9573 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9574 if (noside
== EVAL_SKIP
)
9576 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9577 return value_zero (value_type (arg1
), not_lval
);
9580 /* For integer exponentiation operations,
9581 only promote the first argument. */
9582 if (is_integral_type (value_type (arg2
)))
9583 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9585 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9587 return value_binop (arg1
, arg2
, op
);
9591 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9592 if (noside
== EVAL_SKIP
)
9598 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9599 if (noside
== EVAL_SKIP
)
9601 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9602 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
9603 return value_neg (arg1
);
9608 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9609 if (noside
== EVAL_SKIP
)
9611 type
= ada_check_typedef (value_type (arg1
));
9612 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9614 if (ada_is_array_descriptor_type (type
))
9615 /* GDB allows dereferencing GNAT array descriptors. */
9617 struct type
*arrType
= ada_type_of_array (arg1
, 0);
9619 if (arrType
== NULL
)
9620 error (_("Attempt to dereference null array pointer."));
9621 return value_at_lazy (arrType
, 0);
9623 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
9624 || TYPE_CODE (type
) == TYPE_CODE_REF
9625 /* In C you can dereference an array to get the 1st elt. */
9626 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9628 type
= to_static_fixed_type
9630 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
9632 return value_zero (type
, lval_memory
);
9634 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9636 /* GDB allows dereferencing an int. */
9637 if (expect_type
== NULL
)
9638 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
9643 to_static_fixed_type (ada_aligned_type (expect_type
));
9644 return value_zero (expect_type
, lval_memory
);
9648 error (_("Attempt to take contents of a non-pointer value."));
9650 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
9651 type
= ada_check_typedef (value_type (arg1
));
9653 if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9654 /* GDB allows dereferencing an int. If we were given
9655 the expect_type, then use that as the target type.
9656 Otherwise, assume that the target type is an int. */
9658 if (expect_type
!= NULL
)
9659 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
9662 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
9663 (CORE_ADDR
) value_as_address (arg1
));
9666 if (ada_is_array_descriptor_type (type
))
9667 /* GDB allows dereferencing GNAT array descriptors. */
9668 return ada_coerce_to_simple_array (arg1
);
9670 return ada_value_ind (arg1
);
9672 case STRUCTOP_STRUCT
:
9673 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9674 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
9675 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9676 if (noside
== EVAL_SKIP
)
9678 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9680 struct type
*type1
= value_type (arg1
);
9682 if (ada_is_tagged_type (type1
, 1))
9684 type
= ada_lookup_struct_elt_type (type1
,
9685 &exp
->elts
[pc
+ 2].string
,
9688 /* In this case, we assume that the field COULD exist
9689 in some extension of the type. Return an object of
9690 "type" void, which will match any formal
9691 (see ada_type_match). */
9692 return value_zero (builtin_type (exp
->gdbarch
)->builtin_void
,
9697 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
9700 return value_zero (ada_aligned_type (type
), lval_memory
);
9703 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
9704 arg1
= unwrap_value (arg1
);
9705 return ada_to_fixed_value (arg1
);
9708 /* The value is not supposed to be used. This is here to make it
9709 easier to accommodate expressions that contain types. */
9711 if (noside
== EVAL_SKIP
)
9713 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9714 return allocate_value (exp
->elts
[pc
+ 1].type
);
9716 error (_("Attempt to use a type name as an expression"));
9721 case OP_DISCRETE_RANGE
:
9724 if (noside
== EVAL_NORMAL
)
9728 error (_("Undefined name, ambiguous name, or renaming used in "
9729 "component association: %s."), &exp
->elts
[pc
+2].string
);
9731 error (_("Aggregates only allowed on the right of an assignment"));
9733 internal_error (__FILE__
, __LINE__
, _("aggregate apparently mangled"));
9736 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
9738 for (tem
= 0; tem
< nargs
; tem
+= 1)
9739 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9744 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
, 1);
9750 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9751 type name that encodes the 'small and 'delta information.
9752 Otherwise, return NULL. */
9755 fixed_type_info (struct type
*type
)
9757 const char *name
= ada_type_name (type
);
9758 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
9760 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
9762 const char *tail
= strstr (name
, "___XF_");
9769 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
9770 return fixed_type_info (TYPE_TARGET_TYPE (type
));
9775 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9778 ada_is_fixed_point_type (struct type
*type
)
9780 return fixed_type_info (type
) != NULL
;
9783 /* Return non-zero iff TYPE represents a System.Address type. */
9786 ada_is_system_address_type (struct type
*type
)
9788 return (TYPE_NAME (type
)
9789 && strcmp (TYPE_NAME (type
), "system__address") == 0);
9792 /* Assuming that TYPE is the representation of an Ada fixed-point
9793 type, return its delta, or -1 if the type is malformed and the
9794 delta cannot be determined. */
9797 ada_delta (struct type
*type
)
9799 const char *encoding
= fixed_type_info (type
);
9802 /* Strictly speaking, num and den are encoded as integer. However,
9803 they may not fit into a long, and they will have to be converted
9804 to DOUBLEST anyway. So scan them as DOUBLEST. */
9805 if (sscanf (encoding
, "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
,
9812 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9813 factor ('SMALL value) associated with the type. */
9816 scaling_factor (struct type
*type
)
9818 const char *encoding
= fixed_type_info (type
);
9819 DOUBLEST num0
, den0
, num1
, den1
;
9822 /* Strictly speaking, num's and den's are encoded as integer. However,
9823 they may not fit into a long, and they will have to be converted
9824 to DOUBLEST anyway. So scan them as DOUBLEST. */
9825 n
= sscanf (encoding
,
9826 "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
9827 "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
,
9828 &num0
, &den0
, &num1
, &den1
);
9839 /* Assuming that X is the representation of a value of fixed-point
9840 type TYPE, return its floating-point equivalent. */
9843 ada_fixed_to_float (struct type
*type
, LONGEST x
)
9845 return (DOUBLEST
) x
*scaling_factor (type
);
9848 /* The representation of a fixed-point value of type TYPE
9849 corresponding to the value X. */
9852 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
9854 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
9861 /* Scan STR beginning at position K for a discriminant name, and
9862 return the value of that discriminant field of DVAL in *PX. If
9863 PNEW_K is not null, put the position of the character beyond the
9864 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9865 not alter *PX and *PNEW_K if unsuccessful. */
9868 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
9871 static char *bound_buffer
= NULL
;
9872 static size_t bound_buffer_len
= 0;
9875 struct value
*bound_val
;
9877 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9880 pend
= strstr (str
+ k
, "__");
9884 k
+= strlen (bound
);
9888 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9889 bound
= bound_buffer
;
9890 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9891 bound
[pend
- (str
+ k
)] = '\0';
9895 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
9896 if (bound_val
== NULL
)
9899 *px
= value_as_long (bound_val
);
9905 /* Value of variable named NAME in the current environment. If
9906 no such variable found, then if ERR_MSG is null, returns 0, and
9907 otherwise causes an error with message ERR_MSG. */
9909 static struct value
*
9910 get_var_value (char *name
, char *err_msg
)
9912 struct ada_symbol_info
*syms
;
9915 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9920 if (err_msg
== NULL
)
9923 error (("%s"), err_msg
);
9926 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9929 /* Value of integer variable named NAME in the current environment. If
9930 no such variable found, returns 0, and sets *FLAG to 0. If
9931 successful, sets *FLAG to 1. */
9934 get_int_var_value (char *name
, int *flag
)
9936 struct value
*var_val
= get_var_value (name
, 0);
9948 return value_as_long (var_val
);
9953 /* Return a range type whose base type is that of the range type named
9954 NAME in the current environment, and whose bounds are calculated
9955 from NAME according to the GNAT range encoding conventions.
9956 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
9957 corresponding range type from debug information; fall back to using it
9958 if symbol lookup fails. If a new type must be created, allocate it
9959 like ORIG_TYPE was. The bounds information, in general, is encoded
9960 in NAME, the base type given in the named range type. */
9962 static struct type
*
9963 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
9966 struct type
*base_type
;
9969 gdb_assert (raw_type
!= NULL
);
9970 gdb_assert (TYPE_NAME (raw_type
) != NULL
);
9972 if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9973 base_type
= TYPE_TARGET_TYPE (raw_type
);
9975 base_type
= raw_type
;
9977 name
= TYPE_NAME (raw_type
);
9978 subtype_info
= strstr (name
, "___XD");
9979 if (subtype_info
== NULL
)
9981 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
9982 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
9984 if (L
< INT_MIN
|| U
> INT_MAX
)
9987 return create_range_type (alloc_type_copy (raw_type
), raw_type
,
9988 ada_discrete_type_low_bound (raw_type
),
9989 ada_discrete_type_high_bound (raw_type
));
9993 static char *name_buf
= NULL
;
9994 static size_t name_len
= 0;
9995 int prefix_len
= subtype_info
- name
;
10001 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
10002 strncpy (name_buf
, name
, prefix_len
);
10003 name_buf
[prefix_len
] = '\0';
10006 bounds_str
= strchr (subtype_info
, '_');
10009 if (*subtype_info
== 'L')
10011 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
10012 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
10014 if (bounds_str
[n
] == '_')
10016 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
10024 strcpy (name_buf
+ prefix_len
, "___L");
10025 L
= get_int_var_value (name_buf
, &ok
);
10028 lim_warning (_("Unknown lower bound, using 1."));
10033 if (*subtype_info
== 'U')
10035 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
10036 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
10043 strcpy (name_buf
+ prefix_len
, "___U");
10044 U
= get_int_var_value (name_buf
, &ok
);
10047 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
10052 type
= create_range_type (alloc_type_copy (raw_type
), base_type
, L
, U
);
10053 TYPE_NAME (type
) = name
;
10058 /* True iff NAME is the name of a range type. */
10061 ada_is_range_type_name (const char *name
)
10063 return (name
!= NULL
&& strstr (name
, "___XD"));
10067 /* Modular types */
10069 /* True iff TYPE is an Ada modular type. */
10072 ada_is_modular_type (struct type
*type
)
10074 struct type
*subranged_type
= base_type (type
);
10076 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
10077 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
10078 && TYPE_UNSIGNED (subranged_type
));
10081 /* Try to determine the lower and upper bounds of the given modular type
10082 using the type name only. Return non-zero and set L and U as the lower
10083 and upper bounds (respectively) if successful. */
10086 ada_modulus_from_name (struct type
*type
, ULONGEST
*modulus
)
10088 char *name
= ada_type_name (type
);
10096 /* Discrete type bounds are encoded using an __XD suffix. In our case,
10097 we are looking for static bounds, which means an __XDLU suffix.
10098 Moreover, we know that the lower bound of modular types is always
10099 zero, so the actual suffix should start with "__XDLU_0__", and
10100 then be followed by the upper bound value. */
10101 suffix
= strstr (name
, "__XDLU_0__");
10102 if (suffix
== NULL
)
10105 if (!ada_scan_number (suffix
, k
, &U
, NULL
))
10108 *modulus
= (ULONGEST
) U
+ 1;
10112 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
10115 ada_modulus (struct type
*type
)
10117 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
10121 /* Ada exception catchpoint support:
10122 ---------------------------------
10124 We support 3 kinds of exception catchpoints:
10125 . catchpoints on Ada exceptions
10126 . catchpoints on unhandled Ada exceptions
10127 . catchpoints on failed assertions
10129 Exceptions raised during failed assertions, or unhandled exceptions
10130 could perfectly be caught with the general catchpoint on Ada exceptions.
10131 However, we can easily differentiate these two special cases, and having
10132 the option to distinguish these two cases from the rest can be useful
10133 to zero-in on certain situations.
10135 Exception catchpoints are a specialized form of breakpoint,
10136 since they rely on inserting breakpoints inside known routines
10137 of the GNAT runtime. The implementation therefore uses a standard
10138 breakpoint structure of the BP_BREAKPOINT type, but with its own set
10141 Support in the runtime for exception catchpoints have been changed
10142 a few times already, and these changes affect the implementation
10143 of these catchpoints. In order to be able to support several
10144 variants of the runtime, we use a sniffer that will determine
10145 the runtime variant used by the program being debugged.
10147 At this time, we do not support the use of conditions on Ada exception
10148 catchpoints. The COND and COND_STRING fields are therefore set
10149 to NULL (most of the time, see below).
10151 Conditions where EXP_STRING, COND, and COND_STRING are used:
10153 When a user specifies the name of a specific exception in the case
10154 of catchpoints on Ada exceptions, we store the name of that exception
10155 in the EXP_STRING. We then translate this request into an actual
10156 condition stored in COND_STRING, and then parse it into an expression
10159 /* The different types of catchpoints that we introduced for catching
10162 enum exception_catchpoint_kind
10164 ex_catch_exception
,
10165 ex_catch_exception_unhandled
,
10169 /* Ada's standard exceptions. */
10171 static char *standard_exc
[] = {
10172 "constraint_error",
10178 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
10180 /* A structure that describes how to support exception catchpoints
10181 for a given executable. */
10183 struct exception_support_info
10185 /* The name of the symbol to break on in order to insert
10186 a catchpoint on exceptions. */
10187 const char *catch_exception_sym
;
10189 /* The name of the symbol to break on in order to insert
10190 a catchpoint on unhandled exceptions. */
10191 const char *catch_exception_unhandled_sym
;
10193 /* The name of the symbol to break on in order to insert
10194 a catchpoint on failed assertions. */
10195 const char *catch_assert_sym
;
10197 /* Assuming that the inferior just triggered an unhandled exception
10198 catchpoint, this function is responsible for returning the address
10199 in inferior memory where the name of that exception is stored.
10200 Return zero if the address could not be computed. */
10201 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
10204 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
10205 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
10207 /* The following exception support info structure describes how to
10208 implement exception catchpoints with the latest version of the
10209 Ada runtime (as of 2007-03-06). */
10211 static const struct exception_support_info default_exception_support_info
=
10213 "__gnat_debug_raise_exception", /* catch_exception_sym */
10214 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10215 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
10216 ada_unhandled_exception_name_addr
10219 /* The following exception support info structure describes how to
10220 implement exception catchpoints with a slightly older version
10221 of the Ada runtime. */
10223 static const struct exception_support_info exception_support_info_fallback
=
10225 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
10226 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
10227 "system__assertions__raise_assert_failure", /* catch_assert_sym */
10228 ada_unhandled_exception_name_addr_from_raise
10231 /* For each executable, we sniff which exception info structure to use
10232 and cache it in the following global variable. */
10234 static const struct exception_support_info
*exception_info
= NULL
;
10236 /* Inspect the Ada runtime and determine which exception info structure
10237 should be used to provide support for exception catchpoints.
10239 This function will always set exception_info, or raise an error. */
10242 ada_exception_support_info_sniffer (void)
10244 struct symbol
*sym
;
10246 /* If the exception info is already known, then no need to recompute it. */
10247 if (exception_info
!= NULL
)
10250 /* Check the latest (default) exception support info. */
10251 sym
= standard_lookup (default_exception_support_info
.catch_exception_sym
,
10255 exception_info
= &default_exception_support_info
;
10259 /* Try our fallback exception suport info. */
10260 sym
= standard_lookup (exception_support_info_fallback
.catch_exception_sym
,
10264 exception_info
= &exception_support_info_fallback
;
10268 /* Sometimes, it is normal for us to not be able to find the routine
10269 we are looking for. This happens when the program is linked with
10270 the shared version of the GNAT runtime, and the program has not been
10271 started yet. Inform the user of these two possible causes if
10274 if (ada_update_initial_language (language_unknown
) != language_ada
)
10275 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
10277 /* If the symbol does not exist, then check that the program is
10278 already started, to make sure that shared libraries have been
10279 loaded. If it is not started, this may mean that the symbol is
10280 in a shared library. */
10282 if (ptid_get_pid (inferior_ptid
) == 0)
10283 error (_("Unable to insert catchpoint. Try to start the program first."));
10285 /* At this point, we know that we are debugging an Ada program and
10286 that the inferior has been started, but we still are not able to
10287 find the run-time symbols. That can mean that we are in
10288 configurable run time mode, or that a-except as been optimized
10289 out by the linker... In any case, at this point it is not worth
10290 supporting this feature. */
10292 error (_("Cannot insert catchpoints in this configuration."));
10295 /* An observer of "executable_changed" events.
10296 Its role is to clear certain cached values that need to be recomputed
10297 each time a new executable is loaded by GDB. */
10300 ada_executable_changed_observer (void)
10302 /* If the executable changed, then it is possible that the Ada runtime
10303 is different. So we need to invalidate the exception support info
10305 exception_info
= NULL
;
10308 /* True iff FRAME is very likely to be that of a function that is
10309 part of the runtime system. This is all very heuristic, but is
10310 intended to be used as advice as to what frames are uninteresting
10314 is_known_support_routine (struct frame_info
*frame
)
10316 struct symtab_and_line sal
;
10318 enum language func_lang
;
10321 /* If this code does not have any debugging information (no symtab),
10322 This cannot be any user code. */
10324 find_frame_sal (frame
, &sal
);
10325 if (sal
.symtab
== NULL
)
10328 /* If there is a symtab, but the associated source file cannot be
10329 located, then assume this is not user code: Selecting a frame
10330 for which we cannot display the code would not be very helpful
10331 for the user. This should also take care of case such as VxWorks
10332 where the kernel has some debugging info provided for a few units. */
10334 if (symtab_to_fullname (sal
.symtab
) == NULL
)
10337 /* Check the unit filename againt the Ada runtime file naming.
10338 We also check the name of the objfile against the name of some
10339 known system libraries that sometimes come with debugging info
10342 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
10344 re_comp (known_runtime_file_name_patterns
[i
]);
10345 if (re_exec (sal
.symtab
->filename
))
10347 if (sal
.symtab
->objfile
!= NULL
10348 && re_exec (sal
.symtab
->objfile
->name
))
10352 /* Check whether the function is a GNAT-generated entity. */
10354 find_frame_funname (frame
, &func_name
, &func_lang
, NULL
);
10355 if (func_name
== NULL
)
10358 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
10360 re_comp (known_auxiliary_function_name_patterns
[i
]);
10361 if (re_exec (func_name
))
10368 /* Find the first frame that contains debugging information and that is not
10369 part of the Ada run-time, starting from FI and moving upward. */
10372 ada_find_printable_frame (struct frame_info
*fi
)
10374 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
10376 if (!is_known_support_routine (fi
))
10385 /* Assuming that the inferior just triggered an unhandled exception
10386 catchpoint, return the address in inferior memory where the name
10387 of the exception is stored.
10389 Return zero if the address could not be computed. */
10392 ada_unhandled_exception_name_addr (void)
10394 return parse_and_eval_address ("e.full_name");
10397 /* Same as ada_unhandled_exception_name_addr, except that this function
10398 should be used when the inferior uses an older version of the runtime,
10399 where the exception name needs to be extracted from a specific frame
10400 several frames up in the callstack. */
10403 ada_unhandled_exception_name_addr_from_raise (void)
10406 struct frame_info
*fi
;
10408 /* To determine the name of this exception, we need to select
10409 the frame corresponding to RAISE_SYM_NAME. This frame is
10410 at least 3 levels up, so we simply skip the first 3 frames
10411 without checking the name of their associated function. */
10412 fi
= get_current_frame ();
10413 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
10415 fi
= get_prev_frame (fi
);
10420 enum language func_lang
;
10422 find_frame_funname (fi
, &func_name
, &func_lang
, NULL
);
10423 if (func_name
!= NULL
10424 && strcmp (func_name
, exception_info
->catch_exception_sym
) == 0)
10425 break; /* We found the frame we were looking for... */
10426 fi
= get_prev_frame (fi
);
10433 return parse_and_eval_address ("id.full_name");
10436 /* Assuming the inferior just triggered an Ada exception catchpoint
10437 (of any type), return the address in inferior memory where the name
10438 of the exception is stored, if applicable.
10440 Return zero if the address could not be computed, or if not relevant. */
10443 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex
,
10444 struct breakpoint
*b
)
10448 case ex_catch_exception
:
10449 return (parse_and_eval_address ("e.full_name"));
10452 case ex_catch_exception_unhandled
:
10453 return exception_info
->unhandled_exception_name_addr ();
10456 case ex_catch_assert
:
10457 return 0; /* Exception name is not relevant in this case. */
10461 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10465 return 0; /* Should never be reached. */
10468 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
10469 any error that ada_exception_name_addr_1 might cause to be thrown.
10470 When an error is intercepted, a warning with the error message is printed,
10471 and zero is returned. */
10474 ada_exception_name_addr (enum exception_catchpoint_kind ex
,
10475 struct breakpoint
*b
)
10477 struct gdb_exception e
;
10478 CORE_ADDR result
= 0;
10480 TRY_CATCH (e
, RETURN_MASK_ERROR
)
10482 result
= ada_exception_name_addr_1 (ex
, b
);
10487 warning (_("failed to get exception name: %s"), e
.message
);
10494 /* Implement the PRINT_IT method in the breakpoint_ops structure
10495 for all exception catchpoint kinds. */
10497 static enum print_stop_action
10498 print_it_exception (enum exception_catchpoint_kind ex
, struct breakpoint
*b
)
10500 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
10501 char exception_name
[256];
10505 read_memory (addr
, exception_name
, sizeof (exception_name
) - 1);
10506 exception_name
[sizeof (exception_name
) - 1] = '\0';
10509 ada_find_printable_frame (get_current_frame ());
10511 annotate_catchpoint (b
->number
);
10514 case ex_catch_exception
:
10516 printf_filtered (_("\nCatchpoint %d, %s at "),
10517 b
->number
, exception_name
);
10519 printf_filtered (_("\nCatchpoint %d, exception at "), b
->number
);
10521 case ex_catch_exception_unhandled
:
10523 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10524 b
->number
, exception_name
);
10526 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10529 case ex_catch_assert
:
10530 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10535 return PRINT_SRC_AND_LOC
;
10538 /* Implement the PRINT_ONE method in the breakpoint_ops structure
10539 for all exception catchpoint kinds. */
10542 print_one_exception (enum exception_catchpoint_kind ex
,
10543 struct breakpoint
*b
, struct bp_location
**last_loc
)
10545 struct value_print_options opts
;
10547 get_user_print_options (&opts
);
10548 if (opts
.addressprint
)
10550 annotate_field (4);
10551 ui_out_field_core_addr (uiout
, "addr", b
->loc
->gdbarch
, b
->loc
->address
);
10554 annotate_field (5);
10555 *last_loc
= b
->loc
;
10558 case ex_catch_exception
:
10559 if (b
->exp_string
!= NULL
)
10561 char *msg
= xstrprintf (_("`%s' Ada exception"), b
->exp_string
);
10563 ui_out_field_string (uiout
, "what", msg
);
10567 ui_out_field_string (uiout
, "what", "all Ada exceptions");
10571 case ex_catch_exception_unhandled
:
10572 ui_out_field_string (uiout
, "what", "unhandled Ada exceptions");
10575 case ex_catch_assert
:
10576 ui_out_field_string (uiout
, "what", "failed Ada assertions");
10580 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10585 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
10586 for all exception catchpoint kinds. */
10589 print_mention_exception (enum exception_catchpoint_kind ex
,
10590 struct breakpoint
*b
)
10594 case ex_catch_exception
:
10595 if (b
->exp_string
!= NULL
)
10596 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10597 b
->number
, b
->exp_string
);
10599 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b
->number
);
10603 case ex_catch_exception_unhandled
:
10604 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10608 case ex_catch_assert
:
10609 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b
->number
);
10613 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10618 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
10619 for all exception catchpoint kinds. */
10622 print_recreate_exception (enum exception_catchpoint_kind ex
,
10623 struct breakpoint
*b
, struct ui_file
*fp
)
10627 case ex_catch_exception
:
10628 fprintf_filtered (fp
, "catch exception");
10629 if (b
->exp_string
!= NULL
)
10630 fprintf_filtered (fp
, " %s", b
->exp_string
);
10633 case ex_catch_exception_unhandled
:
10634 fprintf_filtered (fp
, "catch exception unhandled");
10637 case ex_catch_assert
:
10638 fprintf_filtered (fp
, "catch assert");
10642 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10646 /* Virtual table for "catch exception" breakpoints. */
10648 static enum print_stop_action
10649 print_it_catch_exception (struct breakpoint
*b
)
10651 return print_it_exception (ex_catch_exception
, b
);
10655 print_one_catch_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
10657 print_one_exception (ex_catch_exception
, b
, last_loc
);
10661 print_mention_catch_exception (struct breakpoint
*b
)
10663 print_mention_exception (ex_catch_exception
, b
);
10667 print_recreate_catch_exception (struct breakpoint
*b
, struct ui_file
*fp
)
10669 print_recreate_exception (ex_catch_exception
, b
, fp
);
10672 static struct breakpoint_ops catch_exception_breakpoint_ops
=
10676 NULL
, /* breakpoint_hit */
10677 print_it_catch_exception
,
10678 print_one_catch_exception
,
10679 print_mention_catch_exception
,
10680 print_recreate_catch_exception
10683 /* Virtual table for "catch exception unhandled" breakpoints. */
10685 static enum print_stop_action
10686 print_it_catch_exception_unhandled (struct breakpoint
*b
)
10688 return print_it_exception (ex_catch_exception_unhandled
, b
);
10692 print_one_catch_exception_unhandled (struct breakpoint
*b
,
10693 struct bp_location
**last_loc
)
10695 print_one_exception (ex_catch_exception_unhandled
, b
, last_loc
);
10699 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
10701 print_mention_exception (ex_catch_exception_unhandled
, b
);
10705 print_recreate_catch_exception_unhandled (struct breakpoint
*b
,
10706 struct ui_file
*fp
)
10708 print_recreate_exception (ex_catch_exception_unhandled
, b
, fp
);
10711 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
= {
10714 NULL
, /* breakpoint_hit */
10715 print_it_catch_exception_unhandled
,
10716 print_one_catch_exception_unhandled
,
10717 print_mention_catch_exception_unhandled
,
10718 print_recreate_catch_exception_unhandled
10721 /* Virtual table for "catch assert" breakpoints. */
10723 static enum print_stop_action
10724 print_it_catch_assert (struct breakpoint
*b
)
10726 return print_it_exception (ex_catch_assert
, b
);
10730 print_one_catch_assert (struct breakpoint
*b
, struct bp_location
**last_loc
)
10732 print_one_exception (ex_catch_assert
, b
, last_loc
);
10736 print_mention_catch_assert (struct breakpoint
*b
)
10738 print_mention_exception (ex_catch_assert
, b
);
10742 print_recreate_catch_assert (struct breakpoint
*b
, struct ui_file
*fp
)
10744 print_recreate_exception (ex_catch_assert
, b
, fp
);
10747 static struct breakpoint_ops catch_assert_breakpoint_ops
= {
10750 NULL
, /* breakpoint_hit */
10751 print_it_catch_assert
,
10752 print_one_catch_assert
,
10753 print_mention_catch_assert
,
10754 print_recreate_catch_assert
10757 /* Return non-zero if B is an Ada exception catchpoint. */
10760 ada_exception_catchpoint_p (struct breakpoint
*b
)
10762 return (b
->ops
== &catch_exception_breakpoint_ops
10763 || b
->ops
== &catch_exception_unhandled_breakpoint_ops
10764 || b
->ops
== &catch_assert_breakpoint_ops
);
10767 /* Return a newly allocated copy of the first space-separated token
10768 in ARGSP, and then adjust ARGSP to point immediately after that
10771 Return NULL if ARGPS does not contain any more tokens. */
10774 ada_get_next_arg (char **argsp
)
10776 char *args
= *argsp
;
10780 /* Skip any leading white space. */
10782 while (isspace (*args
))
10785 if (args
[0] == '\0')
10786 return NULL
; /* No more arguments. */
10788 /* Find the end of the current argument. */
10791 while (*end
!= '\0' && !isspace (*end
))
10794 /* Adjust ARGSP to point to the start of the next argument. */
10798 /* Make a copy of the current argument and return it. */
10800 result
= xmalloc (end
- args
+ 1);
10801 strncpy (result
, args
, end
- args
);
10802 result
[end
- args
] = '\0';
10807 /* Split the arguments specified in a "catch exception" command.
10808 Set EX to the appropriate catchpoint type.
10809 Set EXP_STRING to the name of the specific exception if
10810 specified by the user. */
10813 catch_ada_exception_command_split (char *args
,
10814 enum exception_catchpoint_kind
*ex
,
10817 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
10818 char *exception_name
;
10820 exception_name
= ada_get_next_arg (&args
);
10821 make_cleanup (xfree
, exception_name
);
10823 /* Check that we do not have any more arguments. Anything else
10826 while (isspace (*args
))
10829 if (args
[0] != '\0')
10830 error (_("Junk at end of expression"));
10832 discard_cleanups (old_chain
);
10834 if (exception_name
== NULL
)
10836 /* Catch all exceptions. */
10837 *ex
= ex_catch_exception
;
10838 *exp_string
= NULL
;
10840 else if (strcmp (exception_name
, "unhandled") == 0)
10842 /* Catch unhandled exceptions. */
10843 *ex
= ex_catch_exception_unhandled
;
10844 *exp_string
= NULL
;
10848 /* Catch a specific exception. */
10849 *ex
= ex_catch_exception
;
10850 *exp_string
= exception_name
;
10854 /* Return the name of the symbol on which we should break in order to
10855 implement a catchpoint of the EX kind. */
10857 static const char *
10858 ada_exception_sym_name (enum exception_catchpoint_kind ex
)
10860 gdb_assert (exception_info
!= NULL
);
10864 case ex_catch_exception
:
10865 return (exception_info
->catch_exception_sym
);
10867 case ex_catch_exception_unhandled
:
10868 return (exception_info
->catch_exception_unhandled_sym
);
10870 case ex_catch_assert
:
10871 return (exception_info
->catch_assert_sym
);
10874 internal_error (__FILE__
, __LINE__
,
10875 _("unexpected catchpoint kind (%d)"), ex
);
10879 /* Return the breakpoint ops "virtual table" used for catchpoints
10882 static struct breakpoint_ops
*
10883 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex
)
10887 case ex_catch_exception
:
10888 return (&catch_exception_breakpoint_ops
);
10890 case ex_catch_exception_unhandled
:
10891 return (&catch_exception_unhandled_breakpoint_ops
);
10893 case ex_catch_assert
:
10894 return (&catch_assert_breakpoint_ops
);
10897 internal_error (__FILE__
, __LINE__
,
10898 _("unexpected catchpoint kind (%d)"), ex
);
10902 /* Return the condition that will be used to match the current exception
10903 being raised with the exception that the user wants to catch. This
10904 assumes that this condition is used when the inferior just triggered
10905 an exception catchpoint.
10907 The string returned is a newly allocated string that needs to be
10908 deallocated later. */
10911 ada_exception_catchpoint_cond_string (const char *exp_string
)
10915 /* The standard exceptions are a special case. They are defined in
10916 runtime units that have been compiled without debugging info; if
10917 EXP_STRING is the not-fully-qualified name of a standard
10918 exception (e.g. "constraint_error") then, during the evaluation
10919 of the condition expression, the symbol lookup on this name would
10920 *not* return this standard exception. The catchpoint condition
10921 may then be set only on user-defined exceptions which have the
10922 same not-fully-qualified name (e.g. my_package.constraint_error).
10924 To avoid this unexcepted behavior, these standard exceptions are
10925 systematically prefixed by "standard". This means that "catch
10926 exception constraint_error" is rewritten into "catch exception
10927 standard.constraint_error".
10929 If an exception named contraint_error is defined in another package of
10930 the inferior program, then the only way to specify this exception as a
10931 breakpoint condition is to use its fully-qualified named:
10932 e.g. my_package.constraint_error. */
10934 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
10936 if (strcmp (standard_exc
[i
], exp_string
) == 0)
10938 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
10942 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string
);
10945 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
10947 static struct expression
*
10948 ada_parse_catchpoint_condition (char *cond_string
,
10949 struct symtab_and_line sal
)
10951 return (parse_exp_1 (&cond_string
, block_for_pc (sal
.pc
), 0));
10954 /* Return the symtab_and_line that should be used to insert an exception
10955 catchpoint of the TYPE kind.
10957 EX_STRING should contain the name of a specific exception
10958 that the catchpoint should catch, or NULL otherwise.
10960 The idea behind all the remaining parameters is that their names match
10961 the name of certain fields in the breakpoint structure that are used to
10962 handle exception catchpoints. This function returns the value to which
10963 these fields should be set, depending on the type of catchpoint we need
10966 If COND and COND_STRING are both non-NULL, any value they might
10967 hold will be free'ed, and then replaced by newly allocated ones.
10968 These parameters are left untouched otherwise. */
10970 static struct symtab_and_line
10971 ada_exception_sal (enum exception_catchpoint_kind ex
, char *exp_string
,
10972 char **addr_string
, char **cond_string
,
10973 struct expression
**cond
, struct breakpoint_ops
**ops
)
10975 const char *sym_name
;
10976 struct symbol
*sym
;
10977 struct symtab_and_line sal
;
10979 /* First, find out which exception support info to use. */
10980 ada_exception_support_info_sniffer ();
10982 /* Then lookup the function on which we will break in order to catch
10983 the Ada exceptions requested by the user. */
10985 sym_name
= ada_exception_sym_name (ex
);
10986 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
10988 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10989 that should be compiled with debugging information. As a result, we
10990 expect to find that symbol in the symtabs. If we don't find it, then
10991 the target most likely does not support Ada exceptions, or we cannot
10992 insert exception breakpoints yet, because the GNAT runtime hasn't been
10995 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10996 in such a way that no debugging information is produced for the symbol
10997 we are looking for. In this case, we could search the minimal symbols
10998 as a fall-back mechanism. This would still be operating in degraded
10999 mode, however, as we would still be missing the debugging information
11000 that is needed in order to extract the name of the exception being
11001 raised (this name is printed in the catchpoint message, and is also
11002 used when trying to catch a specific exception). We do not handle
11003 this case for now. */
11006 error (_("Unable to break on '%s' in this configuration."), sym_name
);
11008 /* Make sure that the symbol we found corresponds to a function. */
11009 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11010 error (_("Symbol \"%s\" is not a function (class = %d)"),
11011 sym_name
, SYMBOL_CLASS (sym
));
11013 sal
= find_function_start_sal (sym
, 1);
11015 /* Set ADDR_STRING. */
11017 *addr_string
= xstrdup (sym_name
);
11019 /* Set the COND and COND_STRING (if not NULL). */
11021 if (cond_string
!= NULL
&& cond
!= NULL
)
11023 if (*cond_string
!= NULL
)
11025 xfree (*cond_string
);
11026 *cond_string
= NULL
;
11033 if (exp_string
!= NULL
)
11035 *cond_string
= ada_exception_catchpoint_cond_string (exp_string
);
11036 *cond
= ada_parse_catchpoint_condition (*cond_string
, sal
);
11041 *ops
= ada_exception_breakpoint_ops (ex
);
11046 /* Parse the arguments (ARGS) of the "catch exception" command.
11048 Set TYPE to the appropriate exception catchpoint type.
11049 If the user asked the catchpoint to catch only a specific
11050 exception, then save the exception name in ADDR_STRING.
11052 See ada_exception_sal for a description of all the remaining
11053 function arguments of this function. */
11055 struct symtab_and_line
11056 ada_decode_exception_location (char *args
, char **addr_string
,
11057 char **exp_string
, char **cond_string
,
11058 struct expression
**cond
,
11059 struct breakpoint_ops
**ops
)
11061 enum exception_catchpoint_kind ex
;
11063 catch_ada_exception_command_split (args
, &ex
, exp_string
);
11064 return ada_exception_sal (ex
, *exp_string
, addr_string
, cond_string
,
11068 struct symtab_and_line
11069 ada_decode_assert_location (char *args
, char **addr_string
,
11070 struct breakpoint_ops
**ops
)
11072 /* Check that no argument where provided at the end of the command. */
11076 while (isspace (*args
))
11079 error (_("Junk at end of arguments."));
11082 return ada_exception_sal (ex_catch_assert
, NULL
, addr_string
, NULL
, NULL
,
11087 /* Information about operators given special treatment in functions
11089 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
11091 #define ADA_OPERATORS \
11092 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
11093 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
11094 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
11095 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
11096 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
11097 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
11098 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
11099 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
11100 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
11101 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
11102 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
11103 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
11104 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
11105 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
11106 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
11107 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
11108 OP_DEFN (OP_OTHERS, 1, 1, 0) \
11109 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
11110 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
11113 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
11116 switch (exp
->elts
[pc
- 1].opcode
)
11119 operator_length_standard (exp
, pc
, oplenp
, argsp
);
11122 #define OP_DEFN(op, len, args, binop) \
11123 case op: *oplenp = len; *argsp = args; break;
11129 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
11134 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
11139 /* Implementation of the exp_descriptor method operator_check. */
11142 ada_operator_check (struct expression
*exp
, int pos
,
11143 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
11146 const union exp_element
*const elts
= exp
->elts
;
11147 struct type
*type
= NULL
;
11149 switch (elts
[pos
].opcode
)
11151 case UNOP_IN_RANGE
:
11153 type
= elts
[pos
+ 1].type
;
11157 return operator_check_standard (exp
, pos
, objfile_func
, data
);
11160 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
11162 if (type
&& TYPE_OBJFILE (type
)
11163 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
11170 ada_op_name (enum exp_opcode opcode
)
11175 return op_name_standard (opcode
);
11177 #define OP_DEFN(op, len, args, binop) case op: return #op;
11182 return "OP_AGGREGATE";
11184 return "OP_CHOICES";
11190 /* As for operator_length, but assumes PC is pointing at the first
11191 element of the operator, and gives meaningful results only for the
11192 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
11195 ada_forward_operator_length (struct expression
*exp
, int pc
,
11196 int *oplenp
, int *argsp
)
11198 switch (exp
->elts
[pc
].opcode
)
11201 *oplenp
= *argsp
= 0;
11204 #define OP_DEFN(op, len, args, binop) \
11205 case op: *oplenp = len; *argsp = args; break;
11211 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11216 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
11222 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
11224 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
11232 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
11234 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
11239 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
11243 /* Ada attributes ('Foo). */
11246 case OP_ATR_LENGTH
:
11250 case OP_ATR_MODULUS
:
11257 case UNOP_IN_RANGE
:
11259 /* XXX: gdb_sprint_host_address, type_sprint */
11260 fprintf_filtered (stream
, _("Type @"));
11261 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
11262 fprintf_filtered (stream
, " (");
11263 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
11264 fprintf_filtered (stream
, ")");
11266 case BINOP_IN_BOUNDS
:
11267 fprintf_filtered (stream
, " (%d)",
11268 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
11270 case TERNOP_IN_RANGE
:
11275 case OP_DISCRETE_RANGE
:
11276 case OP_POSITIONAL
:
11283 char *name
= &exp
->elts
[elt
+ 2].string
;
11284 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
11286 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
11291 return dump_subexp_body_standard (exp
, stream
, elt
);
11295 for (i
= 0; i
< nargs
; i
+= 1)
11296 elt
= dump_subexp (exp
, stream
, elt
);
11301 /* The Ada extension of print_subexp (q.v.). */
11304 ada_print_subexp (struct expression
*exp
, int *pos
,
11305 struct ui_file
*stream
, enum precedence prec
)
11307 int oplen
, nargs
, i
;
11309 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
11311 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
11318 print_subexp_standard (exp
, pos
, stream
, prec
);
11322 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
11325 case BINOP_IN_BOUNDS
:
11326 /* XXX: sprint_subexp */
11327 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11328 fputs_filtered (" in ", stream
);
11329 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11330 fputs_filtered ("'range", stream
);
11331 if (exp
->elts
[pc
+ 1].longconst
> 1)
11332 fprintf_filtered (stream
, "(%ld)",
11333 (long) exp
->elts
[pc
+ 1].longconst
);
11336 case TERNOP_IN_RANGE
:
11337 if (prec
>= PREC_EQUAL
)
11338 fputs_filtered ("(", stream
);
11339 /* XXX: sprint_subexp */
11340 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11341 fputs_filtered (" in ", stream
);
11342 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
11343 fputs_filtered (" .. ", stream
);
11344 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
11345 if (prec
>= PREC_EQUAL
)
11346 fputs_filtered (")", stream
);
11351 case OP_ATR_LENGTH
:
11355 case OP_ATR_MODULUS
:
11360 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
11362 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
11363 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
11367 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11368 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
11373 for (tem
= 1; tem
< nargs
; tem
+= 1)
11375 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
11376 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
11378 fputs_filtered (")", stream
);
11383 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
11384 fputs_filtered ("'(", stream
);
11385 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
11386 fputs_filtered (")", stream
);
11389 case UNOP_IN_RANGE
:
11390 /* XXX: sprint_subexp */
11391 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11392 fputs_filtered (" in ", stream
);
11393 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
11396 case OP_DISCRETE_RANGE
:
11397 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11398 fputs_filtered ("..", stream
);
11399 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11403 fputs_filtered ("others => ", stream
);
11404 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11408 for (i
= 0; i
< nargs
-1; i
+= 1)
11411 fputs_filtered ("|", stream
);
11412 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11414 fputs_filtered (" => ", stream
);
11415 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11418 case OP_POSITIONAL
:
11419 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11423 fputs_filtered ("(", stream
);
11424 for (i
= 0; i
< nargs
; i
+= 1)
11427 fputs_filtered (", ", stream
);
11428 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
11430 fputs_filtered (")", stream
);
11435 /* Table mapping opcodes into strings for printing operators
11436 and precedences of the operators. */
11438 static const struct op_print ada_op_print_tab
[] = {
11439 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
11440 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
11441 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
11442 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
11443 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
11444 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
11445 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
11446 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
11447 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
11448 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
11449 {">", BINOP_GTR
, PREC_ORDER
, 0},
11450 {"<", BINOP_LESS
, PREC_ORDER
, 0},
11451 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
11452 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
11453 {"+", BINOP_ADD
, PREC_ADD
, 0},
11454 {"-", BINOP_SUB
, PREC_ADD
, 0},
11455 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
11456 {"*", BINOP_MUL
, PREC_MUL
, 0},
11457 {"/", BINOP_DIV
, PREC_MUL
, 0},
11458 {"rem", BINOP_REM
, PREC_MUL
, 0},
11459 {"mod", BINOP_MOD
, PREC_MUL
, 0},
11460 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
11461 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
11462 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
11463 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
11464 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
11465 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
11466 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
11467 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
11468 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
11469 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
11473 enum ada_primitive_types
{
11474 ada_primitive_type_int
,
11475 ada_primitive_type_long
,
11476 ada_primitive_type_short
,
11477 ada_primitive_type_char
,
11478 ada_primitive_type_float
,
11479 ada_primitive_type_double
,
11480 ada_primitive_type_void
,
11481 ada_primitive_type_long_long
,
11482 ada_primitive_type_long_double
,
11483 ada_primitive_type_natural
,
11484 ada_primitive_type_positive
,
11485 ada_primitive_type_system_address
,
11486 nr_ada_primitive_types
11490 ada_language_arch_info (struct gdbarch
*gdbarch
,
11491 struct language_arch_info
*lai
)
11493 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
11495 lai
->primitive_type_vector
11496 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
11499 lai
->primitive_type_vector
[ada_primitive_type_int
]
11500 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
11502 lai
->primitive_type_vector
[ada_primitive_type_long
]
11503 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
11504 0, "long_integer");
11505 lai
->primitive_type_vector
[ada_primitive_type_short
]
11506 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
11507 0, "short_integer");
11508 lai
->string_char_type
11509 = lai
->primitive_type_vector
[ada_primitive_type_char
]
11510 = arch_integer_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
11511 lai
->primitive_type_vector
[ada_primitive_type_float
]
11512 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
11514 lai
->primitive_type_vector
[ada_primitive_type_double
]
11515 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
11516 "long_float", NULL
);
11517 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
11518 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
11519 0, "long_long_integer");
11520 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
11521 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
11522 "long_long_float", NULL
);
11523 lai
->primitive_type_vector
[ada_primitive_type_natural
]
11524 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
11526 lai
->primitive_type_vector
[ada_primitive_type_positive
]
11527 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
11529 lai
->primitive_type_vector
[ada_primitive_type_void
]
11530 = builtin
->builtin_void
;
11532 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
11533 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, 1, "void"));
11534 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
11535 = "system__address";
11537 lai
->bool_type_symbol
= NULL
;
11538 lai
->bool_type_default
= builtin
->builtin_bool
;
11541 /* Language vector */
11543 /* Not really used, but needed in the ada_language_defn. */
11546 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
11548 ada_emit_char (c
, type
, stream
, quoter
, 1);
11554 warnings_issued
= 0;
11555 return ada_parse ();
11558 static const struct exp_descriptor ada_exp_descriptor
= {
11560 ada_operator_length
,
11561 ada_operator_check
,
11563 ada_dump_subexp_body
,
11564 ada_evaluate_subexp
11567 const struct language_defn ada_language_defn
= {
11568 "ada", /* Language name */
11572 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
11573 that's not quite what this means. */
11575 macro_expansion_no
,
11576 &ada_exp_descriptor
,
11580 ada_printchar
, /* Print a character constant */
11581 ada_printstr
, /* Function to print string constant */
11582 emit_char
, /* Function to print single char (not used) */
11583 ada_print_type
, /* Print a type using appropriate syntax */
11584 ada_print_typedef
, /* Print a typedef using appropriate syntax */
11585 ada_val_print
, /* Print a value using appropriate syntax */
11586 ada_value_print
, /* Print a top-level value */
11587 NULL
, /* Language specific skip_trampoline */
11588 NULL
, /* name_of_this */
11589 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
11590 basic_lookup_transparent_type
, /* lookup_transparent_type */
11591 ada_la_decode
, /* Language specific symbol demangler */
11592 NULL
, /* Language specific class_name_from_physname */
11593 ada_op_print_tab
, /* expression operators for printing */
11594 0, /* c-style arrays */
11595 1, /* String lower bound */
11596 ada_get_gdb_completer_word_break_characters
,
11597 ada_make_symbol_completion_list
,
11598 ada_language_arch_info
,
11599 ada_print_array_index
,
11600 default_pass_by_reference
,
11605 /* Provide a prototype to silence -Wmissing-prototypes. */
11606 extern initialize_file_ftype _initialize_ada_language
;
11608 /* Command-list for the "set/show ada" prefix command. */
11609 static struct cmd_list_element
*set_ada_list
;
11610 static struct cmd_list_element
*show_ada_list
;
11612 /* Implement the "set ada" prefix command. */
11615 set_ada_command (char *arg
, int from_tty
)
11617 printf_unfiltered (_(\
11618 "\"set ada\" must be followed by the name of a setting.\n"));
11619 help_list (set_ada_list
, "set ada ", -1, gdb_stdout
);
11622 /* Implement the "show ada" prefix command. */
11625 show_ada_command (char *args
, int from_tty
)
11627 cmd_show_list (show_ada_list
, from_tty
, "");
11631 _initialize_ada_language (void)
11633 add_language (&ada_language_defn
);
11635 add_prefix_cmd ("ada", no_class
, set_ada_command
,
11636 _("Prefix command for changing Ada-specfic settings"),
11637 &set_ada_list
, "set ada ", 0, &setlist
);
11639 add_prefix_cmd ("ada", no_class
, show_ada_command
,
11640 _("Generic command for showing Ada-specific settings."),
11641 &show_ada_list
, "show ada ", 0, &showlist
);
11643 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
11644 &trust_pad_over_xvs
, _("\
11645 Enable or disable an optimization trusting PAD types over XVS types"), _("\
11646 Show whether an optimization trusting PAD types over XVS types is activated"),
11648 This is related to the encoding used by the GNAT compiler. The debugger\n\
11649 should normally trust the contents of PAD types, but certain older versions\n\
11650 of GNAT have a bug that sometimes causes the information in the PAD type\n\
11651 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
11652 work around this bug. It is always safe to turn this option \"off\", but\n\
11653 this incurs a slight performance penalty, so it is recommended to NOT change\n\
11654 this option to \"off\" unless necessary."),
11655 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
11657 varsize_limit
= 65536;
11659 obstack_init (&symbol_list_obstack
);
11661 decoded_names_store
= htab_create_alloc
11662 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
11663 NULL
, xcalloc
, xfree
);
11665 observer_attach_executable_changed (ada_executable_changed_observer
);
11667 /* Setup per-inferior data. */
11668 observer_attach_inferior_exit (ada_inferior_exit
);
11670 = register_inferior_data_with_cleanup (ada_inferior_data_cleanup
);