1 /* Ada language support routines for GDB, the GNU debugger.
3 Copyright (C) 1992-2014 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
24 #include "gdb_regex.h"
29 #include "expression.h"
30 #include "parser-defs.h"
37 #include "breakpoint.h"
40 #include "gdb_obstack.h"
42 #include "completer.h"
47 #include "dictionary.h"
55 #include "typeprint.h"
59 #include "mi/mi-common.h"
60 #include "arch-utils.h"
61 #include "cli/cli-utils.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 struct type
*desc_base_type (struct type
*);
73 static struct type
*desc_bounds_type (struct type
*);
75 static struct value
*desc_bounds (struct value
*);
77 static int fat_pntr_bounds_bitpos (struct type
*);
79 static int fat_pntr_bounds_bitsize (struct type
*);
81 static struct type
*desc_data_target_type (struct type
*);
83 static struct value
*desc_data (struct value
*);
85 static int fat_pntr_data_bitpos (struct type
*);
87 static int fat_pntr_data_bitsize (struct type
*);
89 static struct value
*desc_one_bound (struct value
*, int, int);
91 static int desc_bound_bitpos (struct type
*, int, int);
93 static int desc_bound_bitsize (struct type
*, int, int);
95 static struct type
*desc_index_type (struct type
*, int);
97 static int desc_arity (struct type
*);
99 static int ada_type_match (struct type
*, struct type
*, int);
101 static int ada_args_match (struct symbol
*, struct value
**, int);
103 static int full_match (const char *, const char *);
105 static struct value
*make_array_descriptor (struct type
*, struct value
*);
107 static void ada_add_block_symbols (struct obstack
*,
108 const struct block
*, const char *,
109 domain_enum
, struct objfile
*, int);
111 static int is_nonfunction (struct ada_symbol_info
*, int);
113 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
114 const struct block
*);
116 static int num_defns_collected (struct obstack
*);
118 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
120 static struct value
*resolve_subexp (struct expression
**, int *, int,
123 static void replace_operator_with_call (struct expression
**, int, int, int,
124 struct symbol
*, const struct block
*);
126 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
128 static char *ada_op_name (enum exp_opcode
);
130 static const char *ada_decoded_op_name (enum exp_opcode
);
132 static int numeric_type_p (struct type
*);
134 static int integer_type_p (struct type
*);
136 static int scalar_type_p (struct type
*);
138 static int discrete_type_p (struct type
*);
140 static enum ada_renaming_category
parse_old_style_renaming (struct type
*,
145 static struct symbol
*find_old_style_renaming_symbol (const char *,
146 const struct block
*);
148 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
151 static struct value
*evaluate_subexp_type (struct expression
*, int *);
153 static struct type
*ada_find_parallel_type_with_name (struct type
*,
156 static int is_dynamic_field (struct type
*, int);
158 static struct type
*to_fixed_variant_branch_type (struct type
*,
160 CORE_ADDR
, struct value
*);
162 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
164 static struct type
*to_fixed_range_type (struct type
*, struct value
*);
166 static struct type
*to_static_fixed_type (struct type
*);
167 static struct type
*static_unwrap_type (struct type
*type
);
169 static struct value
*unwrap_value (struct value
*);
171 static struct type
*constrained_packed_array_type (struct type
*, long *);
173 static struct type
*decode_constrained_packed_array_type (struct type
*);
175 static long decode_packed_array_bitsize (struct type
*);
177 static struct value
*decode_constrained_packed_array (struct value
*);
179 static int ada_is_packed_array_type (struct type
*);
181 static int ada_is_unconstrained_packed_array_type (struct type
*);
183 static struct value
*value_subscript_packed (struct value
*, int,
186 static void move_bits (gdb_byte
*, int, const gdb_byte
*, int, int, int);
188 static struct value
*coerce_unspec_val_to_type (struct value
*,
191 static struct value
*get_var_value (char *, char *);
193 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
195 static int equiv_types (struct type
*, struct type
*);
197 static int is_name_suffix (const char *);
199 static int advance_wild_match (const char **, const char *, int);
201 static int wild_match (const char *, const char *);
203 static struct value
*ada_coerce_ref (struct value
*);
205 static LONGEST
pos_atr (struct value
*);
207 static struct value
*value_pos_atr (struct type
*, struct value
*);
209 static struct value
*value_val_atr (struct type
*, struct value
*);
211 static struct symbol
*standard_lookup (const char *, const struct block
*,
214 static struct value
*ada_search_struct_field (char *, struct value
*, int,
217 static struct value
*ada_value_primitive_field (struct value
*, int, int,
220 static int find_struct_field (const char *, struct type
*, int,
221 struct type
**, int *, int *, int *, int *);
223 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
226 static int ada_resolve_function (struct ada_symbol_info
*, int,
227 struct value
**, int, const char *,
230 static int ada_is_direct_array_type (struct type
*);
232 static void ada_language_arch_info (struct gdbarch
*,
233 struct language_arch_info
*);
235 static void check_size (const struct type
*);
237 static struct value
*ada_index_struct_field (int, struct value
*, int,
240 static struct value
*assign_aggregate (struct value
*, struct value
*,
244 static void aggregate_assign_from_choices (struct value
*, struct value
*,
246 int *, LONGEST
*, int *,
247 int, LONGEST
, LONGEST
);
249 static void aggregate_assign_positional (struct value
*, struct value
*,
251 int *, LONGEST
*, int *, int,
255 static void aggregate_assign_others (struct value
*, struct value
*,
257 int *, LONGEST
*, int, LONGEST
, LONGEST
);
260 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
263 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
266 static void ada_forward_operator_length (struct expression
*, int, int *,
269 static struct type
*ada_find_any_type (const char *name
);
272 /* The result of a symbol lookup to be stored in our symbol cache. */
276 /* The name used to perform the lookup. */
278 /* The namespace used during the lookup. */
279 domain_enum
namespace;
280 /* The symbol returned by the lookup, or NULL if no matching symbol
283 /* The block where the symbol was found, or NULL if no matching
285 const struct block
*block
;
286 /* A pointer to the next entry with the same hash. */
287 struct cache_entry
*next
;
290 /* The Ada symbol cache, used to store the result of Ada-mode symbol
291 lookups in the course of executing the user's commands.
293 The cache is implemented using a simple, fixed-sized hash.
294 The size is fixed on the grounds that there are not likely to be
295 all that many symbols looked up during any given session, regardless
296 of the size of the symbol table. If we decide to go to a resizable
297 table, let's just use the stuff from libiberty instead. */
299 #define HASH_SIZE 1009
301 struct ada_symbol_cache
303 /* An obstack used to store the entries in our cache. */
304 struct obstack cache_space
;
306 /* The root of the hash table used to implement our symbol cache. */
307 struct cache_entry
*root
[HASH_SIZE
];
310 static void ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
);
312 /* Maximum-sized dynamic type. */
313 static unsigned int varsize_limit
;
315 /* FIXME: brobecker/2003-09-17: No longer a const because it is
316 returned by a function that does not return a const char *. */
317 static char *ada_completer_word_break_characters
=
319 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
321 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
324 /* The name of the symbol to use to get the name of the main subprogram. */
325 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
326 = "__gnat_ada_main_program_name";
328 /* Limit on the number of warnings to raise per expression evaluation. */
329 static int warning_limit
= 2;
331 /* Number of warning messages issued; reset to 0 by cleanups after
332 expression evaluation. */
333 static int warnings_issued
= 0;
335 static const char *known_runtime_file_name_patterns
[] = {
336 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
339 static const char *known_auxiliary_function_name_patterns
[] = {
340 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
343 /* Space for allocating results of ada_lookup_symbol_list. */
344 static struct obstack symbol_list_obstack
;
346 /* Maintenance-related settings for this module. */
348 static struct cmd_list_element
*maint_set_ada_cmdlist
;
349 static struct cmd_list_element
*maint_show_ada_cmdlist
;
351 /* Implement the "maintenance set ada" (prefix) command. */
354 maint_set_ada_cmd (char *args
, int from_tty
)
356 help_list (maint_set_ada_cmdlist
, "maintenance set ada ", all_commands
,
360 /* Implement the "maintenance show ada" (prefix) command. */
363 maint_show_ada_cmd (char *args
, int from_tty
)
365 cmd_show_list (maint_show_ada_cmdlist
, from_tty
, "");
368 /* The "maintenance ada set/show ignore-descriptive-type" value. */
370 static int ada_ignore_descriptive_types_p
= 0;
372 /* Inferior-specific data. */
374 /* Per-inferior data for this module. */
376 struct ada_inferior_data
378 /* The ada__tags__type_specific_data type, which is used when decoding
379 tagged types. With older versions of GNAT, this type was directly
380 accessible through a component ("tsd") in the object tag. But this
381 is no longer the case, so we cache it for each inferior. */
382 struct type
*tsd_type
;
384 /* The exception_support_info data. This data is used to determine
385 how to implement support for Ada exception catchpoints in a given
387 const struct exception_support_info
*exception_info
;
390 /* Our key to this module's inferior data. */
391 static const struct inferior_data
*ada_inferior_data
;
393 /* A cleanup routine for our inferior data. */
395 ada_inferior_data_cleanup (struct inferior
*inf
, void *arg
)
397 struct ada_inferior_data
*data
;
399 data
= inferior_data (inf
, ada_inferior_data
);
404 /* Return our inferior data for the given inferior (INF).
406 This function always returns a valid pointer to an allocated
407 ada_inferior_data structure. If INF's inferior data has not
408 been previously set, this functions creates a new one with all
409 fields set to zero, sets INF's inferior to it, and then returns
410 a pointer to that newly allocated ada_inferior_data. */
412 static struct ada_inferior_data
*
413 get_ada_inferior_data (struct inferior
*inf
)
415 struct ada_inferior_data
*data
;
417 data
= inferior_data (inf
, ada_inferior_data
);
420 data
= XCNEW (struct ada_inferior_data
);
421 set_inferior_data (inf
, ada_inferior_data
, data
);
427 /* Perform all necessary cleanups regarding our module's inferior data
428 that is required after the inferior INF just exited. */
431 ada_inferior_exit (struct inferior
*inf
)
433 ada_inferior_data_cleanup (inf
, NULL
);
434 set_inferior_data (inf
, ada_inferior_data
, NULL
);
438 /* program-space-specific data. */
440 /* This module's per-program-space data. */
441 struct ada_pspace_data
443 /* The Ada symbol cache. */
444 struct ada_symbol_cache
*sym_cache
;
447 /* Key to our per-program-space data. */
448 static const struct program_space_data
*ada_pspace_data_handle
;
450 /* Return this module's data for the given program space (PSPACE).
451 If not is found, add a zero'ed one now.
453 This function always returns a valid object. */
455 static struct ada_pspace_data
*
456 get_ada_pspace_data (struct program_space
*pspace
)
458 struct ada_pspace_data
*data
;
460 data
= program_space_data (pspace
, ada_pspace_data_handle
);
463 data
= XCNEW (struct ada_pspace_data
);
464 set_program_space_data (pspace
, ada_pspace_data_handle
, data
);
470 /* The cleanup callback for this module's per-program-space data. */
473 ada_pspace_data_cleanup (struct program_space
*pspace
, void *data
)
475 struct ada_pspace_data
*pspace_data
= data
;
477 if (pspace_data
->sym_cache
!= NULL
)
478 ada_free_symbol_cache (pspace_data
->sym_cache
);
484 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
485 all typedef layers have been peeled. Otherwise, return TYPE.
487 Normally, we really expect a typedef type to only have 1 typedef layer.
488 In other words, we really expect the target type of a typedef type to be
489 a non-typedef type. This is particularly true for Ada units, because
490 the language does not have a typedef vs not-typedef distinction.
491 In that respect, the Ada compiler has been trying to eliminate as many
492 typedef definitions in the debugging information, since they generally
493 do not bring any extra information (we still use typedef under certain
494 circumstances related mostly to the GNAT encoding).
496 Unfortunately, we have seen situations where the debugging information
497 generated by the compiler leads to such multiple typedef layers. For
498 instance, consider the following example with stabs:
500 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
501 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
503 This is an error in the debugging information which causes type
504 pck__float_array___XUP to be defined twice, and the second time,
505 it is defined as a typedef of a typedef.
507 This is on the fringe of legality as far as debugging information is
508 concerned, and certainly unexpected. But it is easy to handle these
509 situations correctly, so we can afford to be lenient in this case. */
512 ada_typedef_target_type (struct type
*type
)
514 while (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
515 type
= TYPE_TARGET_TYPE (type
);
519 /* Given DECODED_NAME a string holding a symbol name in its
520 decoded form (ie using the Ada dotted notation), returns
521 its unqualified name. */
524 ada_unqualified_name (const char *decoded_name
)
526 const char *result
= strrchr (decoded_name
, '.');
529 result
++; /* Skip the dot... */
531 result
= decoded_name
;
536 /* Return a string starting with '<', followed by STR, and '>'.
537 The result is good until the next call. */
540 add_angle_brackets (const char *str
)
542 static char *result
= NULL
;
545 result
= xstrprintf ("<%s>", str
);
550 ada_get_gdb_completer_word_break_characters (void)
552 return ada_completer_word_break_characters
;
555 /* Print an array element index using the Ada syntax. */
558 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
559 const struct value_print_options
*options
)
561 LA_VALUE_PRINT (index_value
, stream
, options
);
562 fprintf_filtered (stream
, " => ");
565 /* Assuming VECT points to an array of *SIZE objects of size
566 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
567 updating *SIZE as necessary and returning the (new) array. */
570 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
572 if (*size
< min_size
)
575 if (*size
< min_size
)
577 vect
= xrealloc (vect
, *size
* element_size
);
582 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
583 suffix of FIELD_NAME beginning "___". */
586 field_name_match (const char *field_name
, const char *target
)
588 int len
= strlen (target
);
591 (strncmp (field_name
, target
, len
) == 0
592 && (field_name
[len
] == '\0'
593 || (strncmp (field_name
+ len
, "___", 3) == 0
594 && strcmp (field_name
+ strlen (field_name
) - 6,
599 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
600 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
601 and return its index. This function also handles fields whose name
602 have ___ suffixes because the compiler sometimes alters their name
603 by adding such a suffix to represent fields with certain constraints.
604 If the field could not be found, return a negative number if
605 MAYBE_MISSING is set. Otherwise raise an error. */
608 ada_get_field_index (const struct type
*type
, const char *field_name
,
612 struct type
*struct_type
= check_typedef ((struct type
*) type
);
614 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (struct_type
); fieldno
++)
615 if (field_name_match (TYPE_FIELD_NAME (struct_type
, fieldno
), field_name
))
619 error (_("Unable to find field %s in struct %s. Aborting"),
620 field_name
, TYPE_NAME (struct_type
));
625 /* The length of the prefix of NAME prior to any "___" suffix. */
628 ada_name_prefix_len (const char *name
)
634 const char *p
= strstr (name
, "___");
637 return strlen (name
);
643 /* Return non-zero if SUFFIX is a suffix of STR.
644 Return zero if STR is null. */
647 is_suffix (const char *str
, const char *suffix
)
654 len2
= strlen (suffix
);
655 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
658 /* The contents of value VAL, treated as a value of type TYPE. The
659 result is an lval in memory if VAL is. */
661 static struct value
*
662 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
664 type
= ada_check_typedef (type
);
665 if (value_type (val
) == type
)
669 struct value
*result
;
671 /* Make sure that the object size is not unreasonable before
672 trying to allocate some memory for it. */
676 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
677 result
= allocate_value_lazy (type
);
680 result
= allocate_value (type
);
681 value_contents_copy_raw (result
, 0, val
, 0, TYPE_LENGTH (type
));
683 set_value_component_location (result
, val
);
684 set_value_bitsize (result
, value_bitsize (val
));
685 set_value_bitpos (result
, value_bitpos (val
));
686 set_value_address (result
, value_address (val
));
691 static const gdb_byte
*
692 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
697 return valaddr
+ offset
;
701 cond_offset_target (CORE_ADDR address
, long offset
)
706 return address
+ offset
;
709 /* Issue a warning (as for the definition of warning in utils.c, but
710 with exactly one argument rather than ...), unless the limit on the
711 number of warnings has passed during the evaluation of the current
714 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
715 provided by "complaint". */
716 static void lim_warning (const char *format
, ...) ATTRIBUTE_PRINTF (1, 2);
719 lim_warning (const char *format
, ...)
723 va_start (args
, format
);
724 warnings_issued
+= 1;
725 if (warnings_issued
<= warning_limit
)
726 vwarning (format
, args
);
731 /* Issue an error if the size of an object of type T is unreasonable,
732 i.e. if it would be a bad idea to allocate a value of this type in
736 check_size (const struct type
*type
)
738 if (TYPE_LENGTH (type
) > varsize_limit
)
739 error (_("object size is larger than varsize-limit"));
742 /* Maximum value of a SIZE-byte signed integer type. */
744 max_of_size (int size
)
746 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
748 return top_bit
| (top_bit
- 1);
751 /* Minimum value of a SIZE-byte signed integer type. */
753 min_of_size (int size
)
755 return -max_of_size (size
) - 1;
758 /* Maximum value of a SIZE-byte unsigned integer type. */
760 umax_of_size (int size
)
762 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
764 return top_bit
| (top_bit
- 1);
767 /* Maximum value of integral type T, as a signed quantity. */
769 max_of_type (struct type
*t
)
771 if (TYPE_UNSIGNED (t
))
772 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
774 return max_of_size (TYPE_LENGTH (t
));
777 /* Minimum value of integral type T, as a signed quantity. */
779 min_of_type (struct type
*t
)
781 if (TYPE_UNSIGNED (t
))
784 return min_of_size (TYPE_LENGTH (t
));
787 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
789 ada_discrete_type_high_bound (struct type
*type
)
791 type
= resolve_dynamic_type (type
, 0);
792 switch (TYPE_CODE (type
))
794 case TYPE_CODE_RANGE
:
795 return TYPE_HIGH_BOUND (type
);
797 return TYPE_FIELD_ENUMVAL (type
, TYPE_NFIELDS (type
) - 1);
802 return max_of_type (type
);
804 error (_("Unexpected type in ada_discrete_type_high_bound."));
808 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
810 ada_discrete_type_low_bound (struct type
*type
)
812 type
= resolve_dynamic_type (type
, 0);
813 switch (TYPE_CODE (type
))
815 case TYPE_CODE_RANGE
:
816 return TYPE_LOW_BOUND (type
);
818 return TYPE_FIELD_ENUMVAL (type
, 0);
823 return min_of_type (type
);
825 error (_("Unexpected type in ada_discrete_type_low_bound."));
829 /* The identity on non-range types. For range types, the underlying
830 non-range scalar type. */
833 get_base_type (struct type
*type
)
835 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
837 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
839 type
= TYPE_TARGET_TYPE (type
);
844 /* Return a decoded version of the given VALUE. This means returning
845 a value whose type is obtained by applying all the GNAT-specific
846 encondings, making the resulting type a static but standard description
847 of the initial type. */
850 ada_get_decoded_value (struct value
*value
)
852 struct type
*type
= ada_check_typedef (value_type (value
));
854 if (ada_is_array_descriptor_type (type
)
855 || (ada_is_constrained_packed_array_type (type
)
856 && TYPE_CODE (type
) != TYPE_CODE_PTR
))
858 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
) /* array access type. */
859 value
= ada_coerce_to_simple_array_ptr (value
);
861 value
= ada_coerce_to_simple_array (value
);
864 value
= ada_to_fixed_value (value
);
869 /* Same as ada_get_decoded_value, but with the given TYPE.
870 Because there is no associated actual value for this type,
871 the resulting type might be a best-effort approximation in
872 the case of dynamic types. */
875 ada_get_decoded_type (struct type
*type
)
877 type
= to_static_fixed_type (type
);
878 if (ada_is_constrained_packed_array_type (type
))
879 type
= ada_coerce_to_simple_array_type (type
);
885 /* Language Selection */
887 /* If the main program is in Ada, return language_ada, otherwise return LANG
888 (the main program is in Ada iif the adainit symbol is found). */
891 ada_update_initial_language (enum language lang
)
893 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
894 (struct objfile
*) NULL
).minsym
!= NULL
)
900 /* If the main procedure is written in Ada, then return its name.
901 The result is good until the next call. Return NULL if the main
902 procedure doesn't appear to be in Ada. */
907 struct bound_minimal_symbol msym
;
908 static char *main_program_name
= NULL
;
910 /* For Ada, the name of the main procedure is stored in a specific
911 string constant, generated by the binder. Look for that symbol,
912 extract its address, and then read that string. If we didn't find
913 that string, then most probably the main procedure is not written
915 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
917 if (msym
.minsym
!= NULL
)
919 CORE_ADDR main_program_name_addr
;
922 main_program_name_addr
= BMSYMBOL_VALUE_ADDRESS (msym
);
923 if (main_program_name_addr
== 0)
924 error (_("Invalid address for Ada main program name."));
926 xfree (main_program_name
);
927 target_read_string (main_program_name_addr
, &main_program_name
,
932 return main_program_name
;
935 /* The main procedure doesn't seem to be in Ada. */
941 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
944 const struct ada_opname_map ada_opname_table
[] = {
945 {"Oadd", "\"+\"", BINOP_ADD
},
946 {"Osubtract", "\"-\"", BINOP_SUB
},
947 {"Omultiply", "\"*\"", BINOP_MUL
},
948 {"Odivide", "\"/\"", BINOP_DIV
},
949 {"Omod", "\"mod\"", BINOP_MOD
},
950 {"Orem", "\"rem\"", BINOP_REM
},
951 {"Oexpon", "\"**\"", BINOP_EXP
},
952 {"Olt", "\"<\"", BINOP_LESS
},
953 {"Ole", "\"<=\"", BINOP_LEQ
},
954 {"Ogt", "\">\"", BINOP_GTR
},
955 {"Oge", "\">=\"", BINOP_GEQ
},
956 {"Oeq", "\"=\"", BINOP_EQUAL
},
957 {"One", "\"/=\"", BINOP_NOTEQUAL
},
958 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
959 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
960 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
961 {"Oconcat", "\"&\"", BINOP_CONCAT
},
962 {"Oabs", "\"abs\"", UNOP_ABS
},
963 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
964 {"Oadd", "\"+\"", UNOP_PLUS
},
965 {"Osubtract", "\"-\"", UNOP_NEG
},
969 /* The "encoded" form of DECODED, according to GNAT conventions.
970 The result is valid until the next call to ada_encode. */
973 ada_encode (const char *decoded
)
975 static char *encoding_buffer
= NULL
;
976 static size_t encoding_buffer_size
= 0;
983 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
984 2 * strlen (decoded
) + 10);
987 for (p
= decoded
; *p
!= '\0'; p
+= 1)
991 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
996 const struct ada_opname_map
*mapping
;
998 for (mapping
= ada_opname_table
;
999 mapping
->encoded
!= NULL
1000 && strncmp (mapping
->decoded
, p
,
1001 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
1003 if (mapping
->encoded
== NULL
)
1004 error (_("invalid Ada operator name: %s"), p
);
1005 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
1006 k
+= strlen (mapping
->encoded
);
1011 encoding_buffer
[k
] = *p
;
1016 encoding_buffer
[k
] = '\0';
1017 return encoding_buffer
;
1020 /* Return NAME folded to lower case, or, if surrounded by single
1021 quotes, unfolded, but with the quotes stripped away. Result good
1025 ada_fold_name (const char *name
)
1027 static char *fold_buffer
= NULL
;
1028 static size_t fold_buffer_size
= 0;
1030 int len
= strlen (name
);
1031 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
1033 if (name
[0] == '\'')
1035 strncpy (fold_buffer
, name
+ 1, len
- 2);
1036 fold_buffer
[len
- 2] = '\000';
1042 for (i
= 0; i
<= len
; i
+= 1)
1043 fold_buffer
[i
] = tolower (name
[i
]);
1049 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1052 is_lower_alphanum (const char c
)
1054 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
1057 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1058 This function saves in LEN the length of that same symbol name but
1059 without either of these suffixes:
1065 These are suffixes introduced by the compiler for entities such as
1066 nested subprogram for instance, in order to avoid name clashes.
1067 They do not serve any purpose for the debugger. */
1070 ada_remove_trailing_digits (const char *encoded
, int *len
)
1072 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
1076 while (i
> 0 && isdigit (encoded
[i
]))
1078 if (i
>= 0 && encoded
[i
] == '.')
1080 else if (i
>= 0 && encoded
[i
] == '$')
1082 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
1084 else if (i
>= 1 && strncmp (encoded
+ i
- 1, "__", 2) == 0)
1089 /* Remove the suffix introduced by the compiler for protected object
1093 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
1095 /* Remove trailing N. */
1097 /* Protected entry subprograms are broken into two
1098 separate subprograms: The first one is unprotected, and has
1099 a 'N' suffix; the second is the protected version, and has
1100 the 'P' suffix. The second calls the first one after handling
1101 the protection. Since the P subprograms are internally generated,
1102 we leave these names undecoded, giving the user a clue that this
1103 entity is internal. */
1106 && encoded
[*len
- 1] == 'N'
1107 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
1111 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1114 ada_remove_Xbn_suffix (const char *encoded
, int *len
)
1118 while (i
> 0 && (encoded
[i
] == 'b' || encoded
[i
] == 'n'))
1121 if (encoded
[i
] != 'X')
1127 if (isalnum (encoded
[i
-1]))
1131 /* If ENCODED follows the GNAT entity encoding conventions, then return
1132 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1133 replaced by ENCODED.
1135 The resulting string is valid until the next call of ada_decode.
1136 If the string is unchanged by decoding, the original string pointer
1140 ada_decode (const char *encoded
)
1147 static char *decoding_buffer
= NULL
;
1148 static size_t decoding_buffer_size
= 0;
1150 /* The name of the Ada main procedure starts with "_ada_".
1151 This prefix is not part of the decoded name, so skip this part
1152 if we see this prefix. */
1153 if (strncmp (encoded
, "_ada_", 5) == 0)
1156 /* If the name starts with '_', then it is not a properly encoded
1157 name, so do not attempt to decode it. Similarly, if the name
1158 starts with '<', the name should not be decoded. */
1159 if (encoded
[0] == '_' || encoded
[0] == '<')
1162 len0
= strlen (encoded
);
1164 ada_remove_trailing_digits (encoded
, &len0
);
1165 ada_remove_po_subprogram_suffix (encoded
, &len0
);
1167 /* Remove the ___X.* suffix if present. Do not forget to verify that
1168 the suffix is located before the current "end" of ENCODED. We want
1169 to avoid re-matching parts of ENCODED that have previously been
1170 marked as discarded (by decrementing LEN0). */
1171 p
= strstr (encoded
, "___");
1172 if (p
!= NULL
&& p
- encoded
< len0
- 3)
1180 /* Remove any trailing TKB suffix. It tells us that this symbol
1181 is for the body of a task, but that information does not actually
1182 appear in the decoded name. */
1184 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
1187 /* Remove any trailing TB suffix. The TB suffix is slightly different
1188 from the TKB suffix because it is used for non-anonymous task
1191 if (len0
> 2 && strncmp (encoded
+ len0
- 2, "TB", 2) == 0)
1194 /* Remove trailing "B" suffixes. */
1195 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1197 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
1200 /* Make decoded big enough for possible expansion by operator name. */
1202 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
1203 decoded
= decoding_buffer
;
1205 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1207 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1210 while ((i
>= 0 && isdigit (encoded
[i
]))
1211 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1213 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1215 else if (encoded
[i
] == '$')
1219 /* The first few characters that are not alphabetic are not part
1220 of any encoding we use, so we can copy them over verbatim. */
1222 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1223 decoded
[j
] = encoded
[i
];
1228 /* Is this a symbol function? */
1229 if (at_start_name
&& encoded
[i
] == 'O')
1233 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1235 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1236 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1238 && !isalnum (encoded
[i
+ op_len
]))
1240 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1243 j
+= strlen (ada_opname_table
[k
].decoded
);
1247 if (ada_opname_table
[k
].encoded
!= NULL
)
1252 /* Replace "TK__" with "__", which will eventually be translated
1253 into "." (just below). */
1255 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
1258 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1259 be translated into "." (just below). These are internal names
1260 generated for anonymous blocks inside which our symbol is nested. */
1262 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1263 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1264 && isdigit (encoded
[i
+4]))
1268 while (k
< len0
&& isdigit (encoded
[k
]))
1269 k
++; /* Skip any extra digit. */
1271 /* Double-check that the "__B_{DIGITS}+" sequence we found
1272 is indeed followed by "__". */
1273 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1277 /* Remove _E{DIGITS}+[sb] */
1279 /* Just as for protected object subprograms, there are 2 categories
1280 of subprograms created by the compiler for each entry. The first
1281 one implements the actual entry code, and has a suffix following
1282 the convention above; the second one implements the barrier and
1283 uses the same convention as above, except that the 'E' is replaced
1286 Just as above, we do not decode the name of barrier functions
1287 to give the user a clue that the code he is debugging has been
1288 internally generated. */
1290 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1291 && isdigit (encoded
[i
+2]))
1295 while (k
< len0
&& isdigit (encoded
[k
]))
1299 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1302 /* Just as an extra precaution, make sure that if this
1303 suffix is followed by anything else, it is a '_'.
1304 Otherwise, we matched this sequence by accident. */
1306 || (k
< len0
&& encoded
[k
] == '_'))
1311 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1312 the GNAT front-end in protected object subprograms. */
1315 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1317 /* Backtrack a bit up until we reach either the begining of
1318 the encoded name, or "__". Make sure that we only find
1319 digits or lowercase characters. */
1320 const char *ptr
= encoded
+ i
- 1;
1322 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1325 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1329 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1331 /* This is a X[bn]* sequence not separated from the previous
1332 part of the name with a non-alpha-numeric character (in other
1333 words, immediately following an alpha-numeric character), then
1334 verify that it is placed at the end of the encoded name. If
1335 not, then the encoding is not valid and we should abort the
1336 decoding. Otherwise, just skip it, it is used in body-nested
1340 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1344 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1346 /* Replace '__' by '.'. */
1354 /* It's a character part of the decoded name, so just copy it
1356 decoded
[j
] = encoded
[i
];
1361 decoded
[j
] = '\000';
1363 /* Decoded names should never contain any uppercase character.
1364 Double-check this, and abort the decoding if we find one. */
1366 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1367 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1370 if (strcmp (decoded
, encoded
) == 0)
1376 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1377 decoded
= decoding_buffer
;
1378 if (encoded
[0] == '<')
1379 strcpy (decoded
, encoded
);
1381 xsnprintf (decoded
, decoding_buffer_size
, "<%s>", encoded
);
1386 /* Table for keeping permanent unique copies of decoded names. Once
1387 allocated, names in this table are never released. While this is a
1388 storage leak, it should not be significant unless there are massive
1389 changes in the set of decoded names in successive versions of a
1390 symbol table loaded during a single session. */
1391 static struct htab
*decoded_names_store
;
1393 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1394 in the language-specific part of GSYMBOL, if it has not been
1395 previously computed. Tries to save the decoded name in the same
1396 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1397 in any case, the decoded symbol has a lifetime at least that of
1399 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1400 const, but nevertheless modified to a semantically equivalent form
1401 when a decoded name is cached in it. */
1404 ada_decode_symbol (const struct general_symbol_info
*arg
)
1406 struct general_symbol_info
*gsymbol
= (struct general_symbol_info
*) arg
;
1407 const char **resultp
=
1408 &gsymbol
->language_specific
.mangled_lang
.demangled_name
;
1410 if (!gsymbol
->ada_mangled
)
1412 const char *decoded
= ada_decode (gsymbol
->name
);
1413 struct obstack
*obstack
= gsymbol
->language_specific
.obstack
;
1415 gsymbol
->ada_mangled
= 1;
1417 if (obstack
!= NULL
)
1418 *resultp
= obstack_copy0 (obstack
, decoded
, strlen (decoded
));
1421 /* Sometimes, we can't find a corresponding objfile, in
1422 which case, we put the result on the heap. Since we only
1423 decode when needed, we hope this usually does not cause a
1424 significant memory leak (FIXME). */
1426 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1430 *slot
= xstrdup (decoded
);
1439 ada_la_decode (const char *encoded
, int options
)
1441 return xstrdup (ada_decode (encoded
));
1444 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1445 suffixes that encode debugging information or leading _ada_ on
1446 SYM_NAME (see is_name_suffix commentary for the debugging
1447 information that is ignored). If WILD, then NAME need only match a
1448 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1449 either argument is NULL. */
1452 match_name (const char *sym_name
, const char *name
, int wild
)
1454 if (sym_name
== NULL
|| name
== NULL
)
1457 return wild_match (sym_name
, name
) == 0;
1460 int len_name
= strlen (name
);
1462 return (strncmp (sym_name
, name
, len_name
) == 0
1463 && is_name_suffix (sym_name
+ len_name
))
1464 || (strncmp (sym_name
, "_ada_", 5) == 0
1465 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1466 && is_name_suffix (sym_name
+ len_name
+ 5));
1473 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1474 generated by the GNAT compiler to describe the index type used
1475 for each dimension of an array, check whether it follows the latest
1476 known encoding. If not, fix it up to conform to the latest encoding.
1477 Otherwise, do nothing. This function also does nothing if
1478 INDEX_DESC_TYPE is NULL.
1480 The GNAT encoding used to describle the array index type evolved a bit.
1481 Initially, the information would be provided through the name of each
1482 field of the structure type only, while the type of these fields was
1483 described as unspecified and irrelevant. The debugger was then expected
1484 to perform a global type lookup using the name of that field in order
1485 to get access to the full index type description. Because these global
1486 lookups can be very expensive, the encoding was later enhanced to make
1487 the global lookup unnecessary by defining the field type as being
1488 the full index type description.
1490 The purpose of this routine is to allow us to support older versions
1491 of the compiler by detecting the use of the older encoding, and by
1492 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1493 we essentially replace each field's meaningless type by the associated
1497 ada_fixup_array_indexes_type (struct type
*index_desc_type
)
1501 if (index_desc_type
== NULL
)
1503 gdb_assert (TYPE_NFIELDS (index_desc_type
) > 0);
1505 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1506 to check one field only, no need to check them all). If not, return
1509 If our INDEX_DESC_TYPE was generated using the older encoding,
1510 the field type should be a meaningless integer type whose name
1511 is not equal to the field name. */
1512 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)) != NULL
1513 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type
, 0)),
1514 TYPE_FIELD_NAME (index_desc_type
, 0)) == 0)
1517 /* Fixup each field of INDEX_DESC_TYPE. */
1518 for (i
= 0; i
< TYPE_NFIELDS (index_desc_type
); i
++)
1520 const char *name
= TYPE_FIELD_NAME (index_desc_type
, i
);
1521 struct type
*raw_type
= ada_check_typedef (ada_find_any_type (name
));
1524 TYPE_FIELD_TYPE (index_desc_type
, i
) = raw_type
;
1528 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1530 static char *bound_name
[] = {
1531 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1532 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1535 /* Maximum number of array dimensions we are prepared to handle. */
1537 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1540 /* The desc_* routines return primitive portions of array descriptors
1543 /* The descriptor or array type, if any, indicated by TYPE; removes
1544 level of indirection, if needed. */
1546 static struct type
*
1547 desc_base_type (struct type
*type
)
1551 type
= ada_check_typedef (type
);
1552 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
1553 type
= ada_typedef_target_type (type
);
1556 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1557 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1558 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1563 /* True iff TYPE indicates a "thin" array pointer type. */
1566 is_thin_pntr (struct type
*type
)
1569 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1570 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1573 /* The descriptor type for thin pointer type TYPE. */
1575 static struct type
*
1576 thin_descriptor_type (struct type
*type
)
1578 struct type
*base_type
= desc_base_type (type
);
1580 if (base_type
== NULL
)
1582 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1586 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1588 if (alt_type
== NULL
)
1595 /* A pointer to the array data for thin-pointer value VAL. */
1597 static struct value
*
1598 thin_data_pntr (struct value
*val
)
1600 struct type
*type
= ada_check_typedef (value_type (val
));
1601 struct type
*data_type
= desc_data_target_type (thin_descriptor_type (type
));
1603 data_type
= lookup_pointer_type (data_type
);
1605 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1606 return value_cast (data_type
, value_copy (val
));
1608 return value_from_longest (data_type
, value_address (val
));
1611 /* True iff TYPE indicates a "thick" array pointer type. */
1614 is_thick_pntr (struct type
*type
)
1616 type
= desc_base_type (type
);
1617 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1618 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1621 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1622 pointer to one, the type of its bounds data; otherwise, NULL. */
1624 static struct type
*
1625 desc_bounds_type (struct type
*type
)
1629 type
= desc_base_type (type
);
1633 else if (is_thin_pntr (type
))
1635 type
= thin_descriptor_type (type
);
1638 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1640 return ada_check_typedef (r
);
1642 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1644 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1646 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1651 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1652 one, a pointer to its bounds data. Otherwise NULL. */
1654 static struct value
*
1655 desc_bounds (struct value
*arr
)
1657 struct type
*type
= ada_check_typedef (value_type (arr
));
1659 if (is_thin_pntr (type
))
1661 struct type
*bounds_type
=
1662 desc_bounds_type (thin_descriptor_type (type
));
1665 if (bounds_type
== NULL
)
1666 error (_("Bad GNAT array descriptor"));
1668 /* NOTE: The following calculation is not really kosher, but
1669 since desc_type is an XVE-encoded type (and shouldn't be),
1670 the correct calculation is a real pain. FIXME (and fix GCC). */
1671 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1672 addr
= value_as_long (arr
);
1674 addr
= value_address (arr
);
1677 value_from_longest (lookup_pointer_type (bounds_type
),
1678 addr
- TYPE_LENGTH (bounds_type
));
1681 else if (is_thick_pntr (type
))
1683 struct value
*p_bounds
= value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1684 _("Bad GNAT array descriptor"));
1685 struct type
*p_bounds_type
= value_type (p_bounds
);
1688 && TYPE_CODE (p_bounds_type
) == TYPE_CODE_PTR
)
1690 struct type
*target_type
= TYPE_TARGET_TYPE (p_bounds_type
);
1692 if (TYPE_STUB (target_type
))
1693 p_bounds
= value_cast (lookup_pointer_type
1694 (ada_check_typedef (target_type
)),
1698 error (_("Bad GNAT array descriptor"));
1706 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1707 position of the field containing the address of the bounds data. */
1710 fat_pntr_bounds_bitpos (struct type
*type
)
1712 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1715 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1716 size of the field containing the address of the bounds data. */
1719 fat_pntr_bounds_bitsize (struct type
*type
)
1721 type
= desc_base_type (type
);
1723 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1724 return TYPE_FIELD_BITSIZE (type
, 1);
1726 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1729 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1730 pointer to one, the type of its array data (a array-with-no-bounds type);
1731 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1734 static struct type
*
1735 desc_data_target_type (struct type
*type
)
1737 type
= desc_base_type (type
);
1739 /* NOTE: The following is bogus; see comment in desc_bounds. */
1740 if (is_thin_pntr (type
))
1741 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1));
1742 else if (is_thick_pntr (type
))
1744 struct type
*data_type
= lookup_struct_elt_type (type
, "P_ARRAY", 1);
1747 && TYPE_CODE (ada_check_typedef (data_type
)) == TYPE_CODE_PTR
)
1748 return ada_check_typedef (TYPE_TARGET_TYPE (data_type
));
1754 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1757 static struct value
*
1758 desc_data (struct value
*arr
)
1760 struct type
*type
= value_type (arr
);
1762 if (is_thin_pntr (type
))
1763 return thin_data_pntr (arr
);
1764 else if (is_thick_pntr (type
))
1765 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1766 _("Bad GNAT array descriptor"));
1772 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1773 position of the field containing the address of the data. */
1776 fat_pntr_data_bitpos (struct type
*type
)
1778 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1781 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1782 size of the field containing the address of the data. */
1785 fat_pntr_data_bitsize (struct type
*type
)
1787 type
= desc_base_type (type
);
1789 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1790 return TYPE_FIELD_BITSIZE (type
, 0);
1792 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1795 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1796 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1797 bound, if WHICH is 1. The first bound is I=1. */
1799 static struct value
*
1800 desc_one_bound (struct value
*bounds
, int i
, int which
)
1802 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1803 _("Bad GNAT array descriptor bounds"));
1806 /* If BOUNDS is an array-bounds structure type, return the bit position
1807 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1808 bound, if WHICH is 1. The first bound is I=1. */
1811 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1813 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1816 /* If BOUNDS is an array-bounds structure type, return the bit field size
1817 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1818 bound, if WHICH is 1. The first bound is I=1. */
1821 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1823 type
= desc_base_type (type
);
1825 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1826 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1828 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1831 /* If TYPE is the type of an array-bounds structure, the type of its
1832 Ith bound (numbering from 1). Otherwise, NULL. */
1834 static struct type
*
1835 desc_index_type (struct type
*type
, int i
)
1837 type
= desc_base_type (type
);
1839 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1840 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1845 /* The number of index positions in the array-bounds type TYPE.
1846 Return 0 if TYPE is NULL. */
1849 desc_arity (struct type
*type
)
1851 type
= desc_base_type (type
);
1854 return TYPE_NFIELDS (type
) / 2;
1858 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1859 an array descriptor type (representing an unconstrained array
1863 ada_is_direct_array_type (struct type
*type
)
1867 type
= ada_check_typedef (type
);
1868 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1869 || ada_is_array_descriptor_type (type
));
1872 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1876 ada_is_array_type (struct type
*type
)
1879 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1880 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1881 type
= TYPE_TARGET_TYPE (type
);
1882 return ada_is_direct_array_type (type
);
1885 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1888 ada_is_simple_array_type (struct type
*type
)
1892 type
= ada_check_typedef (type
);
1893 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1894 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1895 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
)))
1896 == TYPE_CODE_ARRAY
));
1899 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1902 ada_is_array_descriptor_type (struct type
*type
)
1904 struct type
*data_type
= desc_data_target_type (type
);
1908 type
= ada_check_typedef (type
);
1909 return (data_type
!= NULL
1910 && TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
1911 && desc_arity (desc_bounds_type (type
)) > 0);
1914 /* Non-zero iff type is a partially mal-formed GNAT array
1915 descriptor. FIXME: This is to compensate for some problems with
1916 debugging output from GNAT. Re-examine periodically to see if it
1920 ada_is_bogus_array_descriptor (struct type
*type
)
1924 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1925 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1926 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1927 && !ada_is_array_descriptor_type (type
);
1931 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1932 (fat pointer) returns the type of the array data described---specifically,
1933 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1934 in from the descriptor; otherwise, they are left unspecified. If
1935 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1936 returns NULL. The result is simply the type of ARR if ARR is not
1939 ada_type_of_array (struct value
*arr
, int bounds
)
1941 if (ada_is_constrained_packed_array_type (value_type (arr
)))
1942 return decode_constrained_packed_array_type (value_type (arr
));
1944 if (!ada_is_array_descriptor_type (value_type (arr
)))
1945 return value_type (arr
);
1949 struct type
*array_type
=
1950 ada_check_typedef (desc_data_target_type (value_type (arr
)));
1952 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1953 TYPE_FIELD_BITSIZE (array_type
, 0) =
1954 decode_packed_array_bitsize (value_type (arr
));
1960 struct type
*elt_type
;
1962 struct value
*descriptor
;
1964 elt_type
= ada_array_element_type (value_type (arr
), -1);
1965 arity
= ada_array_arity (value_type (arr
));
1967 if (elt_type
== NULL
|| arity
== 0)
1968 return ada_check_typedef (value_type (arr
));
1970 descriptor
= desc_bounds (arr
);
1971 if (value_as_long (descriptor
) == 0)
1975 struct type
*range_type
= alloc_type_copy (value_type (arr
));
1976 struct type
*array_type
= alloc_type_copy (value_type (arr
));
1977 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1978 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1981 create_static_range_type (range_type
, value_type (low
),
1982 longest_to_int (value_as_long (low
)),
1983 longest_to_int (value_as_long (high
)));
1984 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1986 if (ada_is_unconstrained_packed_array_type (value_type (arr
)))
1988 /* We need to store the element packed bitsize, as well as
1989 recompute the array size, because it was previously
1990 computed based on the unpacked element size. */
1991 LONGEST lo
= value_as_long (low
);
1992 LONGEST hi
= value_as_long (high
);
1994 TYPE_FIELD_BITSIZE (elt_type
, 0) =
1995 decode_packed_array_bitsize (value_type (arr
));
1996 /* If the array has no element, then the size is already
1997 zero, and does not need to be recomputed. */
2001 (hi
- lo
+ 1) * TYPE_FIELD_BITSIZE (elt_type
, 0);
2003 TYPE_LENGTH (array_type
) = (array_bitsize
+ 7) / 8;
2008 return lookup_pointer_type (elt_type
);
2012 /* If ARR does not represent an array, returns ARR unchanged.
2013 Otherwise, returns either a standard GDB array with bounds set
2014 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2015 GDB array. Returns NULL if ARR is a null fat pointer. */
2018 ada_coerce_to_simple_array_ptr (struct value
*arr
)
2020 if (ada_is_array_descriptor_type (value_type (arr
)))
2022 struct type
*arrType
= ada_type_of_array (arr
, 1);
2024 if (arrType
== NULL
)
2026 return value_cast (arrType
, value_copy (desc_data (arr
)));
2028 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
2029 return decode_constrained_packed_array (arr
);
2034 /* If ARR does not represent an array, returns ARR unchanged.
2035 Otherwise, returns a standard GDB array describing ARR (which may
2036 be ARR itself if it already is in the proper form). */
2039 ada_coerce_to_simple_array (struct value
*arr
)
2041 if (ada_is_array_descriptor_type (value_type (arr
)))
2043 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
2046 error (_("Bounds unavailable for null array pointer."));
2047 check_size (TYPE_TARGET_TYPE (value_type (arrVal
)));
2048 return value_ind (arrVal
);
2050 else if (ada_is_constrained_packed_array_type (value_type (arr
)))
2051 return decode_constrained_packed_array (arr
);
2056 /* If TYPE represents a GNAT array type, return it translated to an
2057 ordinary GDB array type (possibly with BITSIZE fields indicating
2058 packing). For other types, is the identity. */
2061 ada_coerce_to_simple_array_type (struct type
*type
)
2063 if (ada_is_constrained_packed_array_type (type
))
2064 return decode_constrained_packed_array_type (type
);
2066 if (ada_is_array_descriptor_type (type
))
2067 return ada_check_typedef (desc_data_target_type (type
));
2072 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2075 ada_is_packed_array_type (struct type
*type
)
2079 type
= desc_base_type (type
);
2080 type
= ada_check_typedef (type
);
2082 ada_type_name (type
) != NULL
2083 && strstr (ada_type_name (type
), "___XP") != NULL
;
2086 /* Non-zero iff TYPE represents a standard GNAT constrained
2087 packed-array type. */
2090 ada_is_constrained_packed_array_type (struct type
*type
)
2092 return ada_is_packed_array_type (type
)
2093 && !ada_is_array_descriptor_type (type
);
2096 /* Non-zero iff TYPE represents an array descriptor for a
2097 unconstrained packed-array type. */
2100 ada_is_unconstrained_packed_array_type (struct type
*type
)
2102 return ada_is_packed_array_type (type
)
2103 && ada_is_array_descriptor_type (type
);
2106 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2107 return the size of its elements in bits. */
2110 decode_packed_array_bitsize (struct type
*type
)
2112 const char *raw_name
;
2116 /* Access to arrays implemented as fat pointers are encoded as a typedef
2117 of the fat pointer type. We need the name of the fat pointer type
2118 to do the decoding, so strip the typedef layer. */
2119 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
2120 type
= ada_typedef_target_type (type
);
2122 raw_name
= ada_type_name (ada_check_typedef (type
));
2124 raw_name
= ada_type_name (desc_base_type (type
));
2129 tail
= strstr (raw_name
, "___XP");
2130 gdb_assert (tail
!= NULL
);
2132 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
2135 (_("could not understand bit size information on packed array"));
2142 /* Given that TYPE is a standard GDB array type with all bounds filled
2143 in, and that the element size of its ultimate scalar constituents
2144 (that is, either its elements, or, if it is an array of arrays, its
2145 elements' elements, etc.) is *ELT_BITS, return an identical type,
2146 but with the bit sizes of its elements (and those of any
2147 constituent arrays) recorded in the BITSIZE components of its
2148 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2151 static struct type
*
2152 constrained_packed_array_type (struct type
*type
, long *elt_bits
)
2154 struct type
*new_elt_type
;
2155 struct type
*new_type
;
2156 struct type
*index_type_desc
;
2157 struct type
*index_type
;
2158 LONGEST low_bound
, high_bound
;
2160 type
= ada_check_typedef (type
);
2161 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2164 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2165 if (index_type_desc
)
2166 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, 0),
2169 index_type
= TYPE_INDEX_TYPE (type
);
2171 new_type
= alloc_type_copy (type
);
2173 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
2175 create_array_type (new_type
, new_elt_type
, index_type
);
2176 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
2177 TYPE_NAME (new_type
) = ada_type_name (type
);
2179 if (get_discrete_bounds (index_type
, &low_bound
, &high_bound
) < 0)
2180 low_bound
= high_bound
= 0;
2181 if (high_bound
< low_bound
)
2182 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
2185 *elt_bits
*= (high_bound
- low_bound
+ 1);
2186 TYPE_LENGTH (new_type
) =
2187 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2190 TYPE_FIXED_INSTANCE (new_type
) = 1;
2194 /* The array type encoded by TYPE, where
2195 ada_is_constrained_packed_array_type (TYPE). */
2197 static struct type
*
2198 decode_constrained_packed_array_type (struct type
*type
)
2200 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
2203 struct type
*shadow_type
;
2207 raw_name
= ada_type_name (desc_base_type (type
));
2212 name
= (char *) alloca (strlen (raw_name
) + 1);
2213 tail
= strstr (raw_name
, "___XP");
2214 type
= desc_base_type (type
);
2216 memcpy (name
, raw_name
, tail
- raw_name
);
2217 name
[tail
- raw_name
] = '\000';
2219 shadow_type
= ada_find_parallel_type_with_name (type
, name
);
2221 if (shadow_type
== NULL
)
2223 lim_warning (_("could not find bounds information on packed array"));
2226 CHECK_TYPEDEF (shadow_type
);
2228 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
2230 lim_warning (_("could not understand bounds "
2231 "information on packed array"));
2235 bits
= decode_packed_array_bitsize (type
);
2236 return constrained_packed_array_type (shadow_type
, &bits
);
2239 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2240 array, returns a simple array that denotes that array. Its type is a
2241 standard GDB array type except that the BITSIZEs of the array
2242 target types are set to the number of bits in each element, and the
2243 type length is set appropriately. */
2245 static struct value
*
2246 decode_constrained_packed_array (struct value
*arr
)
2250 /* If our value is a pointer, then dereference it. Likewise if
2251 the value is a reference. Make sure that this operation does not
2252 cause the target type to be fixed, as this would indirectly cause
2253 this array to be decoded. The rest of the routine assumes that
2254 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2255 and "value_ind" routines to perform the dereferencing, as opposed
2256 to using "ada_coerce_ref" or "ada_value_ind". */
2257 arr
= coerce_ref (arr
);
2258 if (TYPE_CODE (ada_check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
2259 arr
= value_ind (arr
);
2261 type
= decode_constrained_packed_array_type (value_type (arr
));
2264 error (_("can't unpack array"));
2268 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr
)))
2269 && ada_is_modular_type (value_type (arr
)))
2271 /* This is a (right-justified) modular type representing a packed
2272 array with no wrapper. In order to interpret the value through
2273 the (left-justified) packed array type we just built, we must
2274 first left-justify it. */
2275 int bit_size
, bit_pos
;
2278 mod
= ada_modulus (value_type (arr
)) - 1;
2285 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
2286 arr
= ada_value_primitive_packed_val (arr
, NULL
,
2287 bit_pos
/ HOST_CHAR_BIT
,
2288 bit_pos
% HOST_CHAR_BIT
,
2293 return coerce_unspec_val_to_type (arr
, type
);
2297 /* The value of the element of packed array ARR at the ARITY indices
2298 given in IND. ARR must be a simple array. */
2300 static struct value
*
2301 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
2304 int bits
, elt_off
, bit_off
;
2305 long elt_total_bit_offset
;
2306 struct type
*elt_type
;
2310 elt_total_bit_offset
= 0;
2311 elt_type
= ada_check_typedef (value_type (arr
));
2312 for (i
= 0; i
< arity
; i
+= 1)
2314 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
2315 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
2317 (_("attempt to do packed indexing of "
2318 "something other than a packed array"));
2321 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
2322 LONGEST lowerbound
, upperbound
;
2325 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
2327 lim_warning (_("don't know bounds of array"));
2328 lowerbound
= upperbound
= 0;
2331 idx
= pos_atr (ind
[i
]);
2332 if (idx
< lowerbound
|| idx
> upperbound
)
2333 lim_warning (_("packed array index %ld out of bounds"),
2335 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
2336 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
2337 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
2340 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
2341 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
2343 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
2348 /* Non-zero iff TYPE includes negative integer values. */
2351 has_negatives (struct type
*type
)
2353 switch (TYPE_CODE (type
))
2358 return !TYPE_UNSIGNED (type
);
2359 case TYPE_CODE_RANGE
:
2360 return TYPE_LOW_BOUND (type
) < 0;
2365 /* Create a new value of type TYPE from the contents of OBJ starting
2366 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2367 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2368 assigning through the result will set the field fetched from.
2369 VALADDR is ignored unless OBJ is NULL, in which case,
2370 VALADDR+OFFSET must address the start of storage containing the
2371 packed value. The value returned in this case is never an lval.
2372 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2375 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
2376 long offset
, int bit_offset
, int bit_size
,
2380 int src
, /* Index into the source area */
2381 targ
, /* Index into the target area */
2382 srcBitsLeft
, /* Number of source bits left to move */
2383 nsrc
, ntarg
, /* Number of source and target bytes */
2384 unusedLS
, /* Number of bits in next significant
2385 byte of source that are unused */
2386 accumSize
; /* Number of meaningful bits in accum */
2387 unsigned char *bytes
; /* First byte containing data to unpack */
2388 unsigned char *unpacked
;
2389 unsigned long accum
; /* Staging area for bits being transferred */
2391 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2392 /* Transmit bytes from least to most significant; delta is the direction
2393 the indices move. */
2394 int delta
= gdbarch_bits_big_endian (get_type_arch (type
)) ? -1 : 1;
2396 type
= ada_check_typedef (type
);
2400 v
= allocate_value (type
);
2401 bytes
= (unsigned char *) (valaddr
+ offset
);
2403 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2405 v
= value_at (type
, value_address (obj
));
2406 type
= value_type (v
);
2407 bytes
= (unsigned char *) alloca (len
);
2408 read_memory (value_address (v
) + offset
, bytes
, len
);
2412 v
= allocate_value (type
);
2413 bytes
= (unsigned char *) value_contents (obj
) + offset
;
2418 long new_offset
= offset
;
2420 set_value_component_location (v
, obj
);
2421 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2422 set_value_bitsize (v
, bit_size
);
2423 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2426 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2428 set_value_offset (v
, new_offset
);
2430 /* Also set the parent value. This is needed when trying to
2431 assign a new value (in inferior memory). */
2432 set_value_parent (v
, obj
);
2435 set_value_bitsize (v
, bit_size
);
2436 unpacked
= (unsigned char *) value_contents (v
);
2438 srcBitsLeft
= bit_size
;
2440 ntarg
= TYPE_LENGTH (type
);
2444 memset (unpacked
, 0, TYPE_LENGTH (type
));
2447 else if (gdbarch_bits_big_endian (get_type_arch (type
)))
2450 if (has_negatives (type
)
2451 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2455 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2458 switch (TYPE_CODE (type
))
2460 case TYPE_CODE_ARRAY
:
2461 case TYPE_CODE_UNION
:
2462 case TYPE_CODE_STRUCT
:
2463 /* Non-scalar values must be aligned at a byte boundary... */
2465 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2466 /* ... And are placed at the beginning (most-significant) bytes
2468 targ
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2473 targ
= TYPE_LENGTH (type
) - 1;
2479 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2482 unusedLS
= bit_offset
;
2485 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
2492 /* Mask for removing bits of the next source byte that are not
2493 part of the value. */
2494 unsigned int unusedMSMask
=
2495 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2497 /* Sign-extend bits for this byte. */
2498 unsigned int signMask
= sign
& ~unusedMSMask
;
2501 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2502 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2503 if (accumSize
>= HOST_CHAR_BIT
)
2505 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2506 accumSize
-= HOST_CHAR_BIT
;
2507 accum
>>= HOST_CHAR_BIT
;
2511 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2518 accum
|= sign
<< accumSize
;
2519 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2520 accumSize
-= HOST_CHAR_BIT
;
2521 accum
>>= HOST_CHAR_BIT
;
2529 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2530 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2533 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
2534 int src_offset
, int n
, int bits_big_endian_p
)
2536 unsigned int accum
, mask
;
2537 int accum_bits
, chunk_size
;
2539 target
+= targ_offset
/ HOST_CHAR_BIT
;
2540 targ_offset
%= HOST_CHAR_BIT
;
2541 source
+= src_offset
/ HOST_CHAR_BIT
;
2542 src_offset
%= HOST_CHAR_BIT
;
2543 if (bits_big_endian_p
)
2545 accum
= (unsigned char) *source
;
2547 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2553 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2554 accum_bits
+= HOST_CHAR_BIT
;
2556 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2559 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2560 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2563 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2565 accum_bits
-= chunk_size
;
2572 accum
= (unsigned char) *source
>> src_offset
;
2574 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2578 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2579 accum_bits
+= HOST_CHAR_BIT
;
2581 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2584 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2585 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2587 accum_bits
-= chunk_size
;
2588 accum
>>= chunk_size
;
2595 /* Store the contents of FROMVAL into the location of TOVAL.
2596 Return a new value with the location of TOVAL and contents of
2597 FROMVAL. Handles assignment into packed fields that have
2598 floating-point or non-scalar types. */
2600 static struct value
*
2601 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2603 struct type
*type
= value_type (toval
);
2604 int bits
= value_bitsize (toval
);
2606 toval
= ada_coerce_ref (toval
);
2607 fromval
= ada_coerce_ref (fromval
);
2609 if (ada_is_direct_array_type (value_type (toval
)))
2610 toval
= ada_coerce_to_simple_array (toval
);
2611 if (ada_is_direct_array_type (value_type (fromval
)))
2612 fromval
= ada_coerce_to_simple_array (fromval
);
2614 if (!deprecated_value_modifiable (toval
))
2615 error (_("Left operand of assignment is not a modifiable lvalue."));
2617 if (VALUE_LVAL (toval
) == lval_memory
2619 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2620 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2622 int len
= (value_bitpos (toval
)
2623 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2625 gdb_byte
*buffer
= alloca (len
);
2627 CORE_ADDR to_addr
= value_address (toval
);
2629 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2630 fromval
= value_cast (type
, fromval
);
2632 read_memory (to_addr
, buffer
, len
);
2633 from_size
= value_bitsize (fromval
);
2635 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2636 if (gdbarch_bits_big_endian (get_type_arch (type
)))
2637 move_bits (buffer
, value_bitpos (toval
),
2638 value_contents (fromval
), from_size
- bits
, bits
, 1);
2640 move_bits (buffer
, value_bitpos (toval
),
2641 value_contents (fromval
), 0, bits
, 0);
2642 write_memory_with_notification (to_addr
, buffer
, len
);
2644 val
= value_copy (toval
);
2645 memcpy (value_contents_raw (val
), value_contents (fromval
),
2646 TYPE_LENGTH (type
));
2647 deprecated_set_value_type (val
, type
);
2652 return value_assign (toval
, fromval
);
2656 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2657 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2658 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2659 * COMPONENT, and not the inferior's memory. The current contents
2660 * of COMPONENT are ignored. */
2662 value_assign_to_component (struct value
*container
, struct value
*component
,
2665 LONGEST offset_in_container
=
2666 (LONGEST
) (value_address (component
) - value_address (container
));
2667 int bit_offset_in_container
=
2668 value_bitpos (component
) - value_bitpos (container
);
2671 val
= value_cast (value_type (component
), val
);
2673 if (value_bitsize (component
) == 0)
2674 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2676 bits
= value_bitsize (component
);
2678 if (gdbarch_bits_big_endian (get_type_arch (value_type (container
))))
2679 move_bits (value_contents_writeable (container
) + offset_in_container
,
2680 value_bitpos (container
) + bit_offset_in_container
,
2681 value_contents (val
),
2682 TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
,
2685 move_bits (value_contents_writeable (container
) + offset_in_container
,
2686 value_bitpos (container
) + bit_offset_in_container
,
2687 value_contents (val
), 0, bits
, 0);
2690 /* The value of the element of array ARR at the ARITY indices given in IND.
2691 ARR may be either a simple array, GNAT array descriptor, or pointer
2695 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2699 struct type
*elt_type
;
2701 elt
= ada_coerce_to_simple_array (arr
);
2703 elt_type
= ada_check_typedef (value_type (elt
));
2704 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2705 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2706 return value_subscript_packed (elt
, arity
, ind
);
2708 for (k
= 0; k
< arity
; k
+= 1)
2710 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2711 error (_("too many subscripts (%d expected)"), k
);
2712 elt
= value_subscript (elt
, pos_atr (ind
[k
]));
2717 /* Assuming ARR is a pointer to a GDB array, the value of the element
2718 of *ARR at the ARITY indices given in IND.
2719 Does not read the entire array into memory. */
2721 static struct value
*
2722 ada_value_ptr_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2726 = check_typedef (value_enclosing_type (ada_value_ind (arr
)));
2728 for (k
= 0; k
< arity
; k
+= 1)
2732 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2733 error (_("too many subscripts (%d expected)"), k
);
2734 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2736 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2737 arr
= value_ptradd (arr
, pos_atr (ind
[k
]) - lwb
);
2738 type
= TYPE_TARGET_TYPE (type
);
2741 return value_ind (arr
);
2744 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2745 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2746 elements starting at index LOW. The lower bound of this array is LOW, as
2748 static struct value
*
2749 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2752 struct type
*type0
= ada_check_typedef (type
);
2753 CORE_ADDR base
= value_as_address (array_ptr
)
2754 + ((low
- ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0
)))
2755 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0
)));
2756 struct type
*index_type
2757 = create_static_range_type (NULL
,
2758 TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0
)),
2760 struct type
*slice_type
=
2761 create_array_type (NULL
, TYPE_TARGET_TYPE (type0
), index_type
);
2763 return value_at_lazy (slice_type
, base
);
2767 static struct value
*
2768 ada_value_slice (struct value
*array
, int low
, int high
)
2770 struct type
*type
= ada_check_typedef (value_type (array
));
2771 struct type
*index_type
2772 = create_static_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2773 struct type
*slice_type
=
2774 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2776 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2779 /* If type is a record type in the form of a standard GNAT array
2780 descriptor, returns the number of dimensions for type. If arr is a
2781 simple array, returns the number of "array of"s that prefix its
2782 type designation. Otherwise, returns 0. */
2785 ada_array_arity (struct type
*type
)
2792 type
= desc_base_type (type
);
2795 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2796 return desc_arity (desc_bounds_type (type
));
2798 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2801 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2807 /* If TYPE is a record type in the form of a standard GNAT array
2808 descriptor or a simple array type, returns the element type for
2809 TYPE after indexing by NINDICES indices, or by all indices if
2810 NINDICES is -1. Otherwise, returns NULL. */
2813 ada_array_element_type (struct type
*type
, int nindices
)
2815 type
= desc_base_type (type
);
2817 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2820 struct type
*p_array_type
;
2822 p_array_type
= desc_data_target_type (type
);
2824 k
= ada_array_arity (type
);
2828 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2829 if (nindices
>= 0 && k
> nindices
)
2831 while (k
> 0 && p_array_type
!= NULL
)
2833 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2836 return p_array_type
;
2838 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2840 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2842 type
= TYPE_TARGET_TYPE (type
);
2851 /* The type of nth index in arrays of given type (n numbering from 1).
2852 Does not examine memory. Throws an error if N is invalid or TYPE
2853 is not an array type. NAME is the name of the Ada attribute being
2854 evaluated ('range, 'first, 'last, or 'length); it is used in building
2855 the error message. */
2857 static struct type
*
2858 ada_index_type (struct type
*type
, int n
, const char *name
)
2860 struct type
*result_type
;
2862 type
= desc_base_type (type
);
2864 if (n
< 0 || n
> ada_array_arity (type
))
2865 error (_("invalid dimension number to '%s"), name
);
2867 if (ada_is_simple_array_type (type
))
2871 for (i
= 1; i
< n
; i
+= 1)
2872 type
= TYPE_TARGET_TYPE (type
);
2873 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2874 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2875 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2876 perhaps stabsread.c would make more sense. */
2877 if (result_type
&& TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2882 result_type
= desc_index_type (desc_bounds_type (type
), n
);
2883 if (result_type
== NULL
)
2884 error (_("attempt to take bound of something that is not an array"));
2890 /* Given that arr is an array type, returns the lower bound of the
2891 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2892 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2893 array-descriptor type. It works for other arrays with bounds supplied
2894 by run-time quantities other than discriminants. */
2897 ada_array_bound_from_type (struct type
*arr_type
, int n
, int which
)
2899 struct type
*type
, *index_type_desc
, *index_type
;
2902 gdb_assert (which
== 0 || which
== 1);
2904 if (ada_is_constrained_packed_array_type (arr_type
))
2905 arr_type
= decode_constrained_packed_array_type (arr_type
);
2907 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2908 return (LONGEST
) - which
;
2910 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2911 type
= TYPE_TARGET_TYPE (arr_type
);
2915 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2916 ada_fixup_array_indexes_type (index_type_desc
);
2917 if (index_type_desc
!= NULL
)
2918 index_type
= to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, n
- 1),
2922 struct type
*elt_type
= check_typedef (type
);
2924 for (i
= 1; i
< n
; i
++)
2925 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
2927 index_type
= TYPE_INDEX_TYPE (elt_type
);
2931 (LONGEST
) (which
== 0
2932 ? ada_discrete_type_low_bound (index_type
)
2933 : ada_discrete_type_high_bound (index_type
));
2936 /* Given that arr is an array value, returns the lower bound of the
2937 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2938 WHICH is 1. This routine will also work for arrays with bounds
2939 supplied by run-time quantities other than discriminants. */
2942 ada_array_bound (struct value
*arr
, int n
, int which
)
2944 struct type
*arr_type
;
2946 if (TYPE_CODE (check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
2947 arr
= value_ind (arr
);
2948 arr_type
= value_enclosing_type (arr
);
2950 if (ada_is_constrained_packed_array_type (arr_type
))
2951 return ada_array_bound (decode_constrained_packed_array (arr
), n
, which
);
2952 else if (ada_is_simple_array_type (arr_type
))
2953 return ada_array_bound_from_type (arr_type
, n
, which
);
2955 return value_as_long (desc_one_bound (desc_bounds (arr
), n
, which
));
2958 /* Given that arr is an array value, returns the length of the
2959 nth index. This routine will also work for arrays with bounds
2960 supplied by run-time quantities other than discriminants.
2961 Does not work for arrays indexed by enumeration types with representation
2962 clauses at the moment. */
2965 ada_array_length (struct value
*arr
, int n
)
2967 struct type
*arr_type
;
2969 if (TYPE_CODE (check_typedef (value_type (arr
))) == TYPE_CODE_PTR
)
2970 arr
= value_ind (arr
);
2971 arr_type
= value_enclosing_type (arr
);
2973 if (ada_is_constrained_packed_array_type (arr_type
))
2974 return ada_array_length (decode_constrained_packed_array (arr
), n
);
2976 if (ada_is_simple_array_type (arr_type
))
2977 return (ada_array_bound_from_type (arr_type
, n
, 1)
2978 - ada_array_bound_from_type (arr_type
, n
, 0) + 1);
2980 return (value_as_long (desc_one_bound (desc_bounds (arr
), n
, 1))
2981 - value_as_long (desc_one_bound (desc_bounds (arr
), n
, 0)) + 1);
2984 /* An empty array whose type is that of ARR_TYPE (an array type),
2985 with bounds LOW to LOW-1. */
2987 static struct value
*
2988 empty_array (struct type
*arr_type
, int low
)
2990 struct type
*arr_type0
= ada_check_typedef (arr_type
);
2991 struct type
*index_type
2992 = create_static_range_type
2993 (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0
)), low
, low
- 1);
2994 struct type
*elt_type
= ada_array_element_type (arr_type0
, 1);
2996 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
3000 /* Name resolution */
3002 /* The "decoded" name for the user-definable Ada operator corresponding
3006 ada_decoded_op_name (enum exp_opcode op
)
3010 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
3012 if (ada_opname_table
[i
].op
== op
)
3013 return ada_opname_table
[i
].decoded
;
3015 error (_("Could not find operator name for opcode"));
3019 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3020 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3021 undefined namespace) and converts operators that are
3022 user-defined into appropriate function calls. If CONTEXT_TYPE is
3023 non-null, it provides a preferred result type [at the moment, only
3024 type void has any effect---causing procedures to be preferred over
3025 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3026 return type is preferred. May change (expand) *EXP. */
3029 resolve (struct expression
**expp
, int void_context_p
)
3031 struct type
*context_type
= NULL
;
3035 context_type
= builtin_type ((*expp
)->gdbarch
)->builtin_void
;
3037 resolve_subexp (expp
, &pc
, 1, context_type
);
3040 /* Resolve the operator of the subexpression beginning at
3041 position *POS of *EXPP. "Resolving" consists of replacing
3042 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3043 with their resolutions, replacing built-in operators with
3044 function calls to user-defined operators, where appropriate, and,
3045 when DEPROCEDURE_P is non-zero, converting function-valued variables
3046 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3047 are as in ada_resolve, above. */
3049 static struct value
*
3050 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
3051 struct type
*context_type
)
3055 struct expression
*exp
; /* Convenience: == *expp. */
3056 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
3057 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
3058 int nargs
; /* Number of operands. */
3065 /* Pass one: resolve operands, saving their types and updating *pos,
3070 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3071 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3076 resolve_subexp (expp
, pos
, 0, NULL
);
3078 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
3083 resolve_subexp (expp
, pos
, 0, NULL
);
3088 resolve_subexp (expp
, pos
, 1, check_typedef (exp
->elts
[pc
+ 1].type
));
3091 case OP_ATR_MODULUS
:
3101 case TERNOP_IN_RANGE
:
3102 case BINOP_IN_BOUNDS
:
3108 case OP_DISCRETE_RANGE
:
3110 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
3119 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
3121 resolve_subexp (expp
, pos
, 1, NULL
);
3123 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
3140 case BINOP_LOGICAL_AND
:
3141 case BINOP_LOGICAL_OR
:
3142 case BINOP_BITWISE_AND
:
3143 case BINOP_BITWISE_IOR
:
3144 case BINOP_BITWISE_XOR
:
3147 case BINOP_NOTEQUAL
:
3154 case BINOP_SUBSCRIPT
:
3162 case UNOP_LOGICAL_NOT
:
3178 case OP_INTERNALVAR
:
3188 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3191 case STRUCTOP_STRUCT
:
3192 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
3205 error (_("Unexpected operator during name resolution"));
3208 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
3209 for (i
= 0; i
< nargs
; i
+= 1)
3210 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
3214 /* Pass two: perform any resolution on principal operator. */
3221 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
3223 struct ada_symbol_info
*candidates
;
3227 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3228 (exp
->elts
[pc
+ 2].symbol
),
3229 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
3232 if (n_candidates
> 1)
3234 /* Types tend to get re-introduced locally, so if there
3235 are any local symbols that are not types, first filter
3238 for (j
= 0; j
< n_candidates
; j
+= 1)
3239 switch (SYMBOL_CLASS (candidates
[j
].sym
))
3244 case LOC_REGPARM_ADDR
:
3252 if (j
< n_candidates
)
3255 while (j
< n_candidates
)
3257 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
3259 candidates
[j
] = candidates
[n_candidates
- 1];
3268 if (n_candidates
== 0)
3269 error (_("No definition found for %s"),
3270 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3271 else if (n_candidates
== 1)
3273 else if (deprocedure_p
3274 && !is_nonfunction (candidates
, n_candidates
))
3276 i
= ada_resolve_function
3277 (candidates
, n_candidates
, NULL
, 0,
3278 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
3281 error (_("Could not find a match for %s"),
3282 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3286 printf_filtered (_("Multiple matches for %s\n"),
3287 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
3288 user_select_syms (candidates
, n_candidates
, 1);
3292 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
3293 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
3294 if (innermost_block
== NULL
3295 || contained_in (candidates
[i
].block
, innermost_block
))
3296 innermost_block
= candidates
[i
].block
;
3300 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
3303 replace_operator_with_call (expp
, pc
, 0, 0,
3304 exp
->elts
[pc
+ 2].symbol
,
3305 exp
->elts
[pc
+ 1].block
);
3312 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
3313 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
3315 struct ada_symbol_info
*candidates
;
3319 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3320 (exp
->elts
[pc
+ 5].symbol
),
3321 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
3323 if (n_candidates
== 1)
3327 i
= ada_resolve_function
3328 (candidates
, n_candidates
,
3330 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
3333 error (_("Could not find a match for %s"),
3334 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
3337 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
3338 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
3339 if (innermost_block
== NULL
3340 || contained_in (candidates
[i
].block
, innermost_block
))
3341 innermost_block
= candidates
[i
].block
;
3352 case BINOP_BITWISE_AND
:
3353 case BINOP_BITWISE_IOR
:
3354 case BINOP_BITWISE_XOR
:
3356 case BINOP_NOTEQUAL
:
3364 case UNOP_LOGICAL_NOT
:
3366 if (possible_user_operator_p (op
, argvec
))
3368 struct ada_symbol_info
*candidates
;
3372 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
3373 (struct block
*) NULL
, VAR_DOMAIN
,
3375 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
3376 ada_decoded_op_name (op
), NULL
);
3380 replace_operator_with_call (expp
, pc
, nargs
, 1,
3381 candidates
[i
].sym
, candidates
[i
].block
);
3392 return evaluate_subexp_type (exp
, pos
);
3395 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3396 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3398 /* The term "match" here is rather loose. The match is heuristic and
3402 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3404 ftype
= ada_check_typedef (ftype
);
3405 atype
= ada_check_typedef (atype
);
3407 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3408 ftype
= TYPE_TARGET_TYPE (ftype
);
3409 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3410 atype
= TYPE_TARGET_TYPE (atype
);
3412 switch (TYPE_CODE (ftype
))
3415 return TYPE_CODE (ftype
) == TYPE_CODE (atype
);
3417 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3418 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3419 TYPE_TARGET_TYPE (atype
), 0);
3422 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3424 case TYPE_CODE_ENUM
:
3425 case TYPE_CODE_RANGE
:
3426 switch (TYPE_CODE (atype
))
3429 case TYPE_CODE_ENUM
:
3430 case TYPE_CODE_RANGE
:
3436 case TYPE_CODE_ARRAY
:
3437 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3438 || ada_is_array_descriptor_type (atype
));
3440 case TYPE_CODE_STRUCT
:
3441 if (ada_is_array_descriptor_type (ftype
))
3442 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3443 || ada_is_array_descriptor_type (atype
));
3445 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3446 && !ada_is_array_descriptor_type (atype
));
3448 case TYPE_CODE_UNION
:
3450 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3454 /* Return non-zero if the formals of FUNC "sufficiently match" the
3455 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3456 may also be an enumeral, in which case it is treated as a 0-
3457 argument function. */
3460 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3463 struct type
*func_type
= SYMBOL_TYPE (func
);
3465 if (SYMBOL_CLASS (func
) == LOC_CONST
3466 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3467 return (n_actuals
== 0);
3468 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3471 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3474 for (i
= 0; i
< n_actuals
; i
+= 1)
3476 if (actuals
[i
] == NULL
)
3480 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
,
3482 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3484 if (!ada_type_match (ftype
, atype
, 1))
3491 /* False iff function type FUNC_TYPE definitely does not produce a value
3492 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3493 FUNC_TYPE is not a valid function type with a non-null return type
3494 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3497 return_match (struct type
*func_type
, struct type
*context_type
)
3499 struct type
*return_type
;
3501 if (func_type
== NULL
)
3504 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3505 return_type
= get_base_type (TYPE_TARGET_TYPE (func_type
));
3507 return_type
= get_base_type (func_type
);
3508 if (return_type
== NULL
)
3511 context_type
= get_base_type (context_type
);
3513 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3514 return context_type
== NULL
|| return_type
== context_type
;
3515 else if (context_type
== NULL
)
3516 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3518 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3522 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3523 function (if any) that matches the types of the NARGS arguments in
3524 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3525 that returns that type, then eliminate matches that don't. If
3526 CONTEXT_TYPE is void and there is at least one match that does not
3527 return void, eliminate all matches that do.
3529 Asks the user if there is more than one match remaining. Returns -1
3530 if there is no such symbol or none is selected. NAME is used
3531 solely for messages. May re-arrange and modify SYMS in
3532 the process; the index returned is for the modified vector. */
3535 ada_resolve_function (struct ada_symbol_info syms
[],
3536 int nsyms
, struct value
**args
, int nargs
,
3537 const char *name
, struct type
*context_type
)
3541 int m
; /* Number of hits */
3544 /* In the first pass of the loop, we only accept functions matching
3545 context_type. If none are found, we add a second pass of the loop
3546 where every function is accepted. */
3547 for (fallback
= 0; m
== 0 && fallback
< 2; fallback
++)
3549 for (k
= 0; k
< nsyms
; k
+= 1)
3551 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3553 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3554 && (fallback
|| return_match (type
, context_type
)))
3566 printf_filtered (_("Multiple matches for %s\n"), name
);
3567 user_select_syms (syms
, m
, 1);
3573 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3574 in a listing of choices during disambiguation (see sort_choices, below).
3575 The idea is that overloadings of a subprogram name from the
3576 same package should sort in their source order. We settle for ordering
3577 such symbols by their trailing number (__N or $N). */
3580 encoded_ordered_before (const char *N0
, const char *N1
)
3584 else if (N0
== NULL
)
3590 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3592 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3594 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3595 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3600 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3603 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3605 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3606 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3608 return (strcmp (N0
, N1
) < 0);
3612 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3616 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3620 for (i
= 1; i
< nsyms
; i
+= 1)
3622 struct ada_symbol_info sym
= syms
[i
];
3625 for (j
= i
- 1; j
>= 0; j
-= 1)
3627 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3628 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3630 syms
[j
+ 1] = syms
[j
];
3636 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3637 by asking the user (if necessary), returning the number selected,
3638 and setting the first elements of SYMS items. Error if no symbols
3641 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3642 to be re-integrated one of these days. */
3645 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3648 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3650 int first_choice
= (max_results
== 1) ? 1 : 2;
3651 const char *select_mode
= multiple_symbols_select_mode ();
3653 if (max_results
< 1)
3654 error (_("Request to select 0 symbols!"));
3658 if (select_mode
== multiple_symbols_cancel
)
3660 canceled because the command is ambiguous\n\
3661 See set/show multiple-symbol."));
3663 /* If select_mode is "all", then return all possible symbols.
3664 Only do that if more than one symbol can be selected, of course.
3665 Otherwise, display the menu as usual. */
3666 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3669 printf_unfiltered (_("[0] cancel\n"));
3670 if (max_results
> 1)
3671 printf_unfiltered (_("[1] all\n"));
3673 sort_choices (syms
, nsyms
);
3675 for (i
= 0; i
< nsyms
; i
+= 1)
3677 if (syms
[i
].sym
== NULL
)
3680 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3682 struct symtab_and_line sal
=
3683 find_function_start_sal (syms
[i
].sym
, 1);
3685 if (sal
.symtab
== NULL
)
3686 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3688 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3691 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3692 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3693 symtab_to_filename_for_display (sal
.symtab
),
3700 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3701 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3702 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3703 struct symtab
*symtab
= SYMBOL_SYMTAB (syms
[i
].sym
);
3705 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3706 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3708 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3709 symtab_to_filename_for_display (symtab
),
3710 SYMBOL_LINE (syms
[i
].sym
));
3711 else if (is_enumeral
3712 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3714 printf_unfiltered (("[%d] "), i
+ first_choice
);
3715 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3716 gdb_stdout
, -1, 0, &type_print_raw_options
);
3717 printf_unfiltered (_("'(%s) (enumeral)\n"),
3718 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3720 else if (symtab
!= NULL
)
3721 printf_unfiltered (is_enumeral
3722 ? _("[%d] %s in %s (enumeral)\n")
3723 : _("[%d] %s at %s:?\n"),
3725 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3726 symtab_to_filename_for_display (symtab
));
3728 printf_unfiltered (is_enumeral
3729 ? _("[%d] %s (enumeral)\n")
3730 : _("[%d] %s at ?\n"),
3732 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3736 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3739 for (i
= 0; i
< n_chosen
; i
+= 1)
3740 syms
[i
] = syms
[chosen
[i
]];
3745 /* Read and validate a set of numeric choices from the user in the
3746 range 0 .. N_CHOICES-1. Place the results in increasing
3747 order in CHOICES[0 .. N-1], and return N.
3749 The user types choices as a sequence of numbers on one line
3750 separated by blanks, encoding them as follows:
3752 + A choice of 0 means to cancel the selection, throwing an error.
3753 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3754 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3756 The user is not allowed to choose more than MAX_RESULTS values.
3758 ANNOTATION_SUFFIX, if present, is used to annotate the input
3759 prompts (for use with the -f switch). */
3762 get_selections (int *choices
, int n_choices
, int max_results
,
3763 int is_all_choice
, char *annotation_suffix
)
3768 int first_choice
= is_all_choice
? 2 : 1;
3770 prompt
= getenv ("PS2");
3774 args
= command_line_input (prompt
, 0, annotation_suffix
);
3777 error_no_arg (_("one or more choice numbers"));
3781 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3782 order, as given in args. Choices are validated. */
3788 args
= skip_spaces (args
);
3789 if (*args
== '\0' && n_chosen
== 0)
3790 error_no_arg (_("one or more choice numbers"));
3791 else if (*args
== '\0')
3794 choice
= strtol (args
, &args2
, 10);
3795 if (args
== args2
|| choice
< 0
3796 || choice
> n_choices
+ first_choice
- 1)
3797 error (_("Argument must be choice number"));
3801 error (_("cancelled"));
3803 if (choice
< first_choice
)
3805 n_chosen
= n_choices
;
3806 for (j
= 0; j
< n_choices
; j
+= 1)
3810 choice
-= first_choice
;
3812 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3816 if (j
< 0 || choice
!= choices
[j
])
3820 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3821 choices
[k
+ 1] = choices
[k
];
3822 choices
[j
+ 1] = choice
;
3827 if (n_chosen
> max_results
)
3828 error (_("Select no more than %d of the above"), max_results
);
3833 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3834 on the function identified by SYM and BLOCK, and taking NARGS
3835 arguments. Update *EXPP as needed to hold more space. */
3838 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3839 int oplen
, struct symbol
*sym
,
3840 const struct block
*block
)
3842 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3843 symbol, -oplen for operator being replaced). */
3844 struct expression
*newexp
= (struct expression
*)
3845 xzalloc (sizeof (struct expression
)
3846 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3847 struct expression
*exp
= *expp
;
3849 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3850 newexp
->language_defn
= exp
->language_defn
;
3851 newexp
->gdbarch
= exp
->gdbarch
;
3852 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3853 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3854 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3856 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3857 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3859 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3860 newexp
->elts
[pc
+ 4].block
= block
;
3861 newexp
->elts
[pc
+ 5].symbol
= sym
;
3867 /* Type-class predicates */
3869 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3873 numeric_type_p (struct type
*type
)
3879 switch (TYPE_CODE (type
))
3884 case TYPE_CODE_RANGE
:
3885 return (type
== TYPE_TARGET_TYPE (type
)
3886 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3893 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3896 integer_type_p (struct type
*type
)
3902 switch (TYPE_CODE (type
))
3906 case TYPE_CODE_RANGE
:
3907 return (type
== TYPE_TARGET_TYPE (type
)
3908 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3915 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3918 scalar_type_p (struct type
*type
)
3924 switch (TYPE_CODE (type
))
3927 case TYPE_CODE_RANGE
:
3928 case TYPE_CODE_ENUM
:
3937 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3940 discrete_type_p (struct type
*type
)
3946 switch (TYPE_CODE (type
))
3949 case TYPE_CODE_RANGE
:
3950 case TYPE_CODE_ENUM
:
3951 case TYPE_CODE_BOOL
:
3959 /* Returns non-zero if OP with operands in the vector ARGS could be
3960 a user-defined function. Errs on the side of pre-defined operators
3961 (i.e., result 0). */
3964 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3966 struct type
*type0
=
3967 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3968 struct type
*type1
=
3969 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3983 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3987 case BINOP_BITWISE_AND
:
3988 case BINOP_BITWISE_IOR
:
3989 case BINOP_BITWISE_XOR
:
3990 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3993 case BINOP_NOTEQUAL
:
3998 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
4001 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
4004 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
4008 case UNOP_LOGICAL_NOT
:
4010 return (!numeric_type_p (type0
));
4019 1. In the following, we assume that a renaming type's name may
4020 have an ___XD suffix. It would be nice if this went away at some
4022 2. We handle both the (old) purely type-based representation of
4023 renamings and the (new) variable-based encoding. At some point,
4024 it is devoutly to be hoped that the former goes away
4025 (FIXME: hilfinger-2007-07-09).
4026 3. Subprogram renamings are not implemented, although the XRS
4027 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4029 /* If SYM encodes a renaming,
4031 <renaming> renames <renamed entity>,
4033 sets *LEN to the length of the renamed entity's name,
4034 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4035 the string describing the subcomponent selected from the renamed
4036 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4037 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4038 are undefined). Otherwise, returns a value indicating the category
4039 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4040 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4041 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4042 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4043 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4044 may be NULL, in which case they are not assigned.
4046 [Currently, however, GCC does not generate subprogram renamings.] */
4048 enum ada_renaming_category
4049 ada_parse_renaming (struct symbol
*sym
,
4050 const char **renamed_entity
, int *len
,
4051 const char **renaming_expr
)
4053 enum ada_renaming_category kind
;
4058 return ADA_NOT_RENAMING
;
4059 switch (SYMBOL_CLASS (sym
))
4062 return ADA_NOT_RENAMING
;
4064 return parse_old_style_renaming (SYMBOL_TYPE (sym
),
4065 renamed_entity
, len
, renaming_expr
);
4069 case LOC_OPTIMIZED_OUT
:
4070 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
4072 return ADA_NOT_RENAMING
;
4076 kind
= ADA_OBJECT_RENAMING
;
4080 kind
= ADA_EXCEPTION_RENAMING
;
4084 kind
= ADA_PACKAGE_RENAMING
;
4088 kind
= ADA_SUBPROGRAM_RENAMING
;
4092 return ADA_NOT_RENAMING
;
4096 if (renamed_entity
!= NULL
)
4097 *renamed_entity
= info
;
4098 suffix
= strstr (info
, "___XE");
4099 if (suffix
== NULL
|| suffix
== info
)
4100 return ADA_NOT_RENAMING
;
4102 *len
= strlen (info
) - strlen (suffix
);
4104 if (renaming_expr
!= NULL
)
4105 *renaming_expr
= suffix
;
4109 /* Assuming TYPE encodes a renaming according to the old encoding in
4110 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4111 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4112 ADA_NOT_RENAMING otherwise. */
4113 static enum ada_renaming_category
4114 parse_old_style_renaming (struct type
*type
,
4115 const char **renamed_entity
, int *len
,
4116 const char **renaming_expr
)
4118 enum ada_renaming_category kind
;
4123 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
4124 || TYPE_NFIELDS (type
) != 1)
4125 return ADA_NOT_RENAMING
;
4127 name
= type_name_no_tag (type
);
4129 return ADA_NOT_RENAMING
;
4131 name
= strstr (name
, "___XR");
4133 return ADA_NOT_RENAMING
;
4138 kind
= ADA_OBJECT_RENAMING
;
4141 kind
= ADA_EXCEPTION_RENAMING
;
4144 kind
= ADA_PACKAGE_RENAMING
;
4147 kind
= ADA_SUBPROGRAM_RENAMING
;
4150 return ADA_NOT_RENAMING
;
4153 info
= TYPE_FIELD_NAME (type
, 0);
4155 return ADA_NOT_RENAMING
;
4156 if (renamed_entity
!= NULL
)
4157 *renamed_entity
= info
;
4158 suffix
= strstr (info
, "___XE");
4159 if (renaming_expr
!= NULL
)
4160 *renaming_expr
= suffix
+ 5;
4161 if (suffix
== NULL
|| suffix
== info
)
4162 return ADA_NOT_RENAMING
;
4164 *len
= suffix
- info
;
4168 /* Compute the value of the given RENAMING_SYM, which is expected to
4169 be a symbol encoding a renaming expression. BLOCK is the block
4170 used to evaluate the renaming. */
4172 static struct value
*
4173 ada_read_renaming_var_value (struct symbol
*renaming_sym
,
4174 const struct block
*block
)
4176 const char *sym_name
;
4177 struct expression
*expr
;
4178 struct value
*value
;
4179 struct cleanup
*old_chain
= NULL
;
4181 sym_name
= SYMBOL_LINKAGE_NAME (renaming_sym
);
4182 expr
= parse_exp_1 (&sym_name
, 0, block
, 0);
4183 old_chain
= make_cleanup (free_current_contents
, &expr
);
4184 value
= evaluate_expression (expr
);
4186 do_cleanups (old_chain
);
4191 /* Evaluation: Function Calls */
4193 /* Return an lvalue containing the value VAL. This is the identity on
4194 lvalues, and otherwise has the side-effect of allocating memory
4195 in the inferior where a copy of the value contents is copied. */
4197 static struct value
*
4198 ensure_lval (struct value
*val
)
4200 if (VALUE_LVAL (val
) == not_lval
4201 || VALUE_LVAL (val
) == lval_internalvar
)
4203 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
4204 const CORE_ADDR addr
=
4205 value_as_long (value_allocate_space_in_inferior (len
));
4207 set_value_address (val
, addr
);
4208 VALUE_LVAL (val
) = lval_memory
;
4209 write_memory (addr
, value_contents (val
), len
);
4215 /* Return the value ACTUAL, converted to be an appropriate value for a
4216 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4217 allocating any necessary descriptors (fat pointers), or copies of
4218 values not residing in memory, updating it as needed. */
4221 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
)
4223 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
4224 struct type
*formal_type
= ada_check_typedef (formal_type0
);
4225 struct type
*formal_target
=
4226 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4227 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
4228 struct type
*actual_target
=
4229 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
4230 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
4232 if (ada_is_array_descriptor_type (formal_target
)
4233 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
4234 return make_array_descriptor (formal_type
, actual
);
4235 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
4236 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
4238 struct value
*result
;
4240 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
4241 && ada_is_array_descriptor_type (actual_target
))
4242 result
= desc_data (actual
);
4243 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
4245 if (VALUE_LVAL (actual
) != lval_memory
)
4249 actual_type
= ada_check_typedef (value_type (actual
));
4250 val
= allocate_value (actual_type
);
4251 memcpy ((char *) value_contents_raw (val
),
4252 (char *) value_contents (actual
),
4253 TYPE_LENGTH (actual_type
));
4254 actual
= ensure_lval (val
);
4256 result
= value_addr (actual
);
4260 return value_cast_pointers (formal_type
, result
, 0);
4262 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
4263 return ada_value_ind (actual
);
4268 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4269 type TYPE. This is usually an inefficient no-op except on some targets
4270 (such as AVR) where the representation of a pointer and an address
4274 value_pointer (struct value
*value
, struct type
*type
)
4276 struct gdbarch
*gdbarch
= get_type_arch (type
);
4277 unsigned len
= TYPE_LENGTH (type
);
4278 gdb_byte
*buf
= alloca (len
);
4281 addr
= value_address (value
);
4282 gdbarch_address_to_pointer (gdbarch
, type
, buf
, addr
);
4283 addr
= extract_unsigned_integer (buf
, len
, gdbarch_byte_order (gdbarch
));
4288 /* Push a descriptor of type TYPE for array value ARR on the stack at
4289 *SP, updating *SP to reflect the new descriptor. Return either
4290 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4291 to-descriptor type rather than a descriptor type), a struct value *
4292 representing a pointer to this descriptor. */
4294 static struct value
*
4295 make_array_descriptor (struct type
*type
, struct value
*arr
)
4297 struct type
*bounds_type
= desc_bounds_type (type
);
4298 struct type
*desc_type
= desc_base_type (type
);
4299 struct value
*descriptor
= allocate_value (desc_type
);
4300 struct value
*bounds
= allocate_value (bounds_type
);
4303 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
)));
4306 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4307 ada_array_bound (arr
, i
, 0),
4308 desc_bound_bitpos (bounds_type
, i
, 0),
4309 desc_bound_bitsize (bounds_type
, i
, 0));
4310 modify_field (value_type (bounds
), value_contents_writeable (bounds
),
4311 ada_array_bound (arr
, i
, 1),
4312 desc_bound_bitpos (bounds_type
, i
, 1),
4313 desc_bound_bitsize (bounds_type
, i
, 1));
4316 bounds
= ensure_lval (bounds
);
4318 modify_field (value_type (descriptor
),
4319 value_contents_writeable (descriptor
),
4320 value_pointer (ensure_lval (arr
),
4321 TYPE_FIELD_TYPE (desc_type
, 0)),
4322 fat_pntr_data_bitpos (desc_type
),
4323 fat_pntr_data_bitsize (desc_type
));
4325 modify_field (value_type (descriptor
),
4326 value_contents_writeable (descriptor
),
4327 value_pointer (bounds
,
4328 TYPE_FIELD_TYPE (desc_type
, 1)),
4329 fat_pntr_bounds_bitpos (desc_type
),
4330 fat_pntr_bounds_bitsize (desc_type
));
4332 descriptor
= ensure_lval (descriptor
);
4334 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
4335 return value_addr (descriptor
);
4340 /* Symbol Cache Module */
4342 /* Performance measurements made as of 2010-01-15 indicate that
4343 this cache does bring some noticeable improvements. Depending
4344 on the type of entity being printed, the cache can make it as much
4345 as an order of magnitude faster than without it.
4347 The descriptive type DWARF extension has significantly reduced
4348 the need for this cache, at least when DWARF is being used. However,
4349 even in this case, some expensive name-based symbol searches are still
4350 sometimes necessary - to find an XVZ variable, mostly. */
4352 /* Initialize the contents of SYM_CACHE. */
4355 ada_init_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4357 obstack_init (&sym_cache
->cache_space
);
4358 memset (sym_cache
->root
, '\000', sizeof (sym_cache
->root
));
4361 /* Free the memory used by SYM_CACHE. */
4364 ada_free_symbol_cache (struct ada_symbol_cache
*sym_cache
)
4366 obstack_free (&sym_cache
->cache_space
, NULL
);
4370 /* Return the symbol cache associated to the given program space PSPACE.
4371 If not allocated for this PSPACE yet, allocate and initialize one. */
4373 static struct ada_symbol_cache
*
4374 ada_get_symbol_cache (struct program_space
*pspace
)
4376 struct ada_pspace_data
*pspace_data
= get_ada_pspace_data (pspace
);
4377 struct ada_symbol_cache
*sym_cache
= pspace_data
->sym_cache
;
4379 if (sym_cache
== NULL
)
4381 sym_cache
= XCNEW (struct ada_symbol_cache
);
4382 ada_init_symbol_cache (sym_cache
);
4388 /* Clear all entries from the symbol cache. */
4391 ada_clear_symbol_cache (void)
4393 struct ada_symbol_cache
*sym_cache
4394 = ada_get_symbol_cache (current_program_space
);
4396 obstack_free (&sym_cache
->cache_space
, NULL
);
4397 ada_init_symbol_cache (sym_cache
);
4400 /* Search our cache for an entry matching NAME and NAMESPACE.
4401 Return it if found, or NULL otherwise. */
4403 static struct cache_entry
**
4404 find_entry (const char *name
, domain_enum
namespace)
4406 struct ada_symbol_cache
*sym_cache
4407 = ada_get_symbol_cache (current_program_space
);
4408 int h
= msymbol_hash (name
) % HASH_SIZE
;
4409 struct cache_entry
**e
;
4411 for (e
= &sym_cache
->root
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
4413 if (namespace == (*e
)->namespace && strcmp (name
, (*e
)->name
) == 0)
4419 /* Search the symbol cache for an entry matching NAME and NAMESPACE.
4420 Return 1 if found, 0 otherwise.
4422 If an entry was found and SYM is not NULL, set *SYM to the entry's
4423 SYM. Same principle for BLOCK if not NULL. */
4426 lookup_cached_symbol (const char *name
, domain_enum
namespace,
4427 struct symbol
**sym
, const struct block
**block
)
4429 struct cache_entry
**e
= find_entry (name
, namespace);
4436 *block
= (*e
)->block
;
4440 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4441 in domain NAMESPACE, save this result in our symbol cache. */
4444 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
4445 const struct block
*block
)
4447 struct ada_symbol_cache
*sym_cache
4448 = ada_get_symbol_cache (current_program_space
);
4451 struct cache_entry
*e
;
4453 /* If the symbol is a local symbol, then do not cache it, as a search
4454 for that symbol depends on the context. To determine whether
4455 the symbol is local or not, we check the block where we found it
4456 against the global and static blocks of its associated symtab. */
4458 && BLOCKVECTOR_BLOCK (BLOCKVECTOR (sym
->symtab
), GLOBAL_BLOCK
) != block
4459 && BLOCKVECTOR_BLOCK (BLOCKVECTOR (sym
->symtab
), STATIC_BLOCK
) != block
)
4462 h
= msymbol_hash (name
) % HASH_SIZE
;
4463 e
= (struct cache_entry
*) obstack_alloc (&sym_cache
->cache_space
,
4465 e
->next
= sym_cache
->root
[h
];
4466 sym_cache
->root
[h
] = e
;
4467 e
->name
= copy
= obstack_alloc (&sym_cache
->cache_space
, strlen (name
) + 1);
4468 strcpy (copy
, name
);
4470 e
->namespace = namespace;
4476 /* Return nonzero if wild matching should be used when searching for
4477 all symbols matching LOOKUP_NAME.
4479 LOOKUP_NAME is expected to be a symbol name after transformation
4480 for Ada lookups (see ada_name_for_lookup). */
4483 should_use_wild_match (const char *lookup_name
)
4485 return (strstr (lookup_name
, "__") == NULL
);
4488 /* Return the result of a standard (literal, C-like) lookup of NAME in
4489 given DOMAIN, visible from lexical block BLOCK. */
4491 static struct symbol
*
4492 standard_lookup (const char *name
, const struct block
*block
,
4495 /* Initialize it just to avoid a GCC false warning. */
4496 struct symbol
*sym
= NULL
;
4498 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
))
4500 sym
= lookup_symbol_in_language (name
, block
, domain
, language_c
, 0);
4501 cache_symbol (name
, domain
, sym
, block_found
);
4506 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4507 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4508 since they contend in overloading in the same way. */
4510 is_nonfunction (struct ada_symbol_info syms
[], int n
)
4514 for (i
= 0; i
< n
; i
+= 1)
4515 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
4516 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
4517 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
4523 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4524 struct types. Otherwise, they may not. */
4527 equiv_types (struct type
*type0
, struct type
*type1
)
4531 if (type0
== NULL
|| type1
== NULL
4532 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
4534 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
4535 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
4536 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4537 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4543 /* True iff SYM0 represents the same entity as SYM1, or one that is
4544 no more defined than that of SYM1. */
4547 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4551 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4552 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4555 switch (SYMBOL_CLASS (sym0
))
4561 struct type
*type0
= SYMBOL_TYPE (sym0
);
4562 struct type
*type1
= SYMBOL_TYPE (sym1
);
4563 const char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4564 const char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4565 int len0
= strlen (name0
);
4568 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4569 && (equiv_types (type0
, type1
)
4570 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4571 && strncmp (name1
+ len0
, "___XV", 5) == 0));
4574 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4575 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4581 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4582 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4585 add_defn_to_vec (struct obstack
*obstackp
,
4587 const struct block
*block
)
4590 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
4592 /* Do not try to complete stub types, as the debugger is probably
4593 already scanning all symbols matching a certain name at the
4594 time when this function is called. Trying to replace the stub
4595 type by its associated full type will cause us to restart a scan
4596 which may lead to an infinite recursion. Instead, the client
4597 collecting the matching symbols will end up collecting several
4598 matches, with at least one of them complete. It can then filter
4599 out the stub ones if needed. */
4601 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4603 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
4605 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
4607 prevDefns
[i
].sym
= sym
;
4608 prevDefns
[i
].block
= block
;
4614 struct ada_symbol_info info
;
4618 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
4622 /* Number of ada_symbol_info structures currently collected in
4623 current vector in *OBSTACKP. */
4626 num_defns_collected (struct obstack
*obstackp
)
4628 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
4631 /* Vector of ada_symbol_info structures currently collected in current
4632 vector in *OBSTACKP. If FINISH, close off the vector and return
4633 its final address. */
4635 static struct ada_symbol_info
*
4636 defns_collected (struct obstack
*obstackp
, int finish
)
4639 return obstack_finish (obstackp
);
4641 return (struct ada_symbol_info
*) obstack_base (obstackp
);
4644 /* Return a bound minimal symbol matching NAME according to Ada
4645 decoding rules. Returns an invalid symbol if there is no such
4646 minimal symbol. Names prefixed with "standard__" are handled
4647 specially: "standard__" is first stripped off, and only static and
4648 global symbols are searched. */
4650 struct bound_minimal_symbol
4651 ada_lookup_simple_minsym (const char *name
)
4653 struct bound_minimal_symbol result
;
4654 struct objfile
*objfile
;
4655 struct minimal_symbol
*msymbol
;
4656 const int wild_match_p
= should_use_wild_match (name
);
4658 memset (&result
, 0, sizeof (result
));
4660 /* Special case: If the user specifies a symbol name inside package
4661 Standard, do a non-wild matching of the symbol name without
4662 the "standard__" prefix. This was primarily introduced in order
4663 to allow the user to specifically access the standard exceptions
4664 using, for instance, Standard.Constraint_Error when Constraint_Error
4665 is ambiguous (due to the user defining its own Constraint_Error
4666 entity inside its program). */
4667 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4668 name
+= sizeof ("standard__") - 1;
4670 ALL_MSYMBOLS (objfile
, msymbol
)
4672 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match_p
)
4673 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4675 result
.minsym
= msymbol
;
4676 result
.objfile
= objfile
;
4684 /* For all subprograms that statically enclose the subprogram of the
4685 selected frame, add symbols matching identifier NAME in DOMAIN
4686 and their blocks to the list of data in OBSTACKP, as for
4687 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4688 with a wildcard prefix. */
4691 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4692 const char *name
, domain_enum
namespace,
4697 /* True if TYPE is definitely an artificial type supplied to a symbol
4698 for which no debugging information was given in the symbol file. */
4701 is_nondebugging_type (struct type
*type
)
4703 const char *name
= ada_type_name (type
);
4705 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4708 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4709 that are deemed "identical" for practical purposes.
4711 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4712 types and that their number of enumerals is identical (in other
4713 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4716 ada_identical_enum_types_p (struct type
*type1
, struct type
*type2
)
4720 /* The heuristic we use here is fairly conservative. We consider
4721 that 2 enumerate types are identical if they have the same
4722 number of enumerals and that all enumerals have the same
4723 underlying value and name. */
4725 /* All enums in the type should have an identical underlying value. */
4726 for (i
= 0; i
< TYPE_NFIELDS (type1
); i
++)
4727 if (TYPE_FIELD_ENUMVAL (type1
, i
) != TYPE_FIELD_ENUMVAL (type2
, i
))
4730 /* All enumerals should also have the same name (modulo any numerical
4732 for (i
= 0; i
< TYPE_NFIELDS (type1
); i
++)
4734 const char *name_1
= TYPE_FIELD_NAME (type1
, i
);
4735 const char *name_2
= TYPE_FIELD_NAME (type2
, i
);
4736 int len_1
= strlen (name_1
);
4737 int len_2
= strlen (name_2
);
4739 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1
, i
), &len_1
);
4740 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2
, i
), &len_2
);
4742 || strncmp (TYPE_FIELD_NAME (type1
, i
),
4743 TYPE_FIELD_NAME (type2
, i
),
4751 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4752 that are deemed "identical" for practical purposes. Sometimes,
4753 enumerals are not strictly identical, but their types are so similar
4754 that they can be considered identical.
4756 For instance, consider the following code:
4758 type Color is (Black, Red, Green, Blue, White);
4759 type RGB_Color is new Color range Red .. Blue;
4761 Type RGB_Color is a subrange of an implicit type which is a copy
4762 of type Color. If we call that implicit type RGB_ColorB ("B" is
4763 for "Base Type"), then type RGB_ColorB is a copy of type Color.
4764 As a result, when an expression references any of the enumeral
4765 by name (Eg. "print green"), the expression is technically
4766 ambiguous and the user should be asked to disambiguate. But
4767 doing so would only hinder the user, since it wouldn't matter
4768 what choice he makes, the outcome would always be the same.
4769 So, for practical purposes, we consider them as the same. */
4772 symbols_are_identical_enums (struct ada_symbol_info
*syms
, int nsyms
)
4776 /* Before performing a thorough comparison check of each type,
4777 we perform a series of inexpensive checks. We expect that these
4778 checks will quickly fail in the vast majority of cases, and thus
4779 help prevent the unnecessary use of a more expensive comparison.
4780 Said comparison also expects us to make some of these checks
4781 (see ada_identical_enum_types_p). */
4783 /* Quick check: All symbols should have an enum type. */
4784 for (i
= 0; i
< nsyms
; i
++)
4785 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
)
4788 /* Quick check: They should all have the same value. */
4789 for (i
= 1; i
< nsyms
; i
++)
4790 if (SYMBOL_VALUE (syms
[i
].sym
) != SYMBOL_VALUE (syms
[0].sym
))
4793 /* Quick check: They should all have the same number of enumerals. */
4794 for (i
= 1; i
< nsyms
; i
++)
4795 if (TYPE_NFIELDS (SYMBOL_TYPE (syms
[i
].sym
))
4796 != TYPE_NFIELDS (SYMBOL_TYPE (syms
[0].sym
)))
4799 /* All the sanity checks passed, so we might have a set of
4800 identical enumeration types. Perform a more complete
4801 comparison of the type of each symbol. */
4802 for (i
= 1; i
< nsyms
; i
++)
4803 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms
[i
].sym
),
4804 SYMBOL_TYPE (syms
[0].sym
)))
4810 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4811 duplicate other symbols in the list (The only case I know of where
4812 this happens is when object files containing stabs-in-ecoff are
4813 linked with files containing ordinary ecoff debugging symbols (or no
4814 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4815 Returns the number of items in the modified list. */
4818 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4822 /* We should never be called with less than 2 symbols, as there
4823 cannot be any extra symbol in that case. But it's easy to
4824 handle, since we have nothing to do in that case. */
4833 /* If two symbols have the same name and one of them is a stub type,
4834 the get rid of the stub. */
4836 if (TYPE_STUB (SYMBOL_TYPE (syms
[i
].sym
))
4837 && SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
)
4839 for (j
= 0; j
< nsyms
; j
++)
4842 && !TYPE_STUB (SYMBOL_TYPE (syms
[j
].sym
))
4843 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4844 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4845 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0)
4850 /* Two symbols with the same name, same class and same address
4851 should be identical. */
4853 else if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4854 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4855 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4857 for (j
= 0; j
< nsyms
; j
+= 1)
4860 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4861 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4862 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4863 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4864 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4865 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4872 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4873 syms
[j
- 1] = syms
[j
];
4880 /* If all the remaining symbols are identical enumerals, then
4881 just keep the first one and discard the rest.
4883 Unlike what we did previously, we do not discard any entry
4884 unless they are ALL identical. This is because the symbol
4885 comparison is not a strict comparison, but rather a practical
4886 comparison. If all symbols are considered identical, then
4887 we can just go ahead and use the first one and discard the rest.
4888 But if we cannot reduce the list to a single element, we have
4889 to ask the user to disambiguate anyways. And if we have to
4890 present a multiple-choice menu, it's less confusing if the list
4891 isn't missing some choices that were identical and yet distinct. */
4892 if (symbols_are_identical_enums (syms
, nsyms
))
4898 /* Given a type that corresponds to a renaming entity, use the type name
4899 to extract the scope (package name or function name, fully qualified,
4900 and following the GNAT encoding convention) where this renaming has been
4901 defined. The string returned needs to be deallocated after use. */
4904 xget_renaming_scope (struct type
*renaming_type
)
4906 /* The renaming types adhere to the following convention:
4907 <scope>__<rename>___<XR extension>.
4908 So, to extract the scope, we search for the "___XR" extension,
4909 and then backtrack until we find the first "__". */
4911 const char *name
= type_name_no_tag (renaming_type
);
4912 char *suffix
= strstr (name
, "___XR");
4917 /* Now, backtrack a bit until we find the first "__". Start looking
4918 at suffix - 3, as the <rename> part is at least one character long. */
4920 for (last
= suffix
- 3; last
> name
; last
--)
4921 if (last
[0] == '_' && last
[1] == '_')
4924 /* Make a copy of scope and return it. */
4926 scope_len
= last
- name
;
4927 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4929 strncpy (scope
, name
, scope_len
);
4930 scope
[scope_len
] = '\0';
4935 /* Return nonzero if NAME corresponds to a package name. */
4938 is_package_name (const char *name
)
4940 /* Here, We take advantage of the fact that no symbols are generated
4941 for packages, while symbols are generated for each function.
4942 So the condition for NAME represent a package becomes equivalent
4943 to NAME not existing in our list of symbols. There is only one
4944 small complication with library-level functions (see below). */
4948 /* If it is a function that has not been defined at library level,
4949 then we should be able to look it up in the symbols. */
4950 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4953 /* Library-level function names start with "_ada_". See if function
4954 "_ada_" followed by NAME can be found. */
4956 /* Do a quick check that NAME does not contain "__", since library-level
4957 functions names cannot contain "__" in them. */
4958 if (strstr (name
, "__") != NULL
)
4961 fun_name
= xstrprintf ("_ada_%s", name
);
4963 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4966 /* Return nonzero if SYM corresponds to a renaming entity that is
4967 not visible from FUNCTION_NAME. */
4970 old_renaming_is_invisible (const struct symbol
*sym
, const char *function_name
)
4973 struct cleanup
*old_chain
;
4975 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
4978 scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4979 old_chain
= make_cleanup (xfree
, scope
);
4981 /* If the rename has been defined in a package, then it is visible. */
4982 if (is_package_name (scope
))
4984 do_cleanups (old_chain
);
4988 /* Check that the rename is in the current function scope by checking
4989 that its name starts with SCOPE. */
4991 /* If the function name starts with "_ada_", it means that it is
4992 a library-level function. Strip this prefix before doing the
4993 comparison, as the encoding for the renaming does not contain
4995 if (strncmp (function_name
, "_ada_", 5) == 0)
4999 int is_invisible
= strncmp (function_name
, scope
, strlen (scope
)) != 0;
5001 do_cleanups (old_chain
);
5002 return is_invisible
;
5006 /* Remove entries from SYMS that corresponds to a renaming entity that
5007 is not visible from the function associated with CURRENT_BLOCK or
5008 that is superfluous due to the presence of more specific renaming
5009 information. Places surviving symbols in the initial entries of
5010 SYMS and returns the number of surviving symbols.
5013 First, in cases where an object renaming is implemented as a
5014 reference variable, GNAT may produce both the actual reference
5015 variable and the renaming encoding. In this case, we discard the
5018 Second, GNAT emits a type following a specified encoding for each renaming
5019 entity. Unfortunately, STABS currently does not support the definition
5020 of types that are local to a given lexical block, so all renamings types
5021 are emitted at library level. As a consequence, if an application
5022 contains two renaming entities using the same name, and a user tries to
5023 print the value of one of these entities, the result of the ada symbol
5024 lookup will also contain the wrong renaming type.
5026 This function partially covers for this limitation by attempting to
5027 remove from the SYMS list renaming symbols that should be visible
5028 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5029 method with the current information available. The implementation
5030 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5032 - When the user tries to print a rename in a function while there
5033 is another rename entity defined in a package: Normally, the
5034 rename in the function has precedence over the rename in the
5035 package, so the latter should be removed from the list. This is
5036 currently not the case.
5038 - This function will incorrectly remove valid renames if
5039 the CURRENT_BLOCK corresponds to a function which symbol name
5040 has been changed by an "Export" pragma. As a consequence,
5041 the user will be unable to print such rename entities. */
5044 remove_irrelevant_renamings (struct ada_symbol_info
*syms
,
5045 int nsyms
, const struct block
*current_block
)
5047 struct symbol
*current_function
;
5048 const char *current_function_name
;
5050 int is_new_style_renaming
;
5052 /* If there is both a renaming foo___XR... encoded as a variable and
5053 a simple variable foo in the same block, discard the latter.
5054 First, zero out such symbols, then compress. */
5055 is_new_style_renaming
= 0;
5056 for (i
= 0; i
< nsyms
; i
+= 1)
5058 struct symbol
*sym
= syms
[i
].sym
;
5059 const struct block
*block
= syms
[i
].block
;
5063 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5065 name
= SYMBOL_LINKAGE_NAME (sym
);
5066 suffix
= strstr (name
, "___XR");
5070 int name_len
= suffix
- name
;
5073 is_new_style_renaming
= 1;
5074 for (j
= 0; j
< nsyms
; j
+= 1)
5075 if (i
!= j
&& syms
[j
].sym
!= NULL
5076 && strncmp (name
, SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
5078 && block
== syms
[j
].block
)
5082 if (is_new_style_renaming
)
5086 for (j
= k
= 0; j
< nsyms
; j
+= 1)
5087 if (syms
[j
].sym
!= NULL
)
5095 /* Extract the function name associated to CURRENT_BLOCK.
5096 Abort if unable to do so. */
5098 if (current_block
== NULL
)
5101 current_function
= block_linkage_function (current_block
);
5102 if (current_function
== NULL
)
5105 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
5106 if (current_function_name
== NULL
)
5109 /* Check each of the symbols, and remove it from the list if it is
5110 a type corresponding to a renaming that is out of the scope of
5111 the current block. */
5116 if (ada_parse_renaming (syms
[i
].sym
, NULL
, NULL
, NULL
)
5117 == ADA_OBJECT_RENAMING
5118 && old_renaming_is_invisible (syms
[i
].sym
, current_function_name
))
5122 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
5123 syms
[j
- 1] = syms
[j
];
5133 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5134 whose name and domain match NAME and DOMAIN respectively.
5135 If no match was found, then extend the search to "enclosing"
5136 routines (in other words, if we're inside a nested function,
5137 search the symbols defined inside the enclosing functions).
5138 If WILD_MATCH_P is nonzero, perform the naming matching in
5139 "wild" mode (see function "wild_match" for more info).
5141 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5144 ada_add_local_symbols (struct obstack
*obstackp
, const char *name
,
5145 const struct block
*block
, domain_enum domain
,
5148 int block_depth
= 0;
5150 while (block
!= NULL
)
5153 ada_add_block_symbols (obstackp
, block
, name
, domain
, NULL
,
5156 /* If we found a non-function match, assume that's the one. */
5157 if (is_nonfunction (defns_collected (obstackp
, 0),
5158 num_defns_collected (obstackp
)))
5161 block
= BLOCK_SUPERBLOCK (block
);
5164 /* If no luck so far, try to find NAME as a local symbol in some lexically
5165 enclosing subprogram. */
5166 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
5167 add_symbols_from_enclosing_procs (obstackp
, name
, domain
, wild_match_p
);
5170 /* An object of this type is used as the user_data argument when
5171 calling the map_matching_symbols method. */
5175 struct objfile
*objfile
;
5176 struct obstack
*obstackp
;
5177 struct symbol
*arg_sym
;
5181 /* A callback for add_matching_symbols that adds SYM, found in BLOCK,
5182 to a list of symbols. DATA0 is a pointer to a struct match_data *
5183 containing the obstack that collects the symbol list, the file that SYM
5184 must come from, a flag indicating whether a non-argument symbol has
5185 been found in the current block, and the last argument symbol
5186 passed in SYM within the current block (if any). When SYM is null,
5187 marking the end of a block, the argument symbol is added if no
5188 other has been found. */
5191 aux_add_nonlocal_symbols (struct block
*block
, struct symbol
*sym
, void *data0
)
5193 struct match_data
*data
= (struct match_data
*) data0
;
5197 if (!data
->found_sym
&& data
->arg_sym
!= NULL
)
5198 add_defn_to_vec (data
->obstackp
,
5199 fixup_symbol_section (data
->arg_sym
, data
->objfile
),
5201 data
->found_sym
= 0;
5202 data
->arg_sym
= NULL
;
5206 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5208 else if (SYMBOL_IS_ARGUMENT (sym
))
5209 data
->arg_sym
= sym
;
5212 data
->found_sym
= 1;
5213 add_defn_to_vec (data
->obstackp
,
5214 fixup_symbol_section (sym
, data
->objfile
),
5221 /* Implements compare_names, but only applying the comparision using
5222 the given CASING. */
5225 compare_names_with_case (const char *string1
, const char *string2
,
5226 enum case_sensitivity casing
)
5228 while (*string1
!= '\0' && *string2
!= '\0')
5232 if (isspace (*string1
) || isspace (*string2
))
5233 return strcmp_iw_ordered (string1
, string2
);
5235 if (casing
== case_sensitive_off
)
5237 c1
= tolower (*string1
);
5238 c2
= tolower (*string2
);
5255 return strcmp_iw_ordered (string1
, string2
);
5257 if (*string2
== '\0')
5259 if (is_name_suffix (string1
))
5266 if (*string2
== '(')
5267 return strcmp_iw_ordered (string1
, string2
);
5270 if (casing
== case_sensitive_off
)
5271 return tolower (*string1
) - tolower (*string2
);
5273 return *string1
- *string2
;
5278 /* Compare STRING1 to STRING2, with results as for strcmp.
5279 Compatible with strcmp_iw_ordered in that...
5281 strcmp_iw_ordered (STRING1, STRING2) <= 0
5285 compare_names (STRING1, STRING2) <= 0
5287 (they may differ as to what symbols compare equal). */
5290 compare_names (const char *string1
, const char *string2
)
5294 /* Similar to what strcmp_iw_ordered does, we need to perform
5295 a case-insensitive comparison first, and only resort to
5296 a second, case-sensitive, comparison if the first one was
5297 not sufficient to differentiate the two strings. */
5299 result
= compare_names_with_case (string1
, string2
, case_sensitive_off
);
5301 result
= compare_names_with_case (string1
, string2
, case_sensitive_on
);
5306 /* Add to OBSTACKP all non-local symbols whose name and domain match
5307 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5308 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5311 add_nonlocal_symbols (struct obstack
*obstackp
, const char *name
,
5312 domain_enum domain
, int global
,
5315 struct objfile
*objfile
;
5316 struct match_data data
;
5318 memset (&data
, 0, sizeof data
);
5319 data
.obstackp
= obstackp
;
5321 ALL_OBJFILES (objfile
)
5323 data
.objfile
= objfile
;
5326 objfile
->sf
->qf
->map_matching_symbols (objfile
, name
, domain
, global
,
5327 aux_add_nonlocal_symbols
, &data
,
5330 objfile
->sf
->qf
->map_matching_symbols (objfile
, name
, domain
, global
,
5331 aux_add_nonlocal_symbols
, &data
,
5332 full_match
, compare_names
);
5335 if (num_defns_collected (obstackp
) == 0 && global
&& !is_wild_match
)
5337 ALL_OBJFILES (objfile
)
5339 char *name1
= alloca (strlen (name
) + sizeof ("_ada_"));
5340 strcpy (name1
, "_ada_");
5341 strcpy (name1
+ sizeof ("_ada_") - 1, name
);
5342 data
.objfile
= objfile
;
5343 objfile
->sf
->qf
->map_matching_symbols (objfile
, name1
, domain
,
5345 aux_add_nonlocal_symbols
,
5347 full_match
, compare_names
);
5352 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is
5353 non-zero, enclosing scope and in global scopes, returning the number of
5355 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
5356 indicating the symbols found and the blocks and symbol tables (if
5357 any) in which they were found. This vector is transient---good only to
5358 the next call of ada_lookup_symbol_list.
5360 When full_search is non-zero, any non-function/non-enumeral
5361 symbol match within the nest of blocks whose innermost member is BLOCK0,
5362 is the one match returned (no other matches in that or
5363 enclosing blocks is returned). If there are any matches in or
5364 surrounding BLOCK0, then these alone are returned.
5366 Names prefixed with "standard__" are handled specially: "standard__"
5367 is first stripped off, and only static and global symbols are searched. */
5370 ada_lookup_symbol_list_worker (const char *name0
, const struct block
*block0
,
5371 domain_enum
namespace,
5372 struct ada_symbol_info
**results
,
5376 const struct block
*block
;
5378 const int wild_match_p
= should_use_wild_match (name0
);
5382 obstack_free (&symbol_list_obstack
, NULL
);
5383 obstack_init (&symbol_list_obstack
);
5387 /* Search specified block and its superiors. */
5392 /* Special case: If the user specifies a symbol name inside package
5393 Standard, do a non-wild matching of the symbol name without
5394 the "standard__" prefix. This was primarily introduced in order
5395 to allow the user to specifically access the standard exceptions
5396 using, for instance, Standard.Constraint_Error when Constraint_Error
5397 is ambiguous (due to the user defining its own Constraint_Error
5398 entity inside its program). */
5399 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
5402 name
= name0
+ sizeof ("standard__") - 1;
5405 /* Check the non-global symbols. If we have ANY match, then we're done. */
5411 ada_add_local_symbols (&symbol_list_obstack
, name
, block
,
5412 namespace, wild_match_p
);
5416 /* In the !full_search case we're are being called by
5417 ada_iterate_over_symbols, and we don't want to search
5419 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
5420 namespace, NULL
, wild_match_p
);
5422 if (num_defns_collected (&symbol_list_obstack
) > 0 || !full_search
)
5426 /* No non-global symbols found. Check our cache to see if we have
5427 already performed this search before. If we have, then return
5431 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
))
5434 add_defn_to_vec (&symbol_list_obstack
, sym
, block
);
5438 /* Search symbols from all global blocks. */
5440 add_nonlocal_symbols (&symbol_list_obstack
, name
, namespace, 1,
5443 /* Now add symbols from all per-file blocks if we've gotten no hits
5444 (not strictly correct, but perhaps better than an error). */
5446 if (num_defns_collected (&symbol_list_obstack
) == 0)
5447 add_nonlocal_symbols (&symbol_list_obstack
, name
, namespace, 0,
5451 ndefns
= num_defns_collected (&symbol_list_obstack
);
5452 *results
= defns_collected (&symbol_list_obstack
, 1);
5454 ndefns
= remove_extra_symbols (*results
, ndefns
);
5456 if (ndefns
== 0 && full_search
)
5457 cache_symbol (name0
, namespace, NULL
, NULL
);
5459 if (ndefns
== 1 && full_search
&& cacheIfUnique
)
5460 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
);
5462 ndefns
= remove_irrelevant_renamings (*results
, ndefns
, block0
);
5467 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5468 in global scopes, returning the number of matches, and setting *RESULTS
5469 to a vector of (SYM,BLOCK) tuples.
5470 See ada_lookup_symbol_list_worker for further details. */
5473 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
5474 domain_enum domain
, struct ada_symbol_info
**results
)
5476 return ada_lookup_symbol_list_worker (name0
, block0
, domain
, results
, 1);
5479 /* Implementation of the la_iterate_over_symbols method. */
5482 ada_iterate_over_symbols (const struct block
*block
,
5483 const char *name
, domain_enum domain
,
5484 symbol_found_callback_ftype
*callback
,
5488 struct ada_symbol_info
*results
;
5490 ndefs
= ada_lookup_symbol_list_worker (name
, block
, domain
, &results
, 0);
5491 for (i
= 0; i
< ndefs
; ++i
)
5493 if (! (*callback
) (results
[i
].sym
, data
))
5498 /* If NAME is the name of an entity, return a string that should
5499 be used to look that entity up in Ada units. This string should
5500 be deallocated after use using xfree.
5502 NAME can have any form that the "break" or "print" commands might
5503 recognize. In other words, it does not have to be the "natural"
5504 name, or the "encoded" name. */
5507 ada_name_for_lookup (const char *name
)
5510 int nlen
= strlen (name
);
5512 if (name
[0] == '<' && name
[nlen
- 1] == '>')
5514 canon
= xmalloc (nlen
- 1);
5515 memcpy (canon
, name
+ 1, nlen
- 2);
5516 canon
[nlen
- 2] = '\0';
5519 canon
= xstrdup (ada_encode (ada_fold_name (name
)));
5523 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5524 to 1, but choosing the first symbol found if there are multiple
5527 The result is stored in *INFO, which must be non-NULL.
5528 If no match is found, INFO->SYM is set to NULL. */
5531 ada_lookup_encoded_symbol (const char *name
, const struct block
*block
,
5532 domain_enum
namespace,
5533 struct ada_symbol_info
*info
)
5535 struct ada_symbol_info
*candidates
;
5538 gdb_assert (info
!= NULL
);
5539 memset (info
, 0, sizeof (struct ada_symbol_info
));
5541 n_candidates
= ada_lookup_symbol_list (name
, block
, namespace, &candidates
);
5542 if (n_candidates
== 0)
5545 *info
= candidates
[0];
5546 info
->sym
= fixup_symbol_section (info
->sym
, NULL
);
5549 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5550 scope and in global scopes, or NULL if none. NAME is folded and
5551 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5552 choosing the first symbol if there are multiple choices.
5553 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5556 ada_lookup_symbol (const char *name
, const struct block
*block0
,
5557 domain_enum
namespace, int *is_a_field_of_this
)
5559 struct ada_symbol_info info
;
5561 if (is_a_field_of_this
!= NULL
)
5562 *is_a_field_of_this
= 0;
5564 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name
)),
5565 block0
, namespace, &info
);
5569 static struct symbol
*
5570 ada_lookup_symbol_nonlocal (const char *name
,
5571 const struct block
*block
,
5572 const domain_enum domain
)
5574 return ada_lookup_symbol (name
, block_static_block (block
), domain
, NULL
);
5578 /* True iff STR is a possible encoded suffix of a normal Ada name
5579 that is to be ignored for matching purposes. Suffixes of parallel
5580 names (e.g., XVE) are not included here. Currently, the possible suffixes
5581 are given by any of the regular expressions:
5583 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5584 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5585 TKB [subprogram suffix for task bodies]
5586 _E[0-9]+[bs]$ [protected object entry suffixes]
5587 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5589 Also, any leading "__[0-9]+" sequence is skipped before the suffix
5590 match is performed. This sequence is used to differentiate homonyms,
5591 is an optional part of a valid name suffix. */
5594 is_name_suffix (const char *str
)
5597 const char *matching
;
5598 const int len
= strlen (str
);
5600 /* Skip optional leading __[0-9]+. */
5602 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
5605 while (isdigit (str
[0]))
5611 if (str
[0] == '.' || str
[0] == '$')
5614 while (isdigit (matching
[0]))
5616 if (matching
[0] == '\0')
5622 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
5625 while (isdigit (matching
[0]))
5627 if (matching
[0] == '\0')
5631 /* "TKB" suffixes are used for subprograms implementing task bodies. */
5633 if (strcmp (str
, "TKB") == 0)
5637 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5638 with a N at the end. Unfortunately, the compiler uses the same
5639 convention for other internal types it creates. So treating
5640 all entity names that end with an "N" as a name suffix causes
5641 some regressions. For instance, consider the case of an enumerated
5642 type. To support the 'Image attribute, it creates an array whose
5644 Having a single character like this as a suffix carrying some
5645 information is a bit risky. Perhaps we should change the encoding
5646 to be something like "_N" instead. In the meantime, do not do
5647 the following check. */
5648 /* Protected Object Subprograms */
5649 if (len
== 1 && str
[0] == 'N')
5654 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
5657 while (isdigit (matching
[0]))
5659 if ((matching
[0] == 'b' || matching
[0] == 's')
5660 && matching
[1] == '\0')
5664 /* ??? We should not modify STR directly, as we are doing below. This
5665 is fine in this case, but may become problematic later if we find
5666 that this alternative did not work, and want to try matching
5667 another one from the begining of STR. Since we modified it, we
5668 won't be able to find the begining of the string anymore! */
5672 while (str
[0] != '_' && str
[0] != '\0')
5674 if (str
[0] != 'n' && str
[0] != 'b')
5680 if (str
[0] == '\000')
5685 if (str
[1] != '_' || str
[2] == '\000')
5689 if (strcmp (str
+ 3, "JM") == 0)
5691 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5692 the LJM suffix in favor of the JM one. But we will
5693 still accept LJM as a valid suffix for a reasonable
5694 amount of time, just to allow ourselves to debug programs
5695 compiled using an older version of GNAT. */
5696 if (strcmp (str
+ 3, "LJM") == 0)
5700 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5701 || str
[4] == 'U' || str
[4] == 'P')
5703 if (str
[4] == 'R' && str
[5] != 'T')
5707 if (!isdigit (str
[2]))
5709 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5710 if (!isdigit (str
[k
]) && str
[k
] != '_')
5714 if (str
[0] == '$' && isdigit (str
[1]))
5716 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5717 if (!isdigit (str
[k
]) && str
[k
] != '_')
5724 /* Return non-zero if the string starting at NAME and ending before
5725 NAME_END contains no capital letters. */
5728 is_valid_name_for_wild_match (const char *name0
)
5730 const char *decoded_name
= ada_decode (name0
);
5733 /* If the decoded name starts with an angle bracket, it means that
5734 NAME0 does not follow the GNAT encoding format. It should then
5735 not be allowed as a possible wild match. */
5736 if (decoded_name
[0] == '<')
5739 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5740 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5746 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5747 that could start a simple name. Assumes that *NAMEP points into
5748 the string beginning at NAME0. */
5751 advance_wild_match (const char **namep
, const char *name0
, int target0
)
5753 const char *name
= *namep
;
5763 if ((t1
>= 'a' && t1
<= 'z') || (t1
>= '0' && t1
<= '9'))
5766 if (name
== name0
+ 5 && strncmp (name0
, "_ada", 4) == 0)
5771 else if (t1
== '_' && ((name
[2] >= 'a' && name
[2] <= 'z')
5772 || name
[2] == target0
))
5780 else if ((t0
>= 'a' && t0
<= 'z') || (t0
>= '0' && t0
<= '9'))
5790 /* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5791 informational suffixes of NAME (i.e., for which is_name_suffix is
5792 true). Assumes that PATN is a lower-cased Ada simple name. */
5795 wild_match (const char *name
, const char *patn
)
5798 const char *name0
= name
;
5802 const char *match
= name
;
5806 for (name
+= 1, p
= patn
+ 1; *p
!= '\0'; name
+= 1, p
+= 1)
5809 if (*p
== '\0' && is_name_suffix (name
))
5810 return match
!= name0
&& !is_valid_name_for_wild_match (name0
);
5812 if (name
[-1] == '_')
5815 if (!advance_wild_match (&name
, name0
, *patn
))
5820 /* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5821 informational suffix. */
5824 full_match (const char *sym_name
, const char *search_name
)
5826 return !match_name (sym_name
, search_name
, 0);
5830 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5831 vector *defn_symbols, updating the list of symbols in OBSTACKP
5832 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5833 OBJFILE is the section containing BLOCK. */
5836 ada_add_block_symbols (struct obstack
*obstackp
,
5837 const struct block
*block
, const char *name
,
5838 domain_enum domain
, struct objfile
*objfile
,
5841 struct block_iterator iter
;
5842 int name_len
= strlen (name
);
5843 /* A matching argument symbol, if any. */
5844 struct symbol
*arg_sym
;
5845 /* Set true when we find a matching non-argument symbol. */
5853 for (sym
= block_iter_match_first (block
, name
, wild_match
, &iter
);
5854 sym
!= NULL
; sym
= block_iter_match_next (name
, wild_match
, &iter
))
5856 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5857 SYMBOL_DOMAIN (sym
), domain
)
5858 && wild_match (SYMBOL_LINKAGE_NAME (sym
), name
) == 0)
5860 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5862 else if (SYMBOL_IS_ARGUMENT (sym
))
5867 add_defn_to_vec (obstackp
,
5868 fixup_symbol_section (sym
, objfile
),
5876 for (sym
= block_iter_match_first (block
, name
, full_match
, &iter
);
5877 sym
!= NULL
; sym
= block_iter_match_next (name
, full_match
, &iter
))
5879 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5880 SYMBOL_DOMAIN (sym
), domain
))
5882 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5884 if (SYMBOL_IS_ARGUMENT (sym
))
5889 add_defn_to_vec (obstackp
,
5890 fixup_symbol_section (sym
, objfile
),
5898 if (!found_sym
&& arg_sym
!= NULL
)
5900 add_defn_to_vec (obstackp
,
5901 fixup_symbol_section (arg_sym
, objfile
),
5910 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5912 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5913 SYMBOL_DOMAIN (sym
), domain
))
5917 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5920 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5922 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5927 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5929 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5931 if (SYMBOL_IS_ARGUMENT (sym
))
5936 add_defn_to_vec (obstackp
,
5937 fixup_symbol_section (sym
, objfile
),
5945 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5946 They aren't parameters, right? */
5947 if (!found_sym
&& arg_sym
!= NULL
)
5949 add_defn_to_vec (obstackp
,
5950 fixup_symbol_section (arg_sym
, objfile
),
5957 /* Symbol Completion */
5959 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5960 name in a form that's appropriate for the completion. The result
5961 does not need to be deallocated, but is only good until the next call.
5963 TEXT_LEN is equal to the length of TEXT.
5964 Perform a wild match if WILD_MATCH_P is set.
5965 ENCODED_P should be set if TEXT represents the start of a symbol name
5966 in its encoded form. */
5969 symbol_completion_match (const char *sym_name
,
5970 const char *text
, int text_len
,
5971 int wild_match_p
, int encoded_p
)
5973 const int verbatim_match
= (text
[0] == '<');
5978 /* Strip the leading angle bracket. */
5983 /* First, test against the fully qualified name of the symbol. */
5985 if (strncmp (sym_name
, text
, text_len
) == 0)
5988 if (match
&& !encoded_p
)
5990 /* One needed check before declaring a positive match is to verify
5991 that iff we are doing a verbatim match, the decoded version
5992 of the symbol name starts with '<'. Otherwise, this symbol name
5993 is not a suitable completion. */
5994 const char *sym_name_copy
= sym_name
;
5995 int has_angle_bracket
;
5997 sym_name
= ada_decode (sym_name
);
5998 has_angle_bracket
= (sym_name
[0] == '<');
5999 match
= (has_angle_bracket
== verbatim_match
);
6000 sym_name
= sym_name_copy
;
6003 if (match
&& !verbatim_match
)
6005 /* When doing non-verbatim match, another check that needs to
6006 be done is to verify that the potentially matching symbol name
6007 does not include capital letters, because the ada-mode would
6008 not be able to understand these symbol names without the
6009 angle bracket notation. */
6012 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
6017 /* Second: Try wild matching... */
6019 if (!match
&& wild_match_p
)
6021 /* Since we are doing wild matching, this means that TEXT
6022 may represent an unqualified symbol name. We therefore must
6023 also compare TEXT against the unqualified name of the symbol. */
6024 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
6026 if (strncmp (sym_name
, text
, text_len
) == 0)
6030 /* Finally: If we found a mach, prepare the result to return. */
6036 sym_name
= add_angle_brackets (sym_name
);
6039 sym_name
= ada_decode (sym_name
);
6044 /* A companion function to ada_make_symbol_completion_list().
6045 Check if SYM_NAME represents a symbol which name would be suitable
6046 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
6047 it is appended at the end of the given string vector SV.
6049 ORIG_TEXT is the string original string from the user command
6050 that needs to be completed. WORD is the entire command on which
6051 completion should be performed. These two parameters are used to
6052 determine which part of the symbol name should be added to the
6054 if WILD_MATCH_P is set, then wild matching is performed.
6055 ENCODED_P should be set if TEXT represents a symbol name in its
6056 encoded formed (in which case the completion should also be
6060 symbol_completion_add (VEC(char_ptr
) **sv
,
6061 const char *sym_name
,
6062 const char *text
, int text_len
,
6063 const char *orig_text
, const char *word
,
6064 int wild_match_p
, int encoded_p
)
6066 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
6067 wild_match_p
, encoded_p
);
6073 /* We found a match, so add the appropriate completion to the given
6076 if (word
== orig_text
)
6078 completion
= xmalloc (strlen (match
) + 5);
6079 strcpy (completion
, match
);
6081 else if (word
> orig_text
)
6083 /* Return some portion of sym_name. */
6084 completion
= xmalloc (strlen (match
) + 5);
6085 strcpy (completion
, match
+ (word
- orig_text
));
6089 /* Return some of ORIG_TEXT plus sym_name. */
6090 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
6091 strncpy (completion
, word
, orig_text
- word
);
6092 completion
[orig_text
- word
] = '\0';
6093 strcat (completion
, match
);
6096 VEC_safe_push (char_ptr
, *sv
, completion
);
6099 /* An object of this type is passed as the user_data argument to the
6100 expand_symtabs_matching method. */
6101 struct add_partial_datum
6103 VEC(char_ptr
) **completions
;
6112 /* A callback for expand_symtabs_matching. */
6115 ada_complete_symbol_matcher (const char *name
, void *user_data
)
6117 struct add_partial_datum
*data
= user_data
;
6119 return symbol_completion_match (name
, data
->text
, data
->text_len
,
6120 data
->wild_match
, data
->encoded
) != NULL
;
6123 /* Return a list of possible symbol names completing TEXT0. WORD is
6124 the entire command on which completion is made. */
6126 static VEC (char_ptr
) *
6127 ada_make_symbol_completion_list (const char *text0
, const char *word
,
6128 enum type_code code
)
6134 VEC(char_ptr
) *completions
= VEC_alloc (char_ptr
, 128);
6137 struct minimal_symbol
*msymbol
;
6138 struct objfile
*objfile
;
6139 const struct block
*b
, *surrounding_static_block
= 0;
6141 struct block_iterator iter
;
6142 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
6144 gdb_assert (code
== TYPE_CODE_UNDEF
);
6146 if (text0
[0] == '<')
6148 text
= xstrdup (text0
);
6149 make_cleanup (xfree
, text
);
6150 text_len
= strlen (text
);
6156 text
= xstrdup (ada_encode (text0
));
6157 make_cleanup (xfree
, text
);
6158 text_len
= strlen (text
);
6159 for (i
= 0; i
< text_len
; i
++)
6160 text
[i
] = tolower (text
[i
]);
6162 encoded_p
= (strstr (text0
, "__") != NULL
);
6163 /* If the name contains a ".", then the user is entering a fully
6164 qualified entity name, and the match must not be done in wild
6165 mode. Similarly, if the user wants to complete what looks like
6166 an encoded name, the match must not be done in wild mode. */
6167 wild_match_p
= (strchr (text0
, '.') == NULL
&& !encoded_p
);
6170 /* First, look at the partial symtab symbols. */
6172 struct add_partial_datum data
;
6174 data
.completions
= &completions
;
6176 data
.text_len
= text_len
;
6179 data
.wild_match
= wild_match_p
;
6180 data
.encoded
= encoded_p
;
6181 expand_symtabs_matching (NULL
, ada_complete_symbol_matcher
, ALL_DOMAIN
,
6185 /* At this point scan through the misc symbol vectors and add each
6186 symbol you find to the list. Eventually we want to ignore
6187 anything that isn't a text symbol (everything else will be
6188 handled by the psymtab code above). */
6190 ALL_MSYMBOLS (objfile
, msymbol
)
6193 symbol_completion_add (&completions
, MSYMBOL_LINKAGE_NAME (msymbol
),
6194 text
, text_len
, text0
, word
, wild_match_p
,
6198 /* Search upwards from currently selected frame (so that we can
6199 complete on local vars. */
6201 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
6203 if (!BLOCK_SUPERBLOCK (b
))
6204 surrounding_static_block
= b
; /* For elmin of dups */
6206 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6208 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
6209 text
, text_len
, text0
, word
,
6210 wild_match_p
, encoded_p
);
6214 /* Go through the symtabs and check the externs and statics for
6215 symbols which match.
6216 Non-primary symtabs share the block vector with their primary symtabs
6217 so we use ALL_PRIMARY_SYMTABS here instead of ALL_SYMTABS. */
6219 ALL_PRIMARY_SYMTABS (objfile
, s
)
6222 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
6223 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6225 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
6226 text
, text_len
, text0
, word
,
6227 wild_match_p
, encoded_p
);
6231 ALL_PRIMARY_SYMTABS (objfile
, s
)
6234 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
6235 /* Don't do this block twice. */
6236 if (b
== surrounding_static_block
)
6238 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
6240 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
6241 text
, text_len
, text0
, word
,
6242 wild_match_p
, encoded_p
);
6246 do_cleanups (old_chain
);
6252 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6253 for tagged types. */
6256 ada_is_dispatch_table_ptr_type (struct type
*type
)
6260 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
6263 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
6267 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
6270 /* Return non-zero if TYPE is an interface tag. */
6273 ada_is_interface_tag (struct type
*type
)
6275 const char *name
= TYPE_NAME (type
);
6280 return (strcmp (name
, "ada__tags__interface_tag") == 0);
6283 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6284 to be invisible to users. */
6287 ada_is_ignored_field (struct type
*type
, int field_num
)
6289 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
6292 /* Check the name of that field. */
6294 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6296 /* Anonymous field names should not be printed.
6297 brobecker/2007-02-20: I don't think this can actually happen
6298 but we don't want to print the value of annonymous fields anyway. */
6302 /* Normally, fields whose name start with an underscore ("_")
6303 are fields that have been internally generated by the compiler,
6304 and thus should not be printed. The "_parent" field is special,
6305 however: This is a field internally generated by the compiler
6306 for tagged types, and it contains the components inherited from
6307 the parent type. This field should not be printed as is, but
6308 should not be ignored either. */
6309 if (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0)
6313 /* If this is the dispatch table of a tagged type or an interface tag,
6315 if (ada_is_tagged_type (type
, 1)
6316 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
))
6317 || ada_is_interface_tag (TYPE_FIELD_TYPE (type
, field_num
))))
6320 /* Not a special field, so it should not be ignored. */
6324 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6325 pointer or reference type whose ultimate target has a tag field. */
6328 ada_is_tagged_type (struct type
*type
, int refok
)
6330 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
6333 /* True iff TYPE represents the type of X'Tag */
6336 ada_is_tag_type (struct type
*type
)
6338 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
6342 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6344 return (name
!= NULL
6345 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6349 /* The type of the tag on VAL. */
6352 ada_tag_type (struct value
*val
)
6354 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
6357 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6358 retired at Ada 05). */
6361 is_ada95_tag (struct value
*tag
)
6363 return ada_value_struct_elt (tag
, "tsd", 1) != NULL
;
6366 /* The value of the tag on VAL. */
6369 ada_value_tag (struct value
*val
)
6371 return ada_value_struct_elt (val
, "_tag", 0);
6374 /* The value of the tag on the object of type TYPE whose contents are
6375 saved at VALADDR, if it is non-null, or is at memory address
6378 static struct value
*
6379 value_tag_from_contents_and_address (struct type
*type
,
6380 const gdb_byte
*valaddr
,
6383 int tag_byte_offset
;
6384 struct type
*tag_type
;
6386 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6389 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
6391 : valaddr
+ tag_byte_offset
);
6392 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6394 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6399 static struct type
*
6400 type_from_tag (struct value
*tag
)
6402 const char *type_name
= ada_tag_name (tag
);
6404 if (type_name
!= NULL
)
6405 return ada_find_any_type (ada_encode (type_name
));
6409 /* Given a value OBJ of a tagged type, return a value of this
6410 type at the base address of the object. The base address, as
6411 defined in Ada.Tags, it is the address of the primary tag of
6412 the object, and therefore where the field values of its full
6413 view can be fetched. */
6416 ada_tag_value_at_base_address (struct value
*obj
)
6418 volatile struct gdb_exception e
;
6420 LONGEST offset_to_top
= 0;
6421 struct type
*ptr_type
, *obj_type
;
6423 CORE_ADDR base_address
;
6425 obj_type
= value_type (obj
);
6427 /* It is the responsability of the caller to deref pointers. */
6429 if (TYPE_CODE (obj_type
) == TYPE_CODE_PTR
6430 || TYPE_CODE (obj_type
) == TYPE_CODE_REF
)
6433 tag
= ada_value_tag (obj
);
6437 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6439 if (is_ada95_tag (tag
))
6442 ptr_type
= builtin_type (target_gdbarch ())->builtin_data_ptr
;
6443 ptr_type
= lookup_pointer_type (ptr_type
);
6444 val
= value_cast (ptr_type
, tag
);
6448 /* It is perfectly possible that an exception be raised while
6449 trying to determine the base address, just like for the tag;
6450 see ada_tag_name for more details. We do not print the error
6451 message for the same reason. */
6453 TRY_CATCH (e
, RETURN_MASK_ERROR
)
6455 offset_to_top
= value_as_long (value_ind (value_ptradd (val
, -2)));
6461 /* If offset is null, nothing to do. */
6463 if (offset_to_top
== 0)
6466 /* -1 is a special case in Ada.Tags; however, what should be done
6467 is not quite clear from the documentation. So do nothing for
6470 if (offset_to_top
== -1)
6473 base_address
= value_address (obj
) - offset_to_top
;
6474 tag
= value_tag_from_contents_and_address (obj_type
, NULL
, base_address
);
6476 /* Make sure that we have a proper tag at the new address.
6477 Otherwise, offset_to_top is bogus (which can happen when
6478 the object is not initialized yet). */
6483 obj_type
= type_from_tag (tag
);
6488 return value_from_contents_and_address (obj_type
, NULL
, base_address
);
6491 /* Return the "ada__tags__type_specific_data" type. */
6493 static struct type
*
6494 ada_get_tsd_type (struct inferior
*inf
)
6496 struct ada_inferior_data
*data
= get_ada_inferior_data (inf
);
6498 if (data
->tsd_type
== 0)
6499 data
->tsd_type
= ada_find_any_type ("ada__tags__type_specific_data");
6500 return data
->tsd_type
;
6503 /* Return the TSD (type-specific data) associated to the given TAG.
6504 TAG is assumed to be the tag of a tagged-type entity.
6506 May return NULL if we are unable to get the TSD. */
6508 static struct value
*
6509 ada_get_tsd_from_tag (struct value
*tag
)
6514 /* First option: The TSD is simply stored as a field of our TAG.
6515 Only older versions of GNAT would use this format, but we have
6516 to test it first, because there are no visible markers for
6517 the current approach except the absence of that field. */
6519 val
= ada_value_struct_elt (tag
, "tsd", 1);
6523 /* Try the second representation for the dispatch table (in which
6524 there is no explicit 'tsd' field in the referent of the tag pointer,
6525 and instead the tsd pointer is stored just before the dispatch
6528 type
= ada_get_tsd_type (current_inferior());
6531 type
= lookup_pointer_type (lookup_pointer_type (type
));
6532 val
= value_cast (type
, tag
);
6535 return value_ind (value_ptradd (val
, -1));
6538 /* Given the TSD of a tag (type-specific data), return a string
6539 containing the name of the associated type.
6541 The returned value is good until the next call. May return NULL
6542 if we are unable to determine the tag name. */
6545 ada_tag_name_from_tsd (struct value
*tsd
)
6547 static char name
[1024];
6551 val
= ada_value_struct_elt (tsd
, "expanded_name", 1);
6554 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
6555 for (p
= name
; *p
!= '\0'; p
+= 1)
6561 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6564 Return NULL if the TAG is not an Ada tag, or if we were unable to
6565 determine the name of that tag. The result is good until the next
6569 ada_tag_name (struct value
*tag
)
6571 volatile struct gdb_exception e
;
6574 if (!ada_is_tag_type (value_type (tag
)))
6577 /* It is perfectly possible that an exception be raised while trying
6578 to determine the TAG's name, even under normal circumstances:
6579 The associated variable may be uninitialized or corrupted, for
6580 instance. We do not let any exception propagate past this point.
6581 instead we return NULL.
6583 We also do not print the error message either (which often is very
6584 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6585 the caller print a more meaningful message if necessary. */
6586 TRY_CATCH (e
, RETURN_MASK_ERROR
)
6588 struct value
*tsd
= ada_get_tsd_from_tag (tag
);
6591 name
= ada_tag_name_from_tsd (tsd
);
6597 /* The parent type of TYPE, or NULL if none. */
6600 ada_parent_type (struct type
*type
)
6604 type
= ada_check_typedef (type
);
6606 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6609 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6610 if (ada_is_parent_field (type
, i
))
6612 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
6614 /* If the _parent field is a pointer, then dereference it. */
6615 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
6616 parent_type
= TYPE_TARGET_TYPE (parent_type
);
6617 /* If there is a parallel XVS type, get the actual base type. */
6618 parent_type
= ada_get_base_type (parent_type
);
6620 return ada_check_typedef (parent_type
);
6626 /* True iff field number FIELD_NUM of structure type TYPE contains the
6627 parent-type (inherited) fields of a derived type. Assumes TYPE is
6628 a structure type with at least FIELD_NUM+1 fields. */
6631 ada_is_parent_field (struct type
*type
, int field_num
)
6633 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
6635 return (name
!= NULL
6636 && (strncmp (name
, "PARENT", 6) == 0
6637 || strncmp (name
, "_parent", 7) == 0));
6640 /* True iff field number FIELD_NUM of structure type TYPE is a
6641 transparent wrapper field (which should be silently traversed when doing
6642 field selection and flattened when printing). Assumes TYPE is a
6643 structure type with at least FIELD_NUM+1 fields. Such fields are always
6647 ada_is_wrapper_field (struct type
*type
, int field_num
)
6649 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6651 return (name
!= NULL
6652 && (strncmp (name
, "PARENT", 6) == 0
6653 || strcmp (name
, "REP") == 0
6654 || strncmp (name
, "_parent", 7) == 0
6655 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6658 /* True iff field number FIELD_NUM of structure or union type TYPE
6659 is a variant wrapper. Assumes TYPE is a structure type with at least
6660 FIELD_NUM+1 fields. */
6663 ada_is_variant_part (struct type
*type
, int field_num
)
6665 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
6667 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
6668 || (is_dynamic_field (type
, field_num
)
6669 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
6670 == TYPE_CODE_UNION
)));
6673 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6674 whose discriminants are contained in the record type OUTER_TYPE,
6675 returns the type of the controlling discriminant for the variant.
6676 May return NULL if the type could not be found. */
6679 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6681 char *name
= ada_variant_discrim_name (var_type
);
6683 return ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
6686 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6687 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6688 represents a 'when others' clause; otherwise 0. */
6691 ada_is_others_clause (struct type
*type
, int field_num
)
6693 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6695 return (name
!= NULL
&& name
[0] == 'O');
6698 /* Assuming that TYPE0 is the type of the variant part of a record,
6699 returns the name of the discriminant controlling the variant.
6700 The value is valid until the next call to ada_variant_discrim_name. */
6703 ada_variant_discrim_name (struct type
*type0
)
6705 static char *result
= NULL
;
6706 static size_t result_len
= 0;
6709 const char *discrim_end
;
6710 const char *discrim_start
;
6712 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
6713 type
= TYPE_TARGET_TYPE (type0
);
6717 name
= ada_type_name (type
);
6719 if (name
== NULL
|| name
[0] == '\000')
6722 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6725 if (strncmp (discrim_end
, "___XVN", 6) == 0)
6728 if (discrim_end
== name
)
6731 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6734 if (discrim_start
== name
+ 1)
6736 if ((discrim_start
> name
+ 3
6737 && strncmp (discrim_start
- 3, "___", 3) == 0)
6738 || discrim_start
[-1] == '.')
6742 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6743 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6744 result
[discrim_end
- discrim_start
] = '\0';
6748 /* Scan STR for a subtype-encoded number, beginning at position K.
6749 Put the position of the character just past the number scanned in
6750 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6751 Return 1 if there was a valid number at the given position, and 0
6752 otherwise. A "subtype-encoded" number consists of the absolute value
6753 in decimal, followed by the letter 'm' to indicate a negative number.
6754 Assumes 0m does not occur. */
6757 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6761 if (!isdigit (str
[k
]))
6764 /* Do it the hard way so as not to make any assumption about
6765 the relationship of unsigned long (%lu scan format code) and
6768 while (isdigit (str
[k
]))
6770 RU
= RU
* 10 + (str
[k
] - '0');
6777 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6783 /* NOTE on the above: Technically, C does not say what the results of
6784 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6785 number representable as a LONGEST (although either would probably work
6786 in most implementations). When RU>0, the locution in the then branch
6787 above is always equivalent to the negative of RU. */
6794 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6795 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6796 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6799 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6801 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6815 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6825 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6826 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6828 if (val
>= L
&& val
<= U
)
6840 /* FIXME: Lots of redundancy below. Try to consolidate. */
6842 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6843 ARG_TYPE, extract and return the value of one of its (non-static)
6844 fields. FIELDNO says which field. Differs from value_primitive_field
6845 only in that it can handle packed values of arbitrary type. */
6847 static struct value
*
6848 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6849 struct type
*arg_type
)
6853 arg_type
= ada_check_typedef (arg_type
);
6854 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
6856 /* Handle packed fields. */
6858 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
6860 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6861 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6863 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
6864 offset
+ bit_pos
/ 8,
6865 bit_pos
% 8, bit_size
, type
);
6868 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6871 /* Find field with name NAME in object of type TYPE. If found,
6872 set the following for each argument that is non-null:
6873 - *FIELD_TYPE_P to the field's type;
6874 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
6875 an object of that type;
6876 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
6877 - *BIT_SIZE_P to its size in bits if the field is packed, and
6879 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
6880 fields up to but not including the desired field, or by the total
6881 number of fields if not found. A NULL value of NAME never
6882 matches; the function just counts visible fields in this case.
6884 Returns 1 if found, 0 otherwise. */
6887 find_struct_field (const char *name
, struct type
*type
, int offset
,
6888 struct type
**field_type_p
,
6889 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
6894 type
= ada_check_typedef (type
);
6896 if (field_type_p
!= NULL
)
6897 *field_type_p
= NULL
;
6898 if (byte_offset_p
!= NULL
)
6900 if (bit_offset_p
!= NULL
)
6902 if (bit_size_p
!= NULL
)
6905 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6907 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6908 int fld_offset
= offset
+ bit_pos
/ 8;
6909 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6911 if (t_field_name
== NULL
)
6914 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
6916 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6918 if (field_type_p
!= NULL
)
6919 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6920 if (byte_offset_p
!= NULL
)
6921 *byte_offset_p
= fld_offset
;
6922 if (bit_offset_p
!= NULL
)
6923 *bit_offset_p
= bit_pos
% 8;
6924 if (bit_size_p
!= NULL
)
6925 *bit_size_p
= bit_size
;
6928 else if (ada_is_wrapper_field (type
, i
))
6930 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6931 field_type_p
, byte_offset_p
, bit_offset_p
,
6932 bit_size_p
, index_p
))
6935 else if (ada_is_variant_part (type
, i
))
6937 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6940 struct type
*field_type
6941 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6943 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6945 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
6947 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6948 field_type_p
, byte_offset_p
,
6949 bit_offset_p
, bit_size_p
, index_p
))
6953 else if (index_p
!= NULL
)
6959 /* Number of user-visible fields in record type TYPE. */
6962 num_visible_fields (struct type
*type
)
6967 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
6971 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6972 and search in it assuming it has (class) type TYPE.
6973 If found, return value, else return NULL.
6975 Searches recursively through wrapper fields (e.g., '_parent'). */
6977 static struct value
*
6978 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
6983 type
= ada_check_typedef (type
);
6984 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6986 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6988 if (t_field_name
== NULL
)
6991 else if (field_name_match (t_field_name
, name
))
6992 return ada_value_primitive_field (arg
, offset
, i
, type
);
6994 else if (ada_is_wrapper_field (type
, i
))
6996 struct value
*v
= /* Do not let indent join lines here. */
6997 ada_search_struct_field (name
, arg
,
6998 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6999 TYPE_FIELD_TYPE (type
, i
));
7005 else if (ada_is_variant_part (type
, i
))
7007 /* PNH: Do we ever get here? See find_struct_field. */
7009 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7011 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7013 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
7015 struct value
*v
= ada_search_struct_field
/* Force line
7018 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7019 TYPE_FIELD_TYPE (field_type
, j
));
7029 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
7030 int, struct type
*);
7033 /* Return field #INDEX in ARG, where the index is that returned by
7034 * find_struct_field through its INDEX_P argument. Adjust the address
7035 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7036 * If found, return value, else return NULL. */
7038 static struct value
*
7039 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
7042 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
7046 /* Auxiliary function for ada_index_struct_field. Like
7047 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7050 static struct value
*
7051 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
7055 type
= ada_check_typedef (type
);
7057 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7059 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
7061 else if (ada_is_wrapper_field (type
, i
))
7063 struct value
*v
= /* Do not let indent join lines here. */
7064 ada_index_struct_field_1 (index_p
, arg
,
7065 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7066 TYPE_FIELD_TYPE (type
, i
));
7072 else if (ada_is_variant_part (type
, i
))
7074 /* PNH: Do we ever get here? See ada_search_struct_field,
7075 find_struct_field. */
7076 error (_("Cannot assign this kind of variant record"));
7078 else if (*index_p
== 0)
7079 return ada_value_primitive_field (arg
, offset
, i
, type
);
7086 /* Given ARG, a value of type (pointer or reference to a)*
7087 structure/union, extract the component named NAME from the ultimate
7088 target structure/union and return it as a value with its
7091 The routine searches for NAME among all members of the structure itself
7092 and (recursively) among all members of any wrapper members
7095 If NO_ERR, then simply return NULL in case of error, rather than
7099 ada_value_struct_elt (struct value
*arg
, char *name
, int no_err
)
7101 struct type
*t
, *t1
;
7105 t1
= t
= ada_check_typedef (value_type (arg
));
7106 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7108 t1
= TYPE_TARGET_TYPE (t
);
7111 t1
= ada_check_typedef (t1
);
7112 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7114 arg
= coerce_ref (arg
);
7119 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7121 t1
= TYPE_TARGET_TYPE (t
);
7124 t1
= ada_check_typedef (t1
);
7125 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7127 arg
= value_ind (arg
);
7134 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
7138 v
= ada_search_struct_field (name
, arg
, 0, t
);
7141 int bit_offset
, bit_size
, byte_offset
;
7142 struct type
*field_type
;
7145 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7146 address
= value_address (ada_value_ind (arg
));
7148 address
= value_address (ada_coerce_ref (arg
));
7150 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
, 1);
7151 if (find_struct_field (name
, t1
, 0,
7152 &field_type
, &byte_offset
, &bit_offset
,
7157 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7158 arg
= ada_coerce_ref (arg
);
7160 arg
= ada_value_ind (arg
);
7161 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
7162 bit_offset
, bit_size
,
7166 v
= value_at_lazy (field_type
, address
+ byte_offset
);
7170 if (v
!= NULL
|| no_err
)
7173 error (_("There is no member named %s."), name
);
7179 error (_("Attempt to extract a component of "
7180 "a value that is not a record."));
7183 /* Given a type TYPE, look up the type of the component of type named NAME.
7184 If DISPP is non-null, add its byte displacement from the beginning of a
7185 structure (pointed to by a value) of type TYPE to *DISPP (does not
7186 work for packed fields).
7188 Matches any field whose name has NAME as a prefix, possibly
7191 TYPE can be either a struct or union. If REFOK, TYPE may also
7192 be a (pointer or reference)+ to a struct or union, and the
7193 ultimate target type will be searched.
7195 Looks recursively into variant clauses and parent types.
7197 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7198 TYPE is not a type of the right kind. */
7200 static struct type
*
7201 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
7202 int noerr
, int *dispp
)
7209 if (refok
&& type
!= NULL
)
7212 type
= ada_check_typedef (type
);
7213 if (TYPE_CODE (type
) != TYPE_CODE_PTR
7214 && TYPE_CODE (type
) != TYPE_CODE_REF
)
7216 type
= TYPE_TARGET_TYPE (type
);
7220 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
7221 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
7227 target_terminal_ours ();
7228 gdb_flush (gdb_stdout
);
7230 error (_("Type (null) is not a structure or union type"));
7233 /* XXX: type_sprint */
7234 fprintf_unfiltered (gdb_stderr
, _("Type "));
7235 type_print (type
, "", gdb_stderr
, -1);
7236 error (_(" is not a structure or union type"));
7241 type
= to_static_fixed_type (type
);
7243 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7245 const char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7249 if (t_field_name
== NULL
)
7252 else if (field_name_match (t_field_name
, name
))
7255 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
7256 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
7259 else if (ada_is_wrapper_field (type
, i
))
7262 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
7267 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7272 else if (ada_is_variant_part (type
, i
))
7275 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
,
7278 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7280 /* FIXME pnh 2008/01/26: We check for a field that is
7281 NOT wrapped in a struct, since the compiler sometimes
7282 generates these for unchecked variant types. Revisit
7283 if the compiler changes this practice. */
7284 const char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
7286 if (v_field_name
!= NULL
7287 && field_name_match (v_field_name
, name
))
7288 t
= ada_check_typedef (TYPE_FIELD_TYPE (field_type
, j
));
7290 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
,
7297 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7308 target_terminal_ours ();
7309 gdb_flush (gdb_stdout
);
7312 /* XXX: type_sprint */
7313 fprintf_unfiltered (gdb_stderr
, _("Type "));
7314 type_print (type
, "", gdb_stderr
, -1);
7315 error (_(" has no component named <null>"));
7319 /* XXX: type_sprint */
7320 fprintf_unfiltered (gdb_stderr
, _("Type "));
7321 type_print (type
, "", gdb_stderr
, -1);
7322 error (_(" has no component named %s"), name
);
7329 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7330 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7331 represents an unchecked union (that is, the variant part of a
7332 record that is named in an Unchecked_Union pragma). */
7335 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
7337 char *discrim_name
= ada_variant_discrim_name (var_type
);
7339 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1, NULL
)
7344 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7345 within a value of type OUTER_TYPE that is stored in GDB at
7346 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7347 numbering from 0) is applicable. Returns -1 if none are. */
7350 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
7351 const gdb_byte
*outer_valaddr
)
7355 char *discrim_name
= ada_variant_discrim_name (var_type
);
7356 struct value
*outer
;
7357 struct value
*discrim
;
7358 LONGEST discrim_val
;
7360 /* Using plain value_from_contents_and_address here causes problems
7361 because we will end up trying to resolve a type that is currently
7362 being constructed. */
7363 outer
= value_from_contents_and_address_unresolved (outer_type
,
7365 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
7366 if (discrim
== NULL
)
7368 discrim_val
= value_as_long (discrim
);
7371 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
7373 if (ada_is_others_clause (var_type
, i
))
7375 else if (ada_in_variant (discrim_val
, var_type
, i
))
7379 return others_clause
;
7384 /* Dynamic-Sized Records */
7386 /* Strategy: The type ostensibly attached to a value with dynamic size
7387 (i.e., a size that is not statically recorded in the debugging
7388 data) does not accurately reflect the size or layout of the value.
7389 Our strategy is to convert these values to values with accurate,
7390 conventional types that are constructed on the fly. */
7392 /* There is a subtle and tricky problem here. In general, we cannot
7393 determine the size of dynamic records without its data. However,
7394 the 'struct value' data structure, which GDB uses to represent
7395 quantities in the inferior process (the target), requires the size
7396 of the type at the time of its allocation in order to reserve space
7397 for GDB's internal copy of the data. That's why the
7398 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7399 rather than struct value*s.
7401 However, GDB's internal history variables ($1, $2, etc.) are
7402 struct value*s containing internal copies of the data that are not, in
7403 general, the same as the data at their corresponding addresses in
7404 the target. Fortunately, the types we give to these values are all
7405 conventional, fixed-size types (as per the strategy described
7406 above), so that we don't usually have to perform the
7407 'to_fixed_xxx_type' conversions to look at their values.
7408 Unfortunately, there is one exception: if one of the internal
7409 history variables is an array whose elements are unconstrained
7410 records, then we will need to create distinct fixed types for each
7411 element selected. */
7413 /* The upshot of all of this is that many routines take a (type, host
7414 address, target address) triple as arguments to represent a value.
7415 The host address, if non-null, is supposed to contain an internal
7416 copy of the relevant data; otherwise, the program is to consult the
7417 target at the target address. */
7419 /* Assuming that VAL0 represents a pointer value, the result of
7420 dereferencing it. Differs from value_ind in its treatment of
7421 dynamic-sized types. */
7424 ada_value_ind (struct value
*val0
)
7426 struct value
*val
= value_ind (val0
);
7428 if (ada_is_tagged_type (value_type (val
), 0))
7429 val
= ada_tag_value_at_base_address (val
);
7431 return ada_to_fixed_value (val
);
7434 /* The value resulting from dereferencing any "reference to"
7435 qualifiers on VAL0. */
7437 static struct value
*
7438 ada_coerce_ref (struct value
*val0
)
7440 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
7442 struct value
*val
= val0
;
7444 val
= coerce_ref (val
);
7446 if (ada_is_tagged_type (value_type (val
), 0))
7447 val
= ada_tag_value_at_base_address (val
);
7449 return ada_to_fixed_value (val
);
7455 /* Return OFF rounded upward if necessary to a multiple of
7456 ALIGNMENT (a power of 2). */
7459 align_value (unsigned int off
, unsigned int alignment
)
7461 return (off
+ alignment
- 1) & ~(alignment
- 1);
7464 /* Return the bit alignment required for field #F of template type TYPE. */
7467 field_alignment (struct type
*type
, int f
)
7469 const char *name
= TYPE_FIELD_NAME (type
, f
);
7473 /* The field name should never be null, unless the debugging information
7474 is somehow malformed. In this case, we assume the field does not
7475 require any alignment. */
7479 len
= strlen (name
);
7481 if (!isdigit (name
[len
- 1]))
7484 if (isdigit (name
[len
- 2]))
7485 align_offset
= len
- 2;
7487 align_offset
= len
- 1;
7489 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
7490 return TARGET_CHAR_BIT
;
7492 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7495 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7497 static struct symbol
*
7498 ada_find_any_type_symbol (const char *name
)
7502 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7503 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7506 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7510 /* Find a type named NAME. Ignores ambiguity. This routine will look
7511 solely for types defined by debug info, it will not search the GDB
7514 static struct type
*
7515 ada_find_any_type (const char *name
)
7517 struct symbol
*sym
= ada_find_any_type_symbol (name
);
7520 return SYMBOL_TYPE (sym
);
7525 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7526 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7527 symbol, in which case it is returned. Otherwise, this looks for
7528 symbols whose name is that of NAME_SYM suffixed with "___XR".
7529 Return symbol if found, and NULL otherwise. */
7532 ada_find_renaming_symbol (struct symbol
*name_sym
, const struct block
*block
)
7534 const char *name
= SYMBOL_LINKAGE_NAME (name_sym
);
7537 if (strstr (name
, "___XR") != NULL
)
7540 sym
= find_old_style_renaming_symbol (name
, block
);
7545 /* Not right yet. FIXME pnh 7/20/2007. */
7546 sym
= ada_find_any_type_symbol (name
);
7547 if (sym
!= NULL
&& strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR") != NULL
)
7553 static struct symbol
*
7554 find_old_style_renaming_symbol (const char *name
, const struct block
*block
)
7556 const struct symbol
*function_sym
= block_linkage_function (block
);
7559 if (function_sym
!= NULL
)
7561 /* If the symbol is defined inside a function, NAME is not fully
7562 qualified. This means we need to prepend the function name
7563 as well as adding the ``___XR'' suffix to build the name of
7564 the associated renaming symbol. */
7565 const char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
7566 /* Function names sometimes contain suffixes used
7567 for instance to qualify nested subprograms. When building
7568 the XR type name, we need to make sure that this suffix is
7569 not included. So do not include any suffix in the function
7570 name length below. */
7571 int function_name_len
= ada_name_prefix_len (function_name
);
7572 const int rename_len
= function_name_len
+ 2 /* "__" */
7573 + strlen (name
) + 6 /* "___XR\0" */ ;
7575 /* Strip the suffix if necessary. */
7576 ada_remove_trailing_digits (function_name
, &function_name_len
);
7577 ada_remove_po_subprogram_suffix (function_name
, &function_name_len
);
7578 ada_remove_Xbn_suffix (function_name
, &function_name_len
);
7580 /* Library-level functions are a special case, as GNAT adds
7581 a ``_ada_'' prefix to the function name to avoid namespace
7582 pollution. However, the renaming symbols themselves do not
7583 have this prefix, so we need to skip this prefix if present. */
7584 if (function_name_len
> 5 /* "_ada_" */
7585 && strstr (function_name
, "_ada_") == function_name
)
7588 function_name_len
-= 5;
7591 rename
= (char *) alloca (rename_len
* sizeof (char));
7592 strncpy (rename
, function_name
, function_name_len
);
7593 xsnprintf (rename
+ function_name_len
, rename_len
- function_name_len
,
7598 const int rename_len
= strlen (name
) + 6;
7600 rename
= (char *) alloca (rename_len
* sizeof (char));
7601 xsnprintf (rename
, rename_len
* sizeof (char), "%s___XR", name
);
7604 return ada_find_any_type_symbol (rename
);
7607 /* Because of GNAT encoding conventions, several GDB symbols may match a
7608 given type name. If the type denoted by TYPE0 is to be preferred to
7609 that of TYPE1 for purposes of type printing, return non-zero;
7610 otherwise return 0. */
7613 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7617 else if (type0
== NULL
)
7619 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
7621 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
7623 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
7625 else if (ada_is_constrained_packed_array_type (type0
))
7627 else if (ada_is_array_descriptor_type (type0
)
7628 && !ada_is_array_descriptor_type (type1
))
7632 const char *type0_name
= type_name_no_tag (type0
);
7633 const char *type1_name
= type_name_no_tag (type1
);
7635 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
7636 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
7642 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
7643 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7646 ada_type_name (struct type
*type
)
7650 else if (TYPE_NAME (type
) != NULL
)
7651 return TYPE_NAME (type
);
7653 return TYPE_TAG_NAME (type
);
7656 /* Search the list of "descriptive" types associated to TYPE for a type
7657 whose name is NAME. */
7659 static struct type
*
7660 find_parallel_type_by_descriptive_type (struct type
*type
, const char *name
)
7662 struct type
*result
;
7664 if (ada_ignore_descriptive_types_p
)
7667 /* If there no descriptive-type info, then there is no parallel type
7669 if (!HAVE_GNAT_AUX_INFO (type
))
7672 result
= TYPE_DESCRIPTIVE_TYPE (type
);
7673 while (result
!= NULL
)
7675 const char *result_name
= ada_type_name (result
);
7677 if (result_name
== NULL
)
7679 warning (_("unexpected null name on descriptive type"));
7683 /* If the names match, stop. */
7684 if (strcmp (result_name
, name
) == 0)
7687 /* Otherwise, look at the next item on the list, if any. */
7688 if (HAVE_GNAT_AUX_INFO (result
))
7689 result
= TYPE_DESCRIPTIVE_TYPE (result
);
7694 /* If we didn't find a match, see whether this is a packed array. With
7695 older compilers, the descriptive type information is either absent or
7696 irrelevant when it comes to packed arrays so the above lookup fails.
7697 Fall back to using a parallel lookup by name in this case. */
7698 if (result
== NULL
&& ada_is_constrained_packed_array_type (type
))
7699 return ada_find_any_type (name
);
7704 /* Find a parallel type to TYPE with the specified NAME, using the
7705 descriptive type taken from the debugging information, if available,
7706 and otherwise using the (slower) name-based method. */
7708 static struct type
*
7709 ada_find_parallel_type_with_name (struct type
*type
, const char *name
)
7711 struct type
*result
= NULL
;
7713 if (HAVE_GNAT_AUX_INFO (type
))
7714 result
= find_parallel_type_by_descriptive_type (type
, name
);
7716 result
= ada_find_any_type (name
);
7721 /* Same as above, but specify the name of the parallel type by appending
7722 SUFFIX to the name of TYPE. */
7725 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7728 const char *typename
= ada_type_name (type
);
7731 if (typename
== NULL
)
7734 len
= strlen (typename
);
7736 name
= (char *) alloca (len
+ strlen (suffix
) + 1);
7738 strcpy (name
, typename
);
7739 strcpy (name
+ len
, suffix
);
7741 return ada_find_parallel_type_with_name (type
, name
);
7744 /* If TYPE is a variable-size record type, return the corresponding template
7745 type describing its fields. Otherwise, return NULL. */
7747 static struct type
*
7748 dynamic_template_type (struct type
*type
)
7750 type
= ada_check_typedef (type
);
7752 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
7753 || ada_type_name (type
) == NULL
)
7757 int len
= strlen (ada_type_name (type
));
7759 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7762 return ada_find_parallel_type (type
, "___XVE");
7766 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7767 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7770 is_dynamic_field (struct type
*templ_type
, int field_num
)
7772 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7775 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
7776 && strstr (name
, "___XVL") != NULL
;
7779 /* The index of the variant field of TYPE, or -1 if TYPE does not
7780 represent a variant record type. */
7783 variant_field_index (struct type
*type
)
7787 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
7790 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
7792 if (ada_is_variant_part (type
, f
))
7798 /* A record type with no fields. */
7800 static struct type
*
7801 empty_record (struct type
*template)
7803 struct type
*type
= alloc_type_copy (template);
7805 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
7806 TYPE_NFIELDS (type
) = 0;
7807 TYPE_FIELDS (type
) = NULL
;
7808 INIT_CPLUS_SPECIFIC (type
);
7809 TYPE_NAME (type
) = "<empty>";
7810 TYPE_TAG_NAME (type
) = NULL
;
7811 TYPE_LENGTH (type
) = 0;
7815 /* An ordinary record type (with fixed-length fields) that describes
7816 the value of type TYPE at VALADDR or ADDRESS (see comments at
7817 the beginning of this section) VAL according to GNAT conventions.
7818 DVAL0 should describe the (portion of a) record that contains any
7819 necessary discriminants. It should be NULL if value_type (VAL) is
7820 an outer-level type (i.e., as opposed to a branch of a variant.) A
7821 variant field (unless unchecked) is replaced by a particular branch
7824 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7825 length are not statically known are discarded. As a consequence,
7826 VALADDR, ADDRESS and DVAL0 are ignored.
7828 NOTE: Limitations: For now, we assume that dynamic fields and
7829 variants occupy whole numbers of bytes. However, they need not be
7833 ada_template_to_fixed_record_type_1 (struct type
*type
,
7834 const gdb_byte
*valaddr
,
7835 CORE_ADDR address
, struct value
*dval0
,
7836 int keep_dynamic_fields
)
7838 struct value
*mark
= value_mark ();
7841 int nfields
, bit_len
;
7847 /* Compute the number of fields in this record type that are going
7848 to be processed: unless keep_dynamic_fields, this includes only
7849 fields whose position and length are static will be processed. */
7850 if (keep_dynamic_fields
)
7851 nfields
= TYPE_NFIELDS (type
);
7855 while (nfields
< TYPE_NFIELDS (type
)
7856 && !ada_is_variant_part (type
, nfields
)
7857 && !is_dynamic_field (type
, nfields
))
7861 rtype
= alloc_type_copy (type
);
7862 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7863 INIT_CPLUS_SPECIFIC (rtype
);
7864 TYPE_NFIELDS (rtype
) = nfields
;
7865 TYPE_FIELDS (rtype
) = (struct field
*)
7866 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7867 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
7868 TYPE_NAME (rtype
) = ada_type_name (type
);
7869 TYPE_TAG_NAME (rtype
) = NULL
;
7870 TYPE_FIXED_INSTANCE (rtype
) = 1;
7876 for (f
= 0; f
< nfields
; f
+= 1)
7878 off
= align_value (off
, field_alignment (type
, f
))
7879 + TYPE_FIELD_BITPOS (type
, f
);
7880 SET_FIELD_BITPOS (TYPE_FIELD (rtype
, f
), off
);
7881 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7883 if (ada_is_variant_part (type
, f
))
7888 else if (is_dynamic_field (type
, f
))
7890 const gdb_byte
*field_valaddr
= valaddr
;
7891 CORE_ADDR field_address
= address
;
7892 struct type
*field_type
=
7893 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
));
7897 /* rtype's length is computed based on the run-time
7898 value of discriminants. If the discriminants are not
7899 initialized, the type size may be completely bogus and
7900 GDB may fail to allocate a value for it. So check the
7901 size first before creating the value. */
7903 /* Using plain value_from_contents_and_address here
7904 causes problems because we will end up trying to
7905 resolve a type that is currently being
7907 dval
= value_from_contents_and_address_unresolved (rtype
,
7910 rtype
= value_type (dval
);
7915 /* If the type referenced by this field is an aligner type, we need
7916 to unwrap that aligner type, because its size might not be set.
7917 Keeping the aligner type would cause us to compute the wrong
7918 size for this field, impacting the offset of the all the fields
7919 that follow this one. */
7920 if (ada_is_aligner_type (field_type
))
7922 long field_offset
= TYPE_FIELD_BITPOS (field_type
, f
);
7924 field_valaddr
= cond_offset_host (field_valaddr
, field_offset
);
7925 field_address
= cond_offset_target (field_address
, field_offset
);
7926 field_type
= ada_aligned_type (field_type
);
7929 field_valaddr
= cond_offset_host (field_valaddr
,
7930 off
/ TARGET_CHAR_BIT
);
7931 field_address
= cond_offset_target (field_address
,
7932 off
/ TARGET_CHAR_BIT
);
7934 /* Get the fixed type of the field. Note that, in this case,
7935 we do not want to get the real type out of the tag: if
7936 the current field is the parent part of a tagged record,
7937 we will get the tag of the object. Clearly wrong: the real
7938 type of the parent is not the real type of the child. We
7939 would end up in an infinite loop. */
7940 field_type
= ada_get_base_type (field_type
);
7941 field_type
= ada_to_fixed_type (field_type
, field_valaddr
,
7942 field_address
, dval
, 0);
7943 /* If the field size is already larger than the maximum
7944 object size, then the record itself will necessarily
7945 be larger than the maximum object size. We need to make
7946 this check now, because the size might be so ridiculously
7947 large (due to an uninitialized variable in the inferior)
7948 that it would cause an overflow when adding it to the
7950 check_size (field_type
);
7952 TYPE_FIELD_TYPE (rtype
, f
) = field_type
;
7953 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7954 /* The multiplication can potentially overflow. But because
7955 the field length has been size-checked just above, and
7956 assuming that the maximum size is a reasonable value,
7957 an overflow should not happen in practice. So rather than
7958 adding overflow recovery code to this already complex code,
7959 we just assume that it's not going to happen. */
7961 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
7965 /* Note: If this field's type is a typedef, it is important
7966 to preserve the typedef layer.
7968 Otherwise, we might be transforming a typedef to a fat
7969 pointer (encoding a pointer to an unconstrained array),
7970 into a basic fat pointer (encoding an unconstrained
7971 array). As both types are implemented using the same
7972 structure, the typedef is the only clue which allows us
7973 to distinguish between the two options. Stripping it
7974 would prevent us from printing this field appropriately. */
7975 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
7976 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7977 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7979 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7982 struct type
*field_type
= TYPE_FIELD_TYPE (type
, f
);
7984 /* We need to be careful of typedefs when computing
7985 the length of our field. If this is a typedef,
7986 get the length of the target type, not the length
7988 if (TYPE_CODE (field_type
) == TYPE_CODE_TYPEDEF
)
7989 field_type
= ada_typedef_target_type (field_type
);
7992 TYPE_LENGTH (ada_check_typedef (field_type
)) * TARGET_CHAR_BIT
;
7995 if (off
+ fld_bit_len
> bit_len
)
7996 bit_len
= off
+ fld_bit_len
;
7998 TYPE_LENGTH (rtype
) =
7999 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8002 /* We handle the variant part, if any, at the end because of certain
8003 odd cases in which it is re-ordered so as NOT to be the last field of
8004 the record. This can happen in the presence of representation
8006 if (variant_field
>= 0)
8008 struct type
*branch_type
;
8010 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
8014 /* Using plain value_from_contents_and_address here causes
8015 problems because we will end up trying to resolve a type
8016 that is currently being constructed. */
8017 dval
= value_from_contents_and_address_unresolved (rtype
, valaddr
,
8019 rtype
= value_type (dval
);
8025 to_fixed_variant_branch_type
8026 (TYPE_FIELD_TYPE (type
, variant_field
),
8027 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
8028 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
8029 if (branch_type
== NULL
)
8031 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
8032 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
8033 TYPE_NFIELDS (rtype
) -= 1;
8037 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8038 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8040 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
8042 if (off
+ fld_bit_len
> bit_len
)
8043 bit_len
= off
+ fld_bit_len
;
8044 TYPE_LENGTH (rtype
) =
8045 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
8049 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8050 should contain the alignment of that record, which should be a strictly
8051 positive value. If null or negative, then something is wrong, most
8052 probably in the debug info. In that case, we don't round up the size
8053 of the resulting type. If this record is not part of another structure,
8054 the current RTYPE length might be good enough for our purposes. */
8055 if (TYPE_LENGTH (type
) <= 0)
8057 if (TYPE_NAME (rtype
))
8058 warning (_("Invalid type size for `%s' detected: %d."),
8059 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
8061 warning (_("Invalid type size for <unnamed> detected: %d."),
8062 TYPE_LENGTH (type
));
8066 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
8067 TYPE_LENGTH (type
));
8070 value_free_to_mark (mark
);
8071 if (TYPE_LENGTH (rtype
) > varsize_limit
)
8072 error (_("record type with dynamic size is larger than varsize-limit"));
8076 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8079 static struct type
*
8080 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
8081 CORE_ADDR address
, struct value
*dval0
)
8083 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
8087 /* An ordinary record type in which ___XVL-convention fields and
8088 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8089 static approximations, containing all possible fields. Uses
8090 no runtime values. Useless for use in values, but that's OK,
8091 since the results are used only for type determinations. Works on both
8092 structs and unions. Representation note: to save space, we memorize
8093 the result of this function in the TYPE_TARGET_TYPE of the
8096 static struct type
*
8097 template_to_static_fixed_type (struct type
*type0
)
8103 if (TYPE_TARGET_TYPE (type0
) != NULL
)
8104 return TYPE_TARGET_TYPE (type0
);
8106 nfields
= TYPE_NFIELDS (type0
);
8109 for (f
= 0; f
< nfields
; f
+= 1)
8111 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
8112 struct type
*new_type
;
8114 if (is_dynamic_field (type0
, f
))
8115 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
8117 new_type
= static_unwrap_type (field_type
);
8118 if (type
== type0
&& new_type
!= field_type
)
8120 TYPE_TARGET_TYPE (type0
) = type
= alloc_type_copy (type0
);
8121 TYPE_CODE (type
) = TYPE_CODE (type0
);
8122 INIT_CPLUS_SPECIFIC (type
);
8123 TYPE_NFIELDS (type
) = nfields
;
8124 TYPE_FIELDS (type
) = (struct field
*)
8125 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
8126 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
8127 sizeof (struct field
) * nfields
);
8128 TYPE_NAME (type
) = ada_type_name (type0
);
8129 TYPE_TAG_NAME (type
) = NULL
;
8130 TYPE_FIXED_INSTANCE (type
) = 1;
8131 TYPE_LENGTH (type
) = 0;
8133 TYPE_FIELD_TYPE (type
, f
) = new_type
;
8134 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
8139 /* Given an object of type TYPE whose contents are at VALADDR and
8140 whose address in memory is ADDRESS, returns a revision of TYPE,
8141 which should be a non-dynamic-sized record, in which the variant
8142 part, if any, is replaced with the appropriate branch. Looks
8143 for discriminant values in DVAL0, which can be NULL if the record
8144 contains the necessary discriminant values. */
8146 static struct type
*
8147 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
8148 CORE_ADDR address
, struct value
*dval0
)
8150 struct value
*mark
= value_mark ();
8153 struct type
*branch_type
;
8154 int nfields
= TYPE_NFIELDS (type
);
8155 int variant_field
= variant_field_index (type
);
8157 if (variant_field
== -1)
8162 dval
= value_from_contents_and_address (type
, valaddr
, address
);
8163 type
= value_type (dval
);
8168 rtype
= alloc_type_copy (type
);
8169 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
8170 INIT_CPLUS_SPECIFIC (rtype
);
8171 TYPE_NFIELDS (rtype
) = nfields
;
8172 TYPE_FIELDS (rtype
) =
8173 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
8174 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
8175 sizeof (struct field
) * nfields
);
8176 TYPE_NAME (rtype
) = ada_type_name (type
);
8177 TYPE_TAG_NAME (rtype
) = NULL
;
8178 TYPE_FIXED_INSTANCE (rtype
) = 1;
8179 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
8181 branch_type
= to_fixed_variant_branch_type
8182 (TYPE_FIELD_TYPE (type
, variant_field
),
8183 cond_offset_host (valaddr
,
8184 TYPE_FIELD_BITPOS (type
, variant_field
)
8186 cond_offset_target (address
,
8187 TYPE_FIELD_BITPOS (type
, variant_field
)
8188 / TARGET_CHAR_BIT
), dval
);
8189 if (branch_type
== NULL
)
8193 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
8194 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
8195 TYPE_NFIELDS (rtype
) -= 1;
8199 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
8200 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
8201 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
8202 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
8204 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
8206 value_free_to_mark (mark
);
8210 /* An ordinary record type (with fixed-length fields) that describes
8211 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8212 beginning of this section]. Any necessary discriminants' values
8213 should be in DVAL, a record value; it may be NULL if the object
8214 at ADDR itself contains any necessary discriminant values.
8215 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8216 values from the record are needed. Except in the case that DVAL,
8217 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8218 unchecked) is replaced by a particular branch of the variant.
8220 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8221 is questionable and may be removed. It can arise during the
8222 processing of an unconstrained-array-of-record type where all the
8223 variant branches have exactly the same size. This is because in
8224 such cases, the compiler does not bother to use the XVS convention
8225 when encoding the record. I am currently dubious of this
8226 shortcut and suspect the compiler should be altered. FIXME. */
8228 static struct type
*
8229 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
8230 CORE_ADDR address
, struct value
*dval
)
8232 struct type
*templ_type
;
8234 if (TYPE_FIXED_INSTANCE (type0
))
8237 templ_type
= dynamic_template_type (type0
);
8239 if (templ_type
!= NULL
)
8240 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
8241 else if (variant_field_index (type0
) >= 0)
8243 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
8245 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
8250 TYPE_FIXED_INSTANCE (type0
) = 1;
8256 /* An ordinary record type (with fixed-length fields) that describes
8257 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8258 union type. Any necessary discriminants' values should be in DVAL,
8259 a record value. That is, this routine selects the appropriate
8260 branch of the union at ADDR according to the discriminant value
8261 indicated in the union's type name. Returns VAR_TYPE0 itself if
8262 it represents a variant subject to a pragma Unchecked_Union. */
8264 static struct type
*
8265 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
8266 CORE_ADDR address
, struct value
*dval
)
8269 struct type
*templ_type
;
8270 struct type
*var_type
;
8272 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
8273 var_type
= TYPE_TARGET_TYPE (var_type0
);
8275 var_type
= var_type0
;
8277 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8279 if (templ_type
!= NULL
)
8280 var_type
= templ_type
;
8282 if (is_unchecked_variant (var_type
, value_type (dval
)))
8285 ada_which_variant_applies (var_type
,
8286 value_type (dval
), value_contents (dval
));
8289 return empty_record (var_type
);
8290 else if (is_dynamic_field (var_type
, which
))
8291 return to_fixed_record_type
8292 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
8293 valaddr
, address
, dval
);
8294 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
8296 to_fixed_record_type
8297 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
8299 return TYPE_FIELD_TYPE (var_type
, which
);
8302 /* Assuming that TYPE0 is an array type describing the type of a value
8303 at ADDR, and that DVAL describes a record containing any
8304 discriminants used in TYPE0, returns a type for the value that
8305 contains no dynamic components (that is, no components whose sizes
8306 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8307 true, gives an error message if the resulting type's size is over
8310 static struct type
*
8311 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8314 struct type
*index_type_desc
;
8315 struct type
*result
;
8316 int constrained_packed_array_p
;
8318 type0
= ada_check_typedef (type0
);
8319 if (TYPE_FIXED_INSTANCE (type0
))
8322 constrained_packed_array_p
= ada_is_constrained_packed_array_type (type0
);
8323 if (constrained_packed_array_p
)
8324 type0
= decode_constrained_packed_array_type (type0
);
8326 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
8327 ada_fixup_array_indexes_type (index_type_desc
);
8328 if (index_type_desc
== NULL
)
8330 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
8332 /* NOTE: elt_type---the fixed version of elt_type0---should never
8333 depend on the contents of the array in properly constructed
8335 /* Create a fixed version of the array element type.
8336 We're not providing the address of an element here,
8337 and thus the actual object value cannot be inspected to do
8338 the conversion. This should not be a problem, since arrays of
8339 unconstrained objects are not allowed. In particular, all
8340 the elements of an array of a tagged type should all be of
8341 the same type specified in the debugging info. No need to
8342 consult the object tag. */
8343 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
8345 /* Make sure we always create a new array type when dealing with
8346 packed array types, since we're going to fix-up the array
8347 type length and element bitsize a little further down. */
8348 if (elt_type0
== elt_type
&& !constrained_packed_array_p
)
8351 result
= create_array_type (alloc_type_copy (type0
),
8352 elt_type
, TYPE_INDEX_TYPE (type0
));
8357 struct type
*elt_type0
;
8360 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
8361 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8363 /* NOTE: result---the fixed version of elt_type0---should never
8364 depend on the contents of the array in properly constructed
8366 /* Create a fixed version of the array element type.
8367 We're not providing the address of an element here,
8368 and thus the actual object value cannot be inspected to do
8369 the conversion. This should not be a problem, since arrays of
8370 unconstrained objects are not allowed. In particular, all
8371 the elements of an array of a tagged type should all be of
8372 the same type specified in the debugging info. No need to
8373 consult the object tag. */
8375 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
8378 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
8380 struct type
*range_type
=
8381 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc
, i
), dval
);
8383 result
= create_array_type (alloc_type_copy (elt_type0
),
8384 result
, range_type
);
8385 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8387 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8388 error (_("array type with dynamic size is larger than varsize-limit"));
8391 /* We want to preserve the type name. This can be useful when
8392 trying to get the type name of a value that has already been
8393 printed (for instance, if the user did "print VAR; whatis $". */
8394 TYPE_NAME (result
) = TYPE_NAME (type0
);
8396 if (constrained_packed_array_p
)
8398 /* So far, the resulting type has been created as if the original
8399 type was a regular (non-packed) array type. As a result, the
8400 bitsize of the array elements needs to be set again, and the array
8401 length needs to be recomputed based on that bitsize. */
8402 int len
= TYPE_LENGTH (result
) / TYPE_LENGTH (TYPE_TARGET_TYPE (result
));
8403 int elt_bitsize
= TYPE_FIELD_BITSIZE (type0
, 0);
8405 TYPE_FIELD_BITSIZE (result
, 0) = TYPE_FIELD_BITSIZE (type0
, 0);
8406 TYPE_LENGTH (result
) = len
* elt_bitsize
/ HOST_CHAR_BIT
;
8407 if (TYPE_LENGTH (result
) * HOST_CHAR_BIT
< len
* elt_bitsize
)
8408 TYPE_LENGTH (result
)++;
8411 TYPE_FIXED_INSTANCE (result
) = 1;
8416 /* A standard type (containing no dynamically sized components)
8417 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8418 DVAL describes a record containing any discriminants used in TYPE0,
8419 and may be NULL if there are none, or if the object of type TYPE at
8420 ADDRESS or in VALADDR contains these discriminants.
8422 If CHECK_TAG is not null, in the case of tagged types, this function
8423 attempts to locate the object's tag and use it to compute the actual
8424 type. However, when ADDRESS is null, we cannot use it to determine the
8425 location of the tag, and therefore compute the tagged type's actual type.
8426 So we return the tagged type without consulting the tag. */
8428 static struct type
*
8429 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
8430 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8432 type
= ada_check_typedef (type
);
8433 switch (TYPE_CODE (type
))
8437 case TYPE_CODE_STRUCT
:
8439 struct type
*static_type
= to_static_fixed_type (type
);
8440 struct type
*fixed_record_type
=
8441 to_fixed_record_type (type
, valaddr
, address
, NULL
);
8443 /* If STATIC_TYPE is a tagged type and we know the object's address,
8444 then we can determine its tag, and compute the object's actual
8445 type from there. Note that we have to use the fixed record
8446 type (the parent part of the record may have dynamic fields
8447 and the way the location of _tag is expressed may depend on
8450 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
8453 value_tag_from_contents_and_address
8457 struct type
*real_type
= type_from_tag (tag
);
8459 value_from_contents_and_address (fixed_record_type
,
8462 fixed_record_type
= value_type (obj
);
8463 if (real_type
!= NULL
)
8464 return to_fixed_record_type
8466 value_address (ada_tag_value_at_base_address (obj
)), NULL
);
8469 /* Check to see if there is a parallel ___XVZ variable.
8470 If there is, then it provides the actual size of our type. */
8471 else if (ada_type_name (fixed_record_type
) != NULL
)
8473 const char *name
= ada_type_name (fixed_record_type
);
8474 char *xvz_name
= alloca (strlen (name
) + 7 /* "___XVZ\0" */);
8478 xsnprintf (xvz_name
, strlen (name
) + 7, "%s___XVZ", name
);
8479 size
= get_int_var_value (xvz_name
, &xvz_found
);
8480 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
8482 fixed_record_type
= copy_type (fixed_record_type
);
8483 TYPE_LENGTH (fixed_record_type
) = size
;
8485 /* The FIXED_RECORD_TYPE may have be a stub. We have
8486 observed this when the debugging info is STABS, and
8487 apparently it is something that is hard to fix.
8489 In practice, we don't need the actual type definition
8490 at all, because the presence of the XVZ variable allows us
8491 to assume that there must be a XVS type as well, which we
8492 should be able to use later, when we need the actual type
8495 In the meantime, pretend that the "fixed" type we are
8496 returning is NOT a stub, because this can cause trouble
8497 when using this type to create new types targeting it.
8498 Indeed, the associated creation routines often check
8499 whether the target type is a stub and will try to replace
8500 it, thus using a type with the wrong size. This, in turn,
8501 might cause the new type to have the wrong size too.
8502 Consider the case of an array, for instance, where the size
8503 of the array is computed from the number of elements in
8504 our array multiplied by the size of its element. */
8505 TYPE_STUB (fixed_record_type
) = 0;
8508 return fixed_record_type
;
8510 case TYPE_CODE_ARRAY
:
8511 return to_fixed_array_type (type
, dval
, 1);
8512 case TYPE_CODE_UNION
:
8516 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8520 /* The same as ada_to_fixed_type_1, except that it preserves the type
8521 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8523 The typedef layer needs be preserved in order to differentiate between
8524 arrays and array pointers when both types are implemented using the same
8525 fat pointer. In the array pointer case, the pointer is encoded as
8526 a typedef of the pointer type. For instance, considering:
8528 type String_Access is access String;
8529 S1 : String_Access := null;
8531 To the debugger, S1 is defined as a typedef of type String. But
8532 to the user, it is a pointer. So if the user tries to print S1,
8533 we should not dereference the array, but print the array address
8536 If we didn't preserve the typedef layer, we would lose the fact that
8537 the type is to be presented as a pointer (needs de-reference before
8538 being printed). And we would also use the source-level type name. */
8541 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
8542 CORE_ADDR address
, struct value
*dval
, int check_tag
)
8545 struct type
*fixed_type
=
8546 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
8548 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8549 then preserve the typedef layer.
8551 Implementation note: We can only check the main-type portion of
8552 the TYPE and FIXED_TYPE, because eliminating the typedef layer
8553 from TYPE now returns a type that has the same instance flags
8554 as TYPE. For instance, if TYPE is a "typedef const", and its
8555 target type is a "struct", then the typedef elimination will return
8556 a "const" version of the target type. See check_typedef for more
8557 details about how the typedef layer elimination is done.
8559 brobecker/2010-11-19: It seems to me that the only case where it is
8560 useful to preserve the typedef layer is when dealing with fat pointers.
8561 Perhaps, we could add a check for that and preserve the typedef layer
8562 only in that situation. But this seems unecessary so far, probably
8563 because we call check_typedef/ada_check_typedef pretty much everywhere.
8565 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
8566 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type
))
8567 == TYPE_MAIN_TYPE (fixed_type
)))
8573 /* A standard (static-sized) type corresponding as well as possible to
8574 TYPE0, but based on no runtime data. */
8576 static struct type
*
8577 to_static_fixed_type (struct type
*type0
)
8584 if (TYPE_FIXED_INSTANCE (type0
))
8587 type0
= ada_check_typedef (type0
);
8589 switch (TYPE_CODE (type0
))
8593 case TYPE_CODE_STRUCT
:
8594 type
= dynamic_template_type (type0
);
8596 return template_to_static_fixed_type (type
);
8598 return template_to_static_fixed_type (type0
);
8599 case TYPE_CODE_UNION
:
8600 type
= ada_find_parallel_type (type0
, "___XVU");
8602 return template_to_static_fixed_type (type
);
8604 return template_to_static_fixed_type (type0
);
8608 /* A static approximation of TYPE with all type wrappers removed. */
8610 static struct type
*
8611 static_unwrap_type (struct type
*type
)
8613 if (ada_is_aligner_type (type
))
8615 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
8616 if (ada_type_name (type1
) == NULL
)
8617 TYPE_NAME (type1
) = ada_type_name (type
);
8619 return static_unwrap_type (type1
);
8623 struct type
*raw_real_type
= ada_get_base_type (type
);
8625 if (raw_real_type
== type
)
8628 return to_static_fixed_type (raw_real_type
);
8632 /* In some cases, incomplete and private types require
8633 cross-references that are not resolved as records (for example,
8635 type FooP is access Foo;
8637 type Foo is array ...;
8638 ). In these cases, since there is no mechanism for producing
8639 cross-references to such types, we instead substitute for FooP a
8640 stub enumeration type that is nowhere resolved, and whose tag is
8641 the name of the actual type. Call these types "non-record stubs". */
8643 /* A type equivalent to TYPE that is not a non-record stub, if one
8644 exists, otherwise TYPE. */
8647 ada_check_typedef (struct type
*type
)
8652 /* If our type is a typedef type of a fat pointer, then we're done.
8653 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8654 what allows us to distinguish between fat pointers that represent
8655 array types, and fat pointers that represent array access types
8656 (in both cases, the compiler implements them as fat pointers). */
8657 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
8658 && is_thick_pntr (ada_typedef_target_type (type
)))
8661 CHECK_TYPEDEF (type
);
8662 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
8663 || !TYPE_STUB (type
)
8664 || TYPE_TAG_NAME (type
) == NULL
)
8668 const char *name
= TYPE_TAG_NAME (type
);
8669 struct type
*type1
= ada_find_any_type (name
);
8674 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8675 stubs pointing to arrays, as we don't create symbols for array
8676 types, only for the typedef-to-array types). If that's the case,
8677 strip the typedef layer. */
8678 if (TYPE_CODE (type1
) == TYPE_CODE_TYPEDEF
)
8679 type1
= ada_check_typedef (type1
);
8685 /* A value representing the data at VALADDR/ADDRESS as described by
8686 type TYPE0, but with a standard (static-sized) type that correctly
8687 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8688 type, then return VAL0 [this feature is simply to avoid redundant
8689 creation of struct values]. */
8691 static struct value
*
8692 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8695 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
8697 if (type
== type0
&& val0
!= NULL
)
8700 return value_from_contents_and_address (type
, 0, address
);
8703 /* A value representing VAL, but with a standard (static-sized) type
8704 that correctly describes it. Does not necessarily create a new
8708 ada_to_fixed_value (struct value
*val
)
8710 val
= unwrap_value (val
);
8711 val
= ada_to_fixed_value_create (value_type (val
),
8712 value_address (val
),
8720 /* Table mapping attribute numbers to names.
8721 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8723 static const char *attribute_names
[] = {
8741 ada_attribute_name (enum exp_opcode n
)
8743 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8744 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8746 return attribute_names
[0];
8749 /* Evaluate the 'POS attribute applied to ARG. */
8752 pos_atr (struct value
*arg
)
8754 struct value
*val
= coerce_ref (arg
);
8755 struct type
*type
= value_type (val
);
8757 if (!discrete_type_p (type
))
8758 error (_("'POS only defined on discrete types"));
8760 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8763 LONGEST v
= value_as_long (val
);
8765 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
8767 if (v
== TYPE_FIELD_ENUMVAL (type
, i
))
8770 error (_("enumeration value is invalid: can't find 'POS"));
8773 return value_as_long (val
);
8776 static struct value
*
8777 value_pos_atr (struct type
*type
, struct value
*arg
)
8779 return value_from_longest (type
, pos_atr (arg
));
8782 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8784 static struct value
*
8785 value_val_atr (struct type
*type
, struct value
*arg
)
8787 if (!discrete_type_p (type
))
8788 error (_("'VAL only defined on discrete types"));
8789 if (!integer_type_p (value_type (arg
)))
8790 error (_("'VAL requires integral argument"));
8792 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8794 long pos
= value_as_long (arg
);
8796 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
8797 error (_("argument to 'VAL out of range"));
8798 return value_from_longest (type
, TYPE_FIELD_ENUMVAL (type
, pos
));
8801 return value_from_longest (type
, value_as_long (arg
));
8807 /* True if TYPE appears to be an Ada character type.
8808 [At the moment, this is true only for Character and Wide_Character;
8809 It is a heuristic test that could stand improvement]. */
8812 ada_is_character_type (struct type
*type
)
8816 /* If the type code says it's a character, then assume it really is,
8817 and don't check any further. */
8818 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
8821 /* Otherwise, assume it's a character type iff it is a discrete type
8822 with a known character type name. */
8823 name
= ada_type_name (type
);
8824 return (name
!= NULL
8825 && (TYPE_CODE (type
) == TYPE_CODE_INT
8826 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8827 && (strcmp (name
, "character") == 0
8828 || strcmp (name
, "wide_character") == 0
8829 || strcmp (name
, "wide_wide_character") == 0
8830 || strcmp (name
, "unsigned char") == 0));
8833 /* True if TYPE appears to be an Ada string type. */
8836 ada_is_string_type (struct type
*type
)
8838 type
= ada_check_typedef (type
);
8840 && TYPE_CODE (type
) != TYPE_CODE_PTR
8841 && (ada_is_simple_array_type (type
)
8842 || ada_is_array_descriptor_type (type
))
8843 && ada_array_arity (type
) == 1)
8845 struct type
*elttype
= ada_array_element_type (type
, 1);
8847 return ada_is_character_type (elttype
);
8853 /* The compiler sometimes provides a parallel XVS type for a given
8854 PAD type. Normally, it is safe to follow the PAD type directly,
8855 but older versions of the compiler have a bug that causes the offset
8856 of its "F" field to be wrong. Following that field in that case
8857 would lead to incorrect results, but this can be worked around
8858 by ignoring the PAD type and using the associated XVS type instead.
8860 Set to True if the debugger should trust the contents of PAD types.
8861 Otherwise, ignore the PAD type if there is a parallel XVS type. */
8862 static int trust_pad_over_xvs
= 1;
8864 /* True if TYPE is a struct type introduced by the compiler to force the
8865 alignment of a value. Such types have a single field with a
8866 distinctive name. */
8869 ada_is_aligner_type (struct type
*type
)
8871 type
= ada_check_typedef (type
);
8873 if (!trust_pad_over_xvs
&& ada_find_parallel_type (type
, "___XVS") != NULL
)
8876 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
8877 && TYPE_NFIELDS (type
) == 1
8878 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
8881 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8882 the parallel type. */
8885 ada_get_base_type (struct type
*raw_type
)
8887 struct type
*real_type_namer
;
8888 struct type
*raw_real_type
;
8890 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
8893 if (ada_is_aligner_type (raw_type
))
8894 /* The encoding specifies that we should always use the aligner type.
8895 So, even if this aligner type has an associated XVS type, we should
8898 According to the compiler gurus, an XVS type parallel to an aligner
8899 type may exist because of a stabs limitation. In stabs, aligner
8900 types are empty because the field has a variable-sized type, and
8901 thus cannot actually be used as an aligner type. As a result,
8902 we need the associated parallel XVS type to decode the type.
8903 Since the policy in the compiler is to not change the internal
8904 representation based on the debugging info format, we sometimes
8905 end up having a redundant XVS type parallel to the aligner type. */
8908 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
8909 if (real_type_namer
== NULL
8910 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
8911 || TYPE_NFIELDS (real_type_namer
) != 1)
8914 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer
, 0)) != TYPE_CODE_REF
)
8916 /* This is an older encoding form where the base type needs to be
8917 looked up by name. We prefer the newer enconding because it is
8919 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
8920 if (raw_real_type
== NULL
)
8923 return raw_real_type
;
8926 /* The field in our XVS type is a reference to the base type. */
8927 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer
, 0));
8930 /* The type of value designated by TYPE, with all aligners removed. */
8933 ada_aligned_type (struct type
*type
)
8935 if (ada_is_aligner_type (type
))
8936 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
8938 return ada_get_base_type (type
);
8942 /* The address of the aligned value in an object at address VALADDR
8943 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
8946 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
8948 if (ada_is_aligner_type (type
))
8949 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
8951 TYPE_FIELD_BITPOS (type
,
8952 0) / TARGET_CHAR_BIT
);
8959 /* The printed representation of an enumeration literal with encoded
8960 name NAME. The value is good to the next call of ada_enum_name. */
8962 ada_enum_name (const char *name
)
8964 static char *result
;
8965 static size_t result_len
= 0;
8968 /* First, unqualify the enumeration name:
8969 1. Search for the last '.' character. If we find one, then skip
8970 all the preceding characters, the unqualified name starts
8971 right after that dot.
8972 2. Otherwise, we may be debugging on a target where the compiler
8973 translates dots into "__". Search forward for double underscores,
8974 but stop searching when we hit an overloading suffix, which is
8975 of the form "__" followed by digits. */
8977 tmp
= strrchr (name
, '.');
8982 while ((tmp
= strstr (name
, "__")) != NULL
)
8984 if (isdigit (tmp
[2]))
8995 if (name
[1] == 'U' || name
[1] == 'W')
8997 if (sscanf (name
+ 2, "%x", &v
) != 1)
9003 GROW_VECT (result
, result_len
, 16);
9004 if (isascii (v
) && isprint (v
))
9005 xsnprintf (result
, result_len
, "'%c'", v
);
9006 else if (name
[1] == 'U')
9007 xsnprintf (result
, result_len
, "[\"%02x\"]", v
);
9009 xsnprintf (result
, result_len
, "[\"%04x\"]", v
);
9015 tmp
= strstr (name
, "__");
9017 tmp
= strstr (name
, "$");
9020 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
9021 strncpy (result
, name
, tmp
- name
);
9022 result
[tmp
- name
] = '\0';
9030 /* Evaluate the subexpression of EXP starting at *POS as for
9031 evaluate_type, updating *POS to point just past the evaluated
9034 static struct value
*
9035 evaluate_subexp_type (struct expression
*exp
, int *pos
)
9037 return evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
9040 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9043 static struct value
*
9044 unwrap_value (struct value
*val
)
9046 struct type
*type
= ada_check_typedef (value_type (val
));
9048 if (ada_is_aligner_type (type
))
9050 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
9051 struct type
*val_type
= ada_check_typedef (value_type (v
));
9053 if (ada_type_name (val_type
) == NULL
)
9054 TYPE_NAME (val_type
) = ada_type_name (type
);
9056 return unwrap_value (v
);
9060 struct type
*raw_real_type
=
9061 ada_check_typedef (ada_get_base_type (type
));
9063 /* If there is no parallel XVS or XVE type, then the value is
9064 already unwrapped. Return it without further modification. */
9065 if ((type
== raw_real_type
)
9066 && ada_find_parallel_type (type
, "___XVE") == NULL
)
9070 coerce_unspec_val_to_type
9071 (val
, ada_to_fixed_type (raw_real_type
, 0,
9072 value_address (val
),
9077 static struct value
*
9078 cast_to_fixed (struct type
*type
, struct value
*arg
)
9082 if (type
== value_type (arg
))
9084 else if (ada_is_fixed_point_type (value_type (arg
)))
9085 val
= ada_float_to_fixed (type
,
9086 ada_fixed_to_float (value_type (arg
),
9087 value_as_long (arg
)));
9090 DOUBLEST argd
= value_as_double (arg
);
9092 val
= ada_float_to_fixed (type
, argd
);
9095 return value_from_longest (type
, val
);
9098 static struct value
*
9099 cast_from_fixed (struct type
*type
, struct value
*arg
)
9101 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
9102 value_as_long (arg
));
9104 return value_from_double (type
, val
);
9107 /* Given two array types T1 and T2, return nonzero iff both arrays
9108 contain the same number of elements. */
9111 ada_same_array_size_p (struct type
*t1
, struct type
*t2
)
9113 LONGEST lo1
, hi1
, lo2
, hi2
;
9115 /* Get the array bounds in order to verify that the size of
9116 the two arrays match. */
9117 if (!get_array_bounds (t1
, &lo1
, &hi1
)
9118 || !get_array_bounds (t2
, &lo2
, &hi2
))
9119 error (_("unable to determine array bounds"));
9121 /* To make things easier for size comparison, normalize a bit
9122 the case of empty arrays by making sure that the difference
9123 between upper bound and lower bound is always -1. */
9129 return (hi1
- lo1
== hi2
- lo2
);
9132 /* Assuming that VAL is an array of integrals, and TYPE represents
9133 an array with the same number of elements, but with wider integral
9134 elements, return an array "casted" to TYPE. In practice, this
9135 means that the returned array is built by casting each element
9136 of the original array into TYPE's (wider) element type. */
9138 static struct value
*
9139 ada_promote_array_of_integrals (struct type
*type
, struct value
*val
)
9141 struct type
*elt_type
= TYPE_TARGET_TYPE (type
);
9146 /* Verify that both val and type are arrays of scalars, and
9147 that the size of val's elements is smaller than the size
9148 of type's element. */
9149 gdb_assert (TYPE_CODE (type
) == TYPE_CODE_ARRAY
);
9150 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type
)));
9151 gdb_assert (TYPE_CODE (value_type (val
)) == TYPE_CODE_ARRAY
);
9152 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val
))));
9153 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type
))
9154 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val
))));
9156 if (!get_array_bounds (type
, &lo
, &hi
))
9157 error (_("unable to determine array bounds"));
9159 res
= allocate_value (type
);
9161 /* Promote each array element. */
9162 for (i
= 0; i
< hi
- lo
+ 1; i
++)
9164 struct value
*elt
= value_cast (elt_type
, value_subscript (val
, lo
+ i
));
9166 memcpy (value_contents_writeable (res
) + (i
* TYPE_LENGTH (elt_type
)),
9167 value_contents_all (elt
), TYPE_LENGTH (elt_type
));
9173 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9174 return the converted value. */
9176 static struct value
*
9177 coerce_for_assign (struct type
*type
, struct value
*val
)
9179 struct type
*type2
= value_type (val
);
9184 type2
= ada_check_typedef (type2
);
9185 type
= ada_check_typedef (type
);
9187 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
9188 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9190 val
= ada_value_ind (val
);
9191 type2
= value_type (val
);
9194 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
9195 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9197 if (!ada_same_array_size_p (type
, type2
))
9198 error (_("cannot assign arrays of different length"));
9200 if (is_integral_type (TYPE_TARGET_TYPE (type
))
9201 && is_integral_type (TYPE_TARGET_TYPE (type2
))
9202 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9203 < TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9205 /* Allow implicit promotion of the array elements to
9207 return ada_promote_array_of_integrals (type
, val
);
9210 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
9211 != TYPE_LENGTH (TYPE_TARGET_TYPE (type
)))
9212 error (_("Incompatible types in assignment"));
9213 deprecated_set_value_type (val
, type
);
9218 static struct value
*
9219 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
9222 struct type
*type1
, *type2
;
9225 arg1
= coerce_ref (arg1
);
9226 arg2
= coerce_ref (arg2
);
9227 type1
= get_base_type (ada_check_typedef (value_type (arg1
)));
9228 type2
= get_base_type (ada_check_typedef (value_type (arg2
)));
9230 if (TYPE_CODE (type1
) != TYPE_CODE_INT
9231 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
9232 return value_binop (arg1
, arg2
, op
);
9241 return value_binop (arg1
, arg2
, op
);
9244 v2
= value_as_long (arg2
);
9246 error (_("second operand of %s must not be zero."), op_string (op
));
9248 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
9249 return value_binop (arg1
, arg2
, op
);
9251 v1
= value_as_long (arg1
);
9256 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
9257 v
+= v
> 0 ? -1 : 1;
9265 /* Should not reach this point. */
9269 val
= allocate_value (type1
);
9270 store_unsigned_integer (value_contents_raw (val
),
9271 TYPE_LENGTH (value_type (val
)),
9272 gdbarch_byte_order (get_type_arch (type1
)), v
);
9277 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
9279 if (ada_is_direct_array_type (value_type (arg1
))
9280 || ada_is_direct_array_type (value_type (arg2
)))
9282 /* Automatically dereference any array reference before
9283 we attempt to perform the comparison. */
9284 arg1
= ada_coerce_ref (arg1
);
9285 arg2
= ada_coerce_ref (arg2
);
9287 arg1
= ada_coerce_to_simple_array (arg1
);
9288 arg2
= ada_coerce_to_simple_array (arg2
);
9289 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
9290 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
9291 error (_("Attempt to compare array with non-array"));
9292 /* FIXME: The following works only for types whose
9293 representations use all bits (no padding or undefined bits)
9294 and do not have user-defined equality. */
9296 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
9297 && memcmp (value_contents (arg1
), value_contents (arg2
),
9298 TYPE_LENGTH (value_type (arg1
))) == 0;
9300 return value_equal (arg1
, arg2
);
9303 /* Total number of component associations in the aggregate starting at
9304 index PC in EXP. Assumes that index PC is the start of an
9308 num_component_specs (struct expression
*exp
, int pc
)
9312 m
= exp
->elts
[pc
+ 1].longconst
;
9315 for (i
= 0; i
< m
; i
+= 1)
9317 switch (exp
->elts
[pc
].opcode
)
9323 n
+= exp
->elts
[pc
+ 1].longconst
;
9326 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
9331 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9332 component of LHS (a simple array or a record), updating *POS past
9333 the expression, assuming that LHS is contained in CONTAINER. Does
9334 not modify the inferior's memory, nor does it modify LHS (unless
9335 LHS == CONTAINER). */
9338 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
9339 struct expression
*exp
, int *pos
)
9341 struct value
*mark
= value_mark ();
9344 if (TYPE_CODE (value_type (lhs
)) == TYPE_CODE_ARRAY
)
9346 struct type
*index_type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9347 struct value
*index_val
= value_from_longest (index_type
, index
);
9349 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
9353 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
9354 elt
= ada_to_fixed_value (elt
);
9357 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9358 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
9360 value_assign_to_component (container
, elt
,
9361 ada_evaluate_subexp (NULL
, exp
, pos
,
9364 value_free_to_mark (mark
);
9367 /* Assuming that LHS represents an lvalue having a record or array
9368 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9369 of that aggregate's value to LHS, advancing *POS past the
9370 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9371 lvalue containing LHS (possibly LHS itself). Does not modify
9372 the inferior's memory, nor does it modify the contents of
9373 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9375 static struct value
*
9376 assign_aggregate (struct value
*container
,
9377 struct value
*lhs
, struct expression
*exp
,
9378 int *pos
, enum noside noside
)
9380 struct type
*lhs_type
;
9381 int n
= exp
->elts
[*pos
+1].longconst
;
9382 LONGEST low_index
, high_index
;
9385 int max_indices
, num_indices
;
9389 if (noside
!= EVAL_NORMAL
)
9391 for (i
= 0; i
< n
; i
+= 1)
9392 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9396 container
= ada_coerce_ref (container
);
9397 if (ada_is_direct_array_type (value_type (container
)))
9398 container
= ada_coerce_to_simple_array (container
);
9399 lhs
= ada_coerce_ref (lhs
);
9400 if (!deprecated_value_modifiable (lhs
))
9401 error (_("Left operand of assignment is not a modifiable lvalue."));
9403 lhs_type
= value_type (lhs
);
9404 if (ada_is_direct_array_type (lhs_type
))
9406 lhs
= ada_coerce_to_simple_array (lhs
);
9407 lhs_type
= value_type (lhs
);
9408 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
9409 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
9411 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
9414 high_index
= num_visible_fields (lhs_type
) - 1;
9417 error (_("Left-hand side must be array or record."));
9419 num_specs
= num_component_specs (exp
, *pos
- 3);
9420 max_indices
= 4 * num_specs
+ 4;
9421 indices
= alloca (max_indices
* sizeof (indices
[0]));
9422 indices
[0] = indices
[1] = low_index
- 1;
9423 indices
[2] = indices
[3] = high_index
+ 1;
9426 for (i
= 0; i
< n
; i
+= 1)
9428 switch (exp
->elts
[*pos
].opcode
)
9431 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
9432 &num_indices
, max_indices
,
9433 low_index
, high_index
);
9436 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
9437 &num_indices
, max_indices
,
9438 low_index
, high_index
);
9442 error (_("Misplaced 'others' clause"));
9443 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
9444 num_indices
, low_index
, high_index
);
9447 error (_("Internal error: bad aggregate clause"));
9454 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9455 construct at *POS, updating *POS past the construct, given that
9456 the positions are relative to lower bound LOW, where HIGH is the
9457 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9458 updating *NUM_INDICES as needed. CONTAINER is as for
9459 assign_aggregate. */
9461 aggregate_assign_positional (struct value
*container
,
9462 struct value
*lhs
, struct expression
*exp
,
9463 int *pos
, LONGEST
*indices
, int *num_indices
,
9464 int max_indices
, LONGEST low
, LONGEST high
)
9466 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
9468 if (ind
- 1 == high
)
9469 warning (_("Extra components in aggregate ignored."));
9472 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
9474 assign_component (container
, lhs
, ind
, exp
, pos
);
9477 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9480 /* Assign into the components of LHS indexed by the OP_CHOICES
9481 construct at *POS, updating *POS past the construct, given that
9482 the allowable indices are LOW..HIGH. Record the indices assigned
9483 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9484 needed. CONTAINER is as for assign_aggregate. */
9486 aggregate_assign_from_choices (struct value
*container
,
9487 struct value
*lhs
, struct expression
*exp
,
9488 int *pos
, LONGEST
*indices
, int *num_indices
,
9489 int max_indices
, LONGEST low
, LONGEST high
)
9492 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
9493 int choice_pos
, expr_pc
;
9494 int is_array
= ada_is_direct_array_type (value_type (lhs
));
9496 choice_pos
= *pos
+= 3;
9498 for (j
= 0; j
< n_choices
; j
+= 1)
9499 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9501 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9503 for (j
= 0; j
< n_choices
; j
+= 1)
9505 LONGEST lower
, upper
;
9506 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
9508 if (op
== OP_DISCRETE_RANGE
)
9511 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9513 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
9518 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
9530 name
= &exp
->elts
[choice_pos
+ 2].string
;
9533 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
9536 error (_("Invalid record component association."));
9538 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
9540 if (! find_struct_field (name
, value_type (lhs
), 0,
9541 NULL
, NULL
, NULL
, NULL
, &ind
))
9542 error (_("Unknown component name: %s."), name
);
9543 lower
= upper
= ind
;
9546 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
9547 error (_("Index in component association out of bounds."));
9549 add_component_interval (lower
, upper
, indices
, num_indices
,
9551 while (lower
<= upper
)
9556 assign_component (container
, lhs
, lower
, exp
, &pos1
);
9562 /* Assign the value of the expression in the OP_OTHERS construct in
9563 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9564 have not been previously assigned. The index intervals already assigned
9565 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9566 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9568 aggregate_assign_others (struct value
*container
,
9569 struct value
*lhs
, struct expression
*exp
,
9570 int *pos
, LONGEST
*indices
, int num_indices
,
9571 LONGEST low
, LONGEST high
)
9574 int expr_pc
= *pos
+ 1;
9576 for (i
= 0; i
< num_indices
- 2; i
+= 2)
9580 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
9585 assign_component (container
, lhs
, ind
, exp
, &localpos
);
9588 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
9591 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9592 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9593 modifying *SIZE as needed. It is an error if *SIZE exceeds
9594 MAX_SIZE. The resulting intervals do not overlap. */
9596 add_component_interval (LONGEST low
, LONGEST high
,
9597 LONGEST
* indices
, int *size
, int max_size
)
9601 for (i
= 0; i
< *size
; i
+= 2) {
9602 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
9606 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
9607 if (high
< indices
[kh
])
9609 if (low
< indices
[i
])
9611 indices
[i
+ 1] = indices
[kh
- 1];
9612 if (high
> indices
[i
+ 1])
9613 indices
[i
+ 1] = high
;
9614 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
9615 *size
-= kh
- i
- 2;
9618 else if (high
< indices
[i
])
9622 if (*size
== max_size
)
9623 error (_("Internal error: miscounted aggregate components."));
9625 for (j
= *size
-1; j
>= i
+2; j
-= 1)
9626 indices
[j
] = indices
[j
- 2];
9628 indices
[i
+ 1] = high
;
9631 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9634 static struct value
*
9635 ada_value_cast (struct type
*type
, struct value
*arg2
, enum noside noside
)
9637 if (type
== ada_check_typedef (value_type (arg2
)))
9640 if (ada_is_fixed_point_type (type
))
9641 return (cast_to_fixed (type
, arg2
));
9643 if (ada_is_fixed_point_type (value_type (arg2
)))
9644 return cast_from_fixed (type
, arg2
);
9646 return value_cast (type
, arg2
);
9649 /* Evaluating Ada expressions, and printing their result.
9650 ------------------------------------------------------
9655 We usually evaluate an Ada expression in order to print its value.
9656 We also evaluate an expression in order to print its type, which
9657 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9658 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9659 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9660 the evaluation compared to the EVAL_NORMAL, but is otherwise very
9663 Evaluating expressions is a little more complicated for Ada entities
9664 than it is for entities in languages such as C. The main reason for
9665 this is that Ada provides types whose definition might be dynamic.
9666 One example of such types is variant records. Or another example
9667 would be an array whose bounds can only be known at run time.
9669 The following description is a general guide as to what should be
9670 done (and what should NOT be done) in order to evaluate an expression
9671 involving such types, and when. This does not cover how the semantic
9672 information is encoded by GNAT as this is covered separatly. For the
9673 document used as the reference for the GNAT encoding, see exp_dbug.ads
9674 in the GNAT sources.
9676 Ideally, we should embed each part of this description next to its
9677 associated code. Unfortunately, the amount of code is so vast right
9678 now that it's hard to see whether the code handling a particular
9679 situation might be duplicated or not. One day, when the code is
9680 cleaned up, this guide might become redundant with the comments
9681 inserted in the code, and we might want to remove it.
9683 2. ``Fixing'' an Entity, the Simple Case:
9684 -----------------------------------------
9686 When evaluating Ada expressions, the tricky issue is that they may
9687 reference entities whose type contents and size are not statically
9688 known. Consider for instance a variant record:
9690 type Rec (Empty : Boolean := True) is record
9693 when False => Value : Integer;
9696 Yes : Rec := (Empty => False, Value => 1);
9697 No : Rec := (empty => True);
9699 The size and contents of that record depends on the value of the
9700 descriminant (Rec.Empty). At this point, neither the debugging
9701 information nor the associated type structure in GDB are able to
9702 express such dynamic types. So what the debugger does is to create
9703 "fixed" versions of the type that applies to the specific object.
9704 We also informally refer to this opperation as "fixing" an object,
9705 which means creating its associated fixed type.
9707 Example: when printing the value of variable "Yes" above, its fixed
9708 type would look like this:
9715 On the other hand, if we printed the value of "No", its fixed type
9722 Things become a little more complicated when trying to fix an entity
9723 with a dynamic type that directly contains another dynamic type,
9724 such as an array of variant records, for instance. There are
9725 two possible cases: Arrays, and records.
9727 3. ``Fixing'' Arrays:
9728 ---------------------
9730 The type structure in GDB describes an array in terms of its bounds,
9731 and the type of its elements. By design, all elements in the array
9732 have the same type and we cannot represent an array of variant elements
9733 using the current type structure in GDB. When fixing an array,
9734 we cannot fix the array element, as we would potentially need one
9735 fixed type per element of the array. As a result, the best we can do
9736 when fixing an array is to produce an array whose bounds and size
9737 are correct (allowing us to read it from memory), but without having
9738 touched its element type. Fixing each element will be done later,
9739 when (if) necessary.
9741 Arrays are a little simpler to handle than records, because the same
9742 amount of memory is allocated for each element of the array, even if
9743 the amount of space actually used by each element differs from element
9744 to element. Consider for instance the following array of type Rec:
9746 type Rec_Array is array (1 .. 2) of Rec;
9748 The actual amount of memory occupied by each element might be different
9749 from element to element, depending on the value of their discriminant.
9750 But the amount of space reserved for each element in the array remains
9751 fixed regardless. So we simply need to compute that size using
9752 the debugging information available, from which we can then determine
9753 the array size (we multiply the number of elements of the array by
9754 the size of each element).
9756 The simplest case is when we have an array of a constrained element
9757 type. For instance, consider the following type declarations:
9759 type Bounded_String (Max_Size : Integer) is
9761 Buffer : String (1 .. Max_Size);
9763 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
9765 In this case, the compiler describes the array as an array of
9766 variable-size elements (identified by its XVS suffix) for which
9767 the size can be read in the parallel XVZ variable.
9769 In the case of an array of an unconstrained element type, the compiler
9770 wraps the array element inside a private PAD type. This type should not
9771 be shown to the user, and must be "unwrap"'ed before printing. Note
9772 that we also use the adjective "aligner" in our code to designate
9773 these wrapper types.
9775 In some cases, the size allocated for each element is statically
9776 known. In that case, the PAD type already has the correct size,
9777 and the array element should remain unfixed.
9779 But there are cases when this size is not statically known.
9780 For instance, assuming that "Five" is an integer variable:
9782 type Dynamic is array (1 .. Five) of Integer;
9783 type Wrapper (Has_Length : Boolean := False) is record
9786 when True => Length : Integer;
9790 type Wrapper_Array is array (1 .. 2) of Wrapper;
9792 Hello : Wrapper_Array := (others => (Has_Length => True,
9793 Data => (others => 17),
9797 The debugging info would describe variable Hello as being an
9798 array of a PAD type. The size of that PAD type is not statically
9799 known, but can be determined using a parallel XVZ variable.
9800 In that case, a copy of the PAD type with the correct size should
9801 be used for the fixed array.
9803 3. ``Fixing'' record type objects:
9804 ----------------------------------
9806 Things are slightly different from arrays in the case of dynamic
9807 record types. In this case, in order to compute the associated
9808 fixed type, we need to determine the size and offset of each of
9809 its components. This, in turn, requires us to compute the fixed
9810 type of each of these components.
9812 Consider for instance the example:
9814 type Bounded_String (Max_Size : Natural) is record
9815 Str : String (1 .. Max_Size);
9818 My_String : Bounded_String (Max_Size => 10);
9820 In that case, the position of field "Length" depends on the size
9821 of field Str, which itself depends on the value of the Max_Size
9822 discriminant. In order to fix the type of variable My_String,
9823 we need to fix the type of field Str. Therefore, fixing a variant
9824 record requires us to fix each of its components.
9826 However, if a component does not have a dynamic size, the component
9827 should not be fixed. In particular, fields that use a PAD type
9828 should not fixed. Here is an example where this might happen
9829 (assuming type Rec above):
9831 type Container (Big : Boolean) is record
9835 when True => Another : Integer;
9839 My_Container : Container := (Big => False,
9840 First => (Empty => True),
9843 In that example, the compiler creates a PAD type for component First,
9844 whose size is constant, and then positions the component After just
9845 right after it. The offset of component After is therefore constant
9848 The debugger computes the position of each field based on an algorithm
9849 that uses, among other things, the actual position and size of the field
9850 preceding it. Let's now imagine that the user is trying to print
9851 the value of My_Container. If the type fixing was recursive, we would
9852 end up computing the offset of field After based on the size of the
9853 fixed version of field First. And since in our example First has
9854 only one actual field, the size of the fixed type is actually smaller
9855 than the amount of space allocated to that field, and thus we would
9856 compute the wrong offset of field After.
9858 To make things more complicated, we need to watch out for dynamic
9859 components of variant records (identified by the ___XVL suffix in
9860 the component name). Even if the target type is a PAD type, the size
9861 of that type might not be statically known. So the PAD type needs
9862 to be unwrapped and the resulting type needs to be fixed. Otherwise,
9863 we might end up with the wrong size for our component. This can be
9864 observed with the following type declarations:
9866 type Octal is new Integer range 0 .. 7;
9867 type Octal_Array is array (Positive range <>) of Octal;
9868 pragma Pack (Octal_Array);
9870 type Octal_Buffer (Size : Positive) is record
9871 Buffer : Octal_Array (1 .. Size);
9875 In that case, Buffer is a PAD type whose size is unset and needs
9876 to be computed by fixing the unwrapped type.
9878 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
9879 ----------------------------------------------------------
9881 Lastly, when should the sub-elements of an entity that remained unfixed
9882 thus far, be actually fixed?
9884 The answer is: Only when referencing that element. For instance
9885 when selecting one component of a record, this specific component
9886 should be fixed at that point in time. Or when printing the value
9887 of a record, each component should be fixed before its value gets
9888 printed. Similarly for arrays, the element of the array should be
9889 fixed when printing each element of the array, or when extracting
9890 one element out of that array. On the other hand, fixing should
9891 not be performed on the elements when taking a slice of an array!
9893 Note that one of the side-effects of miscomputing the offset and
9894 size of each field is that we end up also miscomputing the size
9895 of the containing type. This can have adverse results when computing
9896 the value of an entity. GDB fetches the value of an entity based
9897 on the size of its type, and thus a wrong size causes GDB to fetch
9898 the wrong amount of memory. In the case where the computed size is
9899 too small, GDB fetches too little data to print the value of our
9900 entiry. Results in this case as unpredicatble, as we usually read
9901 past the buffer containing the data =:-o. */
9903 /* Implement the evaluate_exp routine in the exp_descriptor structure
9904 for the Ada language. */
9906 static struct value
*
9907 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
9908 int *pos
, enum noside noside
)
9914 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
9917 struct value
**argvec
;
9921 op
= exp
->elts
[pc
].opcode
;
9927 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9929 if (noside
== EVAL_NORMAL
)
9930 arg1
= unwrap_value (arg1
);
9932 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
9933 then we need to perform the conversion manually, because
9934 evaluate_subexp_standard doesn't do it. This conversion is
9935 necessary in Ada because the different kinds of float/fixed
9936 types in Ada have different representations.
9938 Similarly, we need to perform the conversion from OP_LONG
9940 if ((op
== OP_DOUBLE
|| op
== OP_LONG
) && expect_type
!= NULL
)
9941 arg1
= ada_value_cast (expect_type
, arg1
, noside
);
9947 struct value
*result
;
9950 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
9951 /* The result type will have code OP_STRING, bashed there from
9952 OP_ARRAY. Bash it back. */
9953 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
9954 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
9960 type
= exp
->elts
[pc
+ 1].type
;
9961 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
9962 if (noside
== EVAL_SKIP
)
9964 arg1
= ada_value_cast (type
, arg1
, noside
);
9969 type
= exp
->elts
[pc
+ 1].type
;
9970 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
9973 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9974 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
9976 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
9977 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
9979 return ada_value_assign (arg1
, arg1
);
9981 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
9982 except if the lhs of our assignment is a convenience variable.
9983 In the case of assigning to a convenience variable, the lhs
9984 should be exactly the result of the evaluation of the rhs. */
9985 type
= value_type (arg1
);
9986 if (VALUE_LVAL (arg1
) == lval_internalvar
)
9988 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
9989 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
9991 if (ada_is_fixed_point_type (value_type (arg1
)))
9992 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
9993 else if (ada_is_fixed_point_type (value_type (arg2
)))
9995 (_("Fixed-point values must be assigned to fixed-point variables"));
9997 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
9998 return ada_value_assign (arg1
, arg2
);
10001 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10002 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10003 if (noside
== EVAL_SKIP
)
10005 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
10006 return (value_from_longest
10007 (value_type (arg1
),
10008 value_as_long (arg1
) + value_as_long (arg2
)));
10009 if (TYPE_CODE (value_type (arg2
)) == TYPE_CODE_PTR
)
10010 return (value_from_longest
10011 (value_type (arg2
),
10012 value_as_long (arg1
) + value_as_long (arg2
)));
10013 if ((ada_is_fixed_point_type (value_type (arg1
))
10014 || ada_is_fixed_point_type (value_type (arg2
)))
10015 && value_type (arg1
) != value_type (arg2
))
10016 error (_("Operands of fixed-point addition must have the same type"));
10017 /* Do the addition, and cast the result to the type of the first
10018 argument. We cannot cast the result to a reference type, so if
10019 ARG1 is a reference type, find its underlying type. */
10020 type
= value_type (arg1
);
10021 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
10022 type
= TYPE_TARGET_TYPE (type
);
10023 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10024 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
10027 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10028 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
10029 if (noside
== EVAL_SKIP
)
10031 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
10032 return (value_from_longest
10033 (value_type (arg1
),
10034 value_as_long (arg1
) - value_as_long (arg2
)));
10035 if (TYPE_CODE (value_type (arg2
)) == TYPE_CODE_PTR
)
10036 return (value_from_longest
10037 (value_type (arg2
),
10038 value_as_long (arg1
) - value_as_long (arg2
)));
10039 if ((ada_is_fixed_point_type (value_type (arg1
))
10040 || ada_is_fixed_point_type (value_type (arg2
)))
10041 && value_type (arg1
) != value_type (arg2
))
10042 error (_("Operands of fixed-point subtraction "
10043 "must have the same type"));
10044 /* Do the substraction, and cast the result to the type of the first
10045 argument. We cannot cast the result to a reference type, so if
10046 ARG1 is a reference type, find its underlying type. */
10047 type
= value_type (arg1
);
10048 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
10049 type
= TYPE_TARGET_TYPE (type
);
10050 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10051 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
10057 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10058 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10059 if (noside
== EVAL_SKIP
)
10061 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10063 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10064 return value_zero (value_type (arg1
), not_lval
);
10068 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
10069 if (ada_is_fixed_point_type (value_type (arg1
)))
10070 arg1
= cast_from_fixed (type
, arg1
);
10071 if (ada_is_fixed_point_type (value_type (arg2
)))
10072 arg2
= cast_from_fixed (type
, arg2
);
10073 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10074 return ada_value_binop (arg1
, arg2
, op
);
10078 case BINOP_NOTEQUAL
:
10079 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10080 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
10081 if (noside
== EVAL_SKIP
)
10083 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10087 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10088 tem
= ada_value_equal (arg1
, arg2
);
10090 if (op
== BINOP_NOTEQUAL
)
10092 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10093 return value_from_longest (type
, (LONGEST
) tem
);
10096 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10097 if (noside
== EVAL_SKIP
)
10099 else if (ada_is_fixed_point_type (value_type (arg1
)))
10100 return value_cast (value_type (arg1
), value_neg (arg1
));
10103 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10104 return value_neg (arg1
);
10107 case BINOP_LOGICAL_AND
:
10108 case BINOP_LOGICAL_OR
:
10109 case UNOP_LOGICAL_NOT
:
10114 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10115 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10116 return value_cast (type
, val
);
10119 case BINOP_BITWISE_AND
:
10120 case BINOP_BITWISE_IOR
:
10121 case BINOP_BITWISE_XOR
:
10125 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
10127 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10129 return value_cast (value_type (arg1
), val
);
10135 if (noside
== EVAL_SKIP
)
10141 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
10142 /* Only encountered when an unresolved symbol occurs in a
10143 context other than a function call, in which case, it is
10145 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10146 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
10148 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10150 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
10151 /* Check to see if this is a tagged type. We also need to handle
10152 the case where the type is a reference to a tagged type, but
10153 we have to be careful to exclude pointers to tagged types.
10154 The latter should be shown as usual (as a pointer), whereas
10155 a reference should mostly be transparent to the user. */
10156 if (ada_is_tagged_type (type
, 0)
10157 || (TYPE_CODE (type
) == TYPE_CODE_REF
10158 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0)))
10160 /* Tagged types are a little special in the fact that the real
10161 type is dynamic and can only be determined by inspecting the
10162 object's tag. This means that we need to get the object's
10163 value first (EVAL_NORMAL) and then extract the actual object
10166 Note that we cannot skip the final step where we extract
10167 the object type from its tag, because the EVAL_NORMAL phase
10168 results in dynamic components being resolved into fixed ones.
10169 This can cause problems when trying to print the type
10170 description of tagged types whose parent has a dynamic size:
10171 We use the type name of the "_parent" component in order
10172 to print the name of the ancestor type in the type description.
10173 If that component had a dynamic size, the resolution into
10174 a fixed type would result in the loss of that type name,
10175 thus preventing us from printing the name of the ancestor
10176 type in the type description. */
10177 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
10179 if (TYPE_CODE (type
) != TYPE_CODE_REF
)
10181 struct type
*actual_type
;
10183 actual_type
= type_from_tag (ada_value_tag (arg1
));
10184 if (actual_type
== NULL
)
10185 /* If, for some reason, we were unable to determine
10186 the actual type from the tag, then use the static
10187 approximation that we just computed as a fallback.
10188 This can happen if the debugging information is
10189 incomplete, for instance. */
10190 actual_type
= type
;
10191 return value_zero (actual_type
, not_lval
);
10195 /* In the case of a ref, ada_coerce_ref takes care
10196 of determining the actual type. But the evaluation
10197 should return a ref as it should be valid to ask
10198 for its address; so rebuild a ref after coerce. */
10199 arg1
= ada_coerce_ref (arg1
);
10200 return value_ref (arg1
);
10204 /* Records and unions for which GNAT encodings have been
10205 generated need to be statically fixed as well.
10206 Otherwise, non-static fixing produces a type where
10207 all dynamic properties are removed, which prevents "ptype"
10208 from being able to completely describe the type.
10209 For instance, a case statement in a variant record would be
10210 replaced by the relevant components based on the actual
10211 value of the discriminants. */
10212 if ((TYPE_CODE (type
) == TYPE_CODE_STRUCT
10213 && dynamic_template_type (type
) != NULL
)
10214 || (TYPE_CODE (type
) == TYPE_CODE_UNION
10215 && ada_find_parallel_type (type
, "___XVU") != NULL
))
10218 return value_zero (to_static_fixed_type (type
), not_lval
);
10222 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
10223 return ada_to_fixed_value (arg1
);
10228 /* Allocate arg vector, including space for the function to be
10229 called in argvec[0] and a terminating NULL. */
10230 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10232 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
10234 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
10235 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
10236 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10237 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
10240 for (tem
= 0; tem
<= nargs
; tem
+= 1)
10241 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10244 if (noside
== EVAL_SKIP
)
10248 if (ada_is_constrained_packed_array_type
10249 (desc_base_type (value_type (argvec
[0]))))
10250 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
10251 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
10252 && TYPE_FIELD_BITSIZE (value_type (argvec
[0]), 0) != 0)
10253 /* This is a packed array that has already been fixed, and
10254 therefore already coerced to a simple array. Nothing further
10257 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
10258 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
10259 && VALUE_LVAL (argvec
[0]) == lval_memory
))
10260 argvec
[0] = value_addr (argvec
[0]);
10262 type
= ada_check_typedef (value_type (argvec
[0]));
10264 /* Ada allows us to implicitly dereference arrays when subscripting
10265 them. So, if this is an array typedef (encoding use for array
10266 access types encoded as fat pointers), strip it now. */
10267 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
)
10268 type
= ada_typedef_target_type (type
);
10270 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
10272 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
10274 case TYPE_CODE_FUNC
:
10275 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10277 case TYPE_CODE_ARRAY
:
10279 case TYPE_CODE_STRUCT
:
10280 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
10281 argvec
[0] = ada_value_ind (argvec
[0]);
10282 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
10285 error (_("cannot subscript or call something of type `%s'"),
10286 ada_type_name (value_type (argvec
[0])));
10291 switch (TYPE_CODE (type
))
10293 case TYPE_CODE_FUNC
:
10294 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10296 struct type
*rtype
= TYPE_TARGET_TYPE (type
);
10298 if (TYPE_GNU_IFUNC (type
))
10299 return allocate_value (TYPE_TARGET_TYPE (rtype
));
10300 return allocate_value (rtype
);
10302 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
10303 case TYPE_CODE_INTERNAL_FUNCTION
:
10304 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10305 /* We don't know anything about what the internal
10306 function might return, but we have to return
10308 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10311 return call_internal_function (exp
->gdbarch
, exp
->language_defn
,
10312 argvec
[0], nargs
, argvec
+ 1);
10314 case TYPE_CODE_STRUCT
:
10318 arity
= ada_array_arity (type
);
10319 type
= ada_array_element_type (type
, nargs
);
10321 error (_("cannot subscript or call a record"));
10322 if (arity
!= nargs
)
10323 error (_("wrong number of subscripts; expecting %d"), arity
);
10324 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10325 return value_zero (ada_aligned_type (type
), lval_memory
);
10327 unwrap_value (ada_value_subscript
10328 (argvec
[0], nargs
, argvec
+ 1));
10330 case TYPE_CODE_ARRAY
:
10331 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10333 type
= ada_array_element_type (type
, nargs
);
10335 error (_("element type of array unknown"));
10337 return value_zero (ada_aligned_type (type
), lval_memory
);
10340 unwrap_value (ada_value_subscript
10341 (ada_coerce_to_simple_array (argvec
[0]),
10342 nargs
, argvec
+ 1));
10343 case TYPE_CODE_PTR
: /* Pointer to array */
10344 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10346 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
10347 type
= ada_array_element_type (type
, nargs
);
10349 error (_("element type of array unknown"));
10351 return value_zero (ada_aligned_type (type
), lval_memory
);
10354 unwrap_value (ada_value_ptr_subscript (argvec
[0],
10355 nargs
, argvec
+ 1));
10358 error (_("Attempt to index or call something other than an "
10359 "array or function"));
10364 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10365 struct value
*low_bound_val
=
10366 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10367 struct value
*high_bound_val
=
10368 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10370 LONGEST high_bound
;
10372 low_bound_val
= coerce_ref (low_bound_val
);
10373 high_bound_val
= coerce_ref (high_bound_val
);
10374 low_bound
= pos_atr (low_bound_val
);
10375 high_bound
= pos_atr (high_bound_val
);
10377 if (noside
== EVAL_SKIP
)
10380 /* If this is a reference to an aligner type, then remove all
10382 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
10383 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
10384 TYPE_TARGET_TYPE (value_type (array
)) =
10385 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
10387 if (ada_is_constrained_packed_array_type (value_type (array
)))
10388 error (_("cannot slice a packed array"));
10390 /* If this is a reference to an array or an array lvalue,
10391 convert to a pointer. */
10392 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
10393 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
10394 && VALUE_LVAL (array
) == lval_memory
))
10395 array
= value_addr (array
);
10397 if (noside
== EVAL_AVOID_SIDE_EFFECTS
10398 && ada_is_array_descriptor_type (ada_check_typedef
10399 (value_type (array
))))
10400 return empty_array (ada_type_of_array (array
, 0), low_bound
);
10402 array
= ada_coerce_to_simple_array_ptr (array
);
10404 /* If we have more than one level of pointer indirection,
10405 dereference the value until we get only one level. */
10406 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
10407 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
10409 array
= value_ind (array
);
10411 /* Make sure we really do have an array type before going further,
10412 to avoid a SEGV when trying to get the index type or the target
10413 type later down the road if the debug info generated by
10414 the compiler is incorrect or incomplete. */
10415 if (!ada_is_simple_array_type (value_type (array
)))
10416 error (_("cannot take slice of non-array"));
10418 if (TYPE_CODE (ada_check_typedef (value_type (array
)))
10421 struct type
*type0
= ada_check_typedef (value_type (array
));
10423 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
10424 return empty_array (TYPE_TARGET_TYPE (type0
), low_bound
);
10427 struct type
*arr_type0
=
10428 to_fixed_array_type (TYPE_TARGET_TYPE (type0
), NULL
, 1);
10430 return ada_value_slice_from_ptr (array
, arr_type0
,
10431 longest_to_int (low_bound
),
10432 longest_to_int (high_bound
));
10435 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10437 else if (high_bound
< low_bound
)
10438 return empty_array (value_type (array
), low_bound
);
10440 return ada_value_slice (array
, longest_to_int (low_bound
),
10441 longest_to_int (high_bound
));
10444 case UNOP_IN_RANGE
:
10446 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10447 type
= check_typedef (exp
->elts
[pc
+ 1].type
);
10449 if (noside
== EVAL_SKIP
)
10452 switch (TYPE_CODE (type
))
10455 lim_warning (_("Membership test incompletely implemented; "
10456 "always returns true"));
10457 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10458 return value_from_longest (type
, (LONGEST
) 1);
10460 case TYPE_CODE_RANGE
:
10461 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
10462 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
10463 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10464 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10465 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10467 value_from_longest (type
,
10468 (value_less (arg1
, arg3
)
10469 || value_equal (arg1
, arg3
))
10470 && (value_less (arg2
, arg1
)
10471 || value_equal (arg2
, arg1
)));
10474 case BINOP_IN_BOUNDS
:
10476 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10477 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10479 if (noside
== EVAL_SKIP
)
10482 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10484 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10485 return value_zero (type
, not_lval
);
10488 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10490 type
= ada_index_type (value_type (arg2
), tem
, "range");
10492 type
= value_type (arg1
);
10494 arg3
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 1));
10495 arg2
= value_from_longest (type
, ada_array_bound (arg2
, tem
, 0));
10497 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10498 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10499 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10501 value_from_longest (type
,
10502 (value_less (arg1
, arg3
)
10503 || value_equal (arg1
, arg3
))
10504 && (value_less (arg2
, arg1
)
10505 || value_equal (arg2
, arg1
)));
10507 case TERNOP_IN_RANGE
:
10508 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10509 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10510 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10512 if (noside
== EVAL_SKIP
)
10515 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10516 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
10517 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
10519 value_from_longest (type
,
10520 (value_less (arg1
, arg3
)
10521 || value_equal (arg1
, arg3
))
10522 && (value_less (arg2
, arg1
)
10523 || value_equal (arg2
, arg1
)));
10527 case OP_ATR_LENGTH
:
10529 struct type
*type_arg
;
10531 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10533 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10535 type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10539 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10543 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
10544 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
10545 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
10548 if (noside
== EVAL_SKIP
)
10551 if (type_arg
== NULL
)
10553 arg1
= ada_coerce_ref (arg1
);
10555 if (ada_is_constrained_packed_array_type (value_type (arg1
)))
10556 arg1
= ada_coerce_to_simple_array (arg1
);
10558 if (op
== OP_ATR_LENGTH
)
10559 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10562 type
= ada_index_type (value_type (arg1
), tem
,
10563 ada_attribute_name (op
));
10565 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10568 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10569 return allocate_value (type
);
10573 default: /* Should never happen. */
10574 error (_("unexpected attribute encountered"));
10576 return value_from_longest
10577 (type
, ada_array_bound (arg1
, tem
, 0));
10579 return value_from_longest
10580 (type
, ada_array_bound (arg1
, tem
, 1));
10581 case OP_ATR_LENGTH
:
10582 return value_from_longest
10583 (type
, ada_array_length (arg1
, tem
));
10586 else if (discrete_type_p (type_arg
))
10588 struct type
*range_type
;
10589 const char *name
= ada_type_name (type_arg
);
10592 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
10593 range_type
= to_fixed_range_type (type_arg
, NULL
);
10594 if (range_type
== NULL
)
10595 range_type
= type_arg
;
10599 error (_("unexpected attribute encountered"));
10601 return value_from_longest
10602 (range_type
, ada_discrete_type_low_bound (range_type
));
10604 return value_from_longest
10605 (range_type
, ada_discrete_type_high_bound (range_type
));
10606 case OP_ATR_LENGTH
:
10607 error (_("the 'length attribute applies only to array types"));
10610 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
10611 error (_("unimplemented type attribute"));
10616 if (ada_is_constrained_packed_array_type (type_arg
))
10617 type_arg
= decode_constrained_packed_array_type (type_arg
);
10619 if (op
== OP_ATR_LENGTH
)
10620 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10623 type
= ada_index_type (type_arg
, tem
, ada_attribute_name (op
));
10625 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10628 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10629 return allocate_value (type
);
10634 error (_("unexpected attribute encountered"));
10636 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10637 return value_from_longest (type
, low
);
10639 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10640 return value_from_longest (type
, high
);
10641 case OP_ATR_LENGTH
:
10642 low
= ada_array_bound_from_type (type_arg
, tem
, 0);
10643 high
= ada_array_bound_from_type (type_arg
, tem
, 1);
10644 return value_from_longest (type
, high
- low
+ 1);
10650 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10651 if (noside
== EVAL_SKIP
)
10654 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10655 return value_zero (ada_tag_type (arg1
), not_lval
);
10657 return ada_value_tag (arg1
);
10661 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10662 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10663 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10664 if (noside
== EVAL_SKIP
)
10666 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10667 return value_zero (value_type (arg1
), not_lval
);
10670 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10671 return value_binop (arg1
, arg2
,
10672 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
10675 case OP_ATR_MODULUS
:
10677 struct type
*type_arg
= check_typedef (exp
->elts
[pc
+ 2].type
);
10679 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10680 if (noside
== EVAL_SKIP
)
10683 if (!ada_is_modular_type (type_arg
))
10684 error (_("'modulus must be applied to modular type"));
10686 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
10687 ada_modulus (type_arg
));
10692 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10693 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10694 if (noside
== EVAL_SKIP
)
10696 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
10697 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10698 return value_zero (type
, not_lval
);
10700 return value_pos_atr (type
, arg1
);
10703 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10704 type
= value_type (arg1
);
10706 /* If the argument is a reference, then dereference its type, since
10707 the user is really asking for the size of the actual object,
10708 not the size of the pointer. */
10709 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
10710 type
= TYPE_TARGET_TYPE (type
);
10712 if (noside
== EVAL_SKIP
)
10714 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10715 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
, not_lval
);
10717 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
10718 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
10721 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
10722 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10723 type
= exp
->elts
[pc
+ 2].type
;
10724 if (noside
== EVAL_SKIP
)
10726 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10727 return value_zero (type
, not_lval
);
10729 return value_val_atr (type
, arg1
);
10732 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10733 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10734 if (noside
== EVAL_SKIP
)
10736 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10737 return value_zero (value_type (arg1
), not_lval
);
10740 /* For integer exponentiation operations,
10741 only promote the first argument. */
10742 if (is_integral_type (value_type (arg2
)))
10743 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10745 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
10747 return value_binop (arg1
, arg2
, op
);
10751 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10752 if (noside
== EVAL_SKIP
)
10758 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10759 if (noside
== EVAL_SKIP
)
10761 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
10762 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
10763 return value_neg (arg1
);
10768 preeval_pos
= *pos
;
10769 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10770 if (noside
== EVAL_SKIP
)
10772 type
= ada_check_typedef (value_type (arg1
));
10773 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10775 if (ada_is_array_descriptor_type (type
))
10776 /* GDB allows dereferencing GNAT array descriptors. */
10778 struct type
*arrType
= ada_type_of_array (arg1
, 0);
10780 if (arrType
== NULL
)
10781 error (_("Attempt to dereference null array pointer."));
10782 return value_at_lazy (arrType
, 0);
10784 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
10785 || TYPE_CODE (type
) == TYPE_CODE_REF
10786 /* In C you can dereference an array to get the 1st elt. */
10787 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
10789 /* As mentioned in the OP_VAR_VALUE case, tagged types can
10790 only be determined by inspecting the object's tag.
10791 This means that we need to evaluate completely the
10792 expression in order to get its type. */
10794 if ((TYPE_CODE (type
) == TYPE_CODE_REF
10795 || TYPE_CODE (type
) == TYPE_CODE_PTR
)
10796 && ada_is_tagged_type (TYPE_TARGET_TYPE (type
), 0))
10798 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
10800 type
= value_type (ada_value_ind (arg1
));
10804 type
= to_static_fixed_type
10806 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
10809 return value_zero (type
, lval_memory
);
10811 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
10813 /* GDB allows dereferencing an int. */
10814 if (expect_type
== NULL
)
10815 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
10820 to_static_fixed_type (ada_aligned_type (expect_type
));
10821 return value_zero (expect_type
, lval_memory
);
10825 error (_("Attempt to take contents of a non-pointer value."));
10827 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
10828 type
= ada_check_typedef (value_type (arg1
));
10830 if (TYPE_CODE (type
) == TYPE_CODE_INT
)
10831 /* GDB allows dereferencing an int. If we were given
10832 the expect_type, then use that as the target type.
10833 Otherwise, assume that the target type is an int. */
10835 if (expect_type
!= NULL
)
10836 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
10839 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
10840 (CORE_ADDR
) value_as_address (arg1
));
10843 if (ada_is_array_descriptor_type (type
))
10844 /* GDB allows dereferencing GNAT array descriptors. */
10845 return ada_coerce_to_simple_array (arg1
);
10847 return ada_value_ind (arg1
);
10849 case STRUCTOP_STRUCT
:
10850 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10851 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
10852 preeval_pos
= *pos
;
10853 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
10854 if (noside
== EVAL_SKIP
)
10856 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10858 struct type
*type1
= value_type (arg1
);
10860 if (ada_is_tagged_type (type1
, 1))
10862 type
= ada_lookup_struct_elt_type (type1
,
10863 &exp
->elts
[pc
+ 2].string
,
10866 /* If the field is not found, check if it exists in the
10867 extension of this object's type. This means that we
10868 need to evaluate completely the expression. */
10872 arg1
= evaluate_subexp (NULL_TYPE
, exp
, &preeval_pos
,
10874 arg1
= ada_value_struct_elt (arg1
,
10875 &exp
->elts
[pc
+ 2].string
,
10877 arg1
= unwrap_value (arg1
);
10878 type
= value_type (ada_to_fixed_value (arg1
));
10883 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
10886 return value_zero (ada_aligned_type (type
), lval_memory
);
10889 arg1
= ada_value_struct_elt (arg1
, &exp
->elts
[pc
+ 2].string
, 0);
10890 arg1
= unwrap_value (arg1
);
10891 return ada_to_fixed_value (arg1
);
10894 /* The value is not supposed to be used. This is here to make it
10895 easier to accommodate expressions that contain types. */
10897 if (noside
== EVAL_SKIP
)
10899 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
10900 return allocate_value (exp
->elts
[pc
+ 1].type
);
10902 error (_("Attempt to use a type name as an expression"));
10907 case OP_DISCRETE_RANGE
:
10908 case OP_POSITIONAL
:
10910 if (noside
== EVAL_NORMAL
)
10914 error (_("Undefined name, ambiguous name, or renaming used in "
10915 "component association: %s."), &exp
->elts
[pc
+2].string
);
10917 error (_("Aggregates only allowed on the right of an assignment"));
10919 internal_error (__FILE__
, __LINE__
,
10920 _("aggregate apparently mangled"));
10923 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
10925 for (tem
= 0; tem
< nargs
; tem
+= 1)
10926 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
10931 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
, 1);
10937 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
10938 type name that encodes the 'small and 'delta information.
10939 Otherwise, return NULL. */
10941 static const char *
10942 fixed_type_info (struct type
*type
)
10944 const char *name
= ada_type_name (type
);
10945 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
10947 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
10949 const char *tail
= strstr (name
, "___XF_");
10956 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
10957 return fixed_type_info (TYPE_TARGET_TYPE (type
));
10962 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
10965 ada_is_fixed_point_type (struct type
*type
)
10967 return fixed_type_info (type
) != NULL
;
10970 /* Return non-zero iff TYPE represents a System.Address type. */
10973 ada_is_system_address_type (struct type
*type
)
10975 return (TYPE_NAME (type
)
10976 && strcmp (TYPE_NAME (type
), "system__address") == 0);
10979 /* Assuming that TYPE is the representation of an Ada fixed-point
10980 type, return its delta, or -1 if the type is malformed and the
10981 delta cannot be determined. */
10984 ada_delta (struct type
*type
)
10986 const char *encoding
= fixed_type_info (type
);
10989 /* Strictly speaking, num and den are encoded as integer. However,
10990 they may not fit into a long, and they will have to be converted
10991 to DOUBLEST anyway. So scan them as DOUBLEST. */
10992 if (sscanf (encoding
, "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
,
10999 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11000 factor ('SMALL value) associated with the type. */
11003 scaling_factor (struct type
*type
)
11005 const char *encoding
= fixed_type_info (type
);
11006 DOUBLEST num0
, den0
, num1
, den1
;
11009 /* Strictly speaking, num's and den's are encoded as integer. However,
11010 they may not fit into a long, and they will have to be converted
11011 to DOUBLEST anyway. So scan them as DOUBLEST. */
11012 n
= sscanf (encoding
,
11013 "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
11014 "_%" DOUBLEST_SCAN_FORMAT
"_%" DOUBLEST_SCAN_FORMAT
,
11015 &num0
, &den0
, &num1
, &den1
);
11020 return num1
/ den1
;
11022 return num0
/ den0
;
11026 /* Assuming that X is the representation of a value of fixed-point
11027 type TYPE, return its floating-point equivalent. */
11030 ada_fixed_to_float (struct type
*type
, LONGEST x
)
11032 return (DOUBLEST
) x
*scaling_factor (type
);
11035 /* The representation of a fixed-point value of type TYPE
11036 corresponding to the value X. */
11039 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
11041 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
11048 /* Scan STR beginning at position K for a discriminant name, and
11049 return the value of that discriminant field of DVAL in *PX. If
11050 PNEW_K is not null, put the position of the character beyond the
11051 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11052 not alter *PX and *PNEW_K if unsuccessful. */
11055 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
11058 static char *bound_buffer
= NULL
;
11059 static size_t bound_buffer_len
= 0;
11062 struct value
*bound_val
;
11064 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
11067 pend
= strstr (str
+ k
, "__");
11071 k
+= strlen (bound
);
11075 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
11076 bound
= bound_buffer
;
11077 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
11078 bound
[pend
- (str
+ k
)] = '\0';
11082 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
11083 if (bound_val
== NULL
)
11086 *px
= value_as_long (bound_val
);
11087 if (pnew_k
!= NULL
)
11092 /* Value of variable named NAME in the current environment. If
11093 no such variable found, then if ERR_MSG is null, returns 0, and
11094 otherwise causes an error with message ERR_MSG. */
11096 static struct value
*
11097 get_var_value (char *name
, char *err_msg
)
11099 struct ada_symbol_info
*syms
;
11102 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
11107 if (err_msg
== NULL
)
11110 error (("%s"), err_msg
);
11113 return value_of_variable (syms
[0].sym
, syms
[0].block
);
11116 /* Value of integer variable named NAME in the current environment. If
11117 no such variable found, returns 0, and sets *FLAG to 0. If
11118 successful, sets *FLAG to 1. */
11121 get_int_var_value (char *name
, int *flag
)
11123 struct value
*var_val
= get_var_value (name
, 0);
11135 return value_as_long (var_val
);
11140 /* Return a range type whose base type is that of the range type named
11141 NAME in the current environment, and whose bounds are calculated
11142 from NAME according to the GNAT range encoding conventions.
11143 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11144 corresponding range type from debug information; fall back to using it
11145 if symbol lookup fails. If a new type must be created, allocate it
11146 like ORIG_TYPE was. The bounds information, in general, is encoded
11147 in NAME, the base type given in the named range type. */
11149 static struct type
*
11150 to_fixed_range_type (struct type
*raw_type
, struct value
*dval
)
11153 struct type
*base_type
;
11154 char *subtype_info
;
11156 gdb_assert (raw_type
!= NULL
);
11157 gdb_assert (TYPE_NAME (raw_type
) != NULL
);
11159 if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
11160 base_type
= TYPE_TARGET_TYPE (raw_type
);
11162 base_type
= raw_type
;
11164 name
= TYPE_NAME (raw_type
);
11165 subtype_info
= strstr (name
, "___XD");
11166 if (subtype_info
== NULL
)
11168 LONGEST L
= ada_discrete_type_low_bound (raw_type
);
11169 LONGEST U
= ada_discrete_type_high_bound (raw_type
);
11171 if (L
< INT_MIN
|| U
> INT_MAX
)
11174 return create_static_range_type (alloc_type_copy (raw_type
), raw_type
,
11179 static char *name_buf
= NULL
;
11180 static size_t name_len
= 0;
11181 int prefix_len
= subtype_info
- name
;
11187 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
11188 strncpy (name_buf
, name
, prefix_len
);
11189 name_buf
[prefix_len
] = '\0';
11192 bounds_str
= strchr (subtype_info
, '_');
11195 if (*subtype_info
== 'L')
11197 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
11198 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
11200 if (bounds_str
[n
] == '_')
11202 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
11210 strcpy (name_buf
+ prefix_len
, "___L");
11211 L
= get_int_var_value (name_buf
, &ok
);
11214 lim_warning (_("Unknown lower bound, using 1."));
11219 if (*subtype_info
== 'U')
11221 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
11222 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
11229 strcpy (name_buf
+ prefix_len
, "___U");
11230 U
= get_int_var_value (name_buf
, &ok
);
11233 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
11238 type
= create_static_range_type (alloc_type_copy (raw_type
),
11240 TYPE_NAME (type
) = name
;
11245 /* True iff NAME is the name of a range type. */
11248 ada_is_range_type_name (const char *name
)
11250 return (name
!= NULL
&& strstr (name
, "___XD"));
11254 /* Modular types */
11256 /* True iff TYPE is an Ada modular type. */
11259 ada_is_modular_type (struct type
*type
)
11261 struct type
*subranged_type
= get_base_type (type
);
11263 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
11264 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
11265 && TYPE_UNSIGNED (subranged_type
));
11268 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11271 ada_modulus (struct type
*type
)
11273 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
11277 /* Ada exception catchpoint support:
11278 ---------------------------------
11280 We support 3 kinds of exception catchpoints:
11281 . catchpoints on Ada exceptions
11282 . catchpoints on unhandled Ada exceptions
11283 . catchpoints on failed assertions
11285 Exceptions raised during failed assertions, or unhandled exceptions
11286 could perfectly be caught with the general catchpoint on Ada exceptions.
11287 However, we can easily differentiate these two special cases, and having
11288 the option to distinguish these two cases from the rest can be useful
11289 to zero-in on certain situations.
11291 Exception catchpoints are a specialized form of breakpoint,
11292 since they rely on inserting breakpoints inside known routines
11293 of the GNAT runtime. The implementation therefore uses a standard
11294 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11297 Support in the runtime for exception catchpoints have been changed
11298 a few times already, and these changes affect the implementation
11299 of these catchpoints. In order to be able to support several
11300 variants of the runtime, we use a sniffer that will determine
11301 the runtime variant used by the program being debugged. */
11303 /* Ada's standard exceptions.
11305 The Ada 83 standard also defined Numeric_Error. But there so many
11306 situations where it was unclear from the Ada 83 Reference Manual
11307 (RM) whether Constraint_Error or Numeric_Error should be raised,
11308 that the ARG (Ada Rapporteur Group) eventually issued a Binding
11309 Interpretation saying that anytime the RM says that Numeric_Error
11310 should be raised, the implementation may raise Constraint_Error.
11311 Ada 95 went one step further and pretty much removed Numeric_Error
11312 from the list of standard exceptions (it made it a renaming of
11313 Constraint_Error, to help preserve compatibility when compiling
11314 an Ada83 compiler). As such, we do not include Numeric_Error from
11315 this list of standard exceptions. */
11317 static char *standard_exc
[] = {
11318 "constraint_error",
11324 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
11326 /* A structure that describes how to support exception catchpoints
11327 for a given executable. */
11329 struct exception_support_info
11331 /* The name of the symbol to break on in order to insert
11332 a catchpoint on exceptions. */
11333 const char *catch_exception_sym
;
11335 /* The name of the symbol to break on in order to insert
11336 a catchpoint on unhandled exceptions. */
11337 const char *catch_exception_unhandled_sym
;
11339 /* The name of the symbol to break on in order to insert
11340 a catchpoint on failed assertions. */
11341 const char *catch_assert_sym
;
11343 /* Assuming that the inferior just triggered an unhandled exception
11344 catchpoint, this function is responsible for returning the address
11345 in inferior memory where the name of that exception is stored.
11346 Return zero if the address could not be computed. */
11347 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
11350 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
11351 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
11353 /* The following exception support info structure describes how to
11354 implement exception catchpoints with the latest version of the
11355 Ada runtime (as of 2007-03-06). */
11357 static const struct exception_support_info default_exception_support_info
=
11359 "__gnat_debug_raise_exception", /* catch_exception_sym */
11360 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11361 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11362 ada_unhandled_exception_name_addr
11365 /* The following exception support info structure describes how to
11366 implement exception catchpoints with a slightly older version
11367 of the Ada runtime. */
11369 static const struct exception_support_info exception_support_info_fallback
=
11371 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11372 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11373 "system__assertions__raise_assert_failure", /* catch_assert_sym */
11374 ada_unhandled_exception_name_addr_from_raise
11377 /* Return nonzero if we can detect the exception support routines
11378 described in EINFO.
11380 This function errors out if an abnormal situation is detected
11381 (for instance, if we find the exception support routines, but
11382 that support is found to be incomplete). */
11385 ada_has_this_exception_support (const struct exception_support_info
*einfo
)
11387 struct symbol
*sym
;
11389 /* The symbol we're looking up is provided by a unit in the GNAT runtime
11390 that should be compiled with debugging information. As a result, we
11391 expect to find that symbol in the symtabs. */
11393 sym
= standard_lookup (einfo
->catch_exception_sym
, NULL
, VAR_DOMAIN
);
11396 /* Perhaps we did not find our symbol because the Ada runtime was
11397 compiled without debugging info, or simply stripped of it.
11398 It happens on some GNU/Linux distributions for instance, where
11399 users have to install a separate debug package in order to get
11400 the runtime's debugging info. In that situation, let the user
11401 know why we cannot insert an Ada exception catchpoint.
11403 Note: Just for the purpose of inserting our Ada exception
11404 catchpoint, we could rely purely on the associated minimal symbol.
11405 But we would be operating in degraded mode anyway, since we are
11406 still lacking the debugging info needed later on to extract
11407 the name of the exception being raised (this name is printed in
11408 the catchpoint message, and is also used when trying to catch
11409 a specific exception). We do not handle this case for now. */
11410 struct bound_minimal_symbol msym
11411 = lookup_minimal_symbol (einfo
->catch_exception_sym
, NULL
, NULL
);
11413 if (msym
.minsym
&& MSYMBOL_TYPE (msym
.minsym
) != mst_solib_trampoline
)
11414 error (_("Your Ada runtime appears to be missing some debugging "
11415 "information.\nCannot insert Ada exception catchpoint "
11416 "in this configuration."));
11421 /* Make sure that the symbol we found corresponds to a function. */
11423 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
11424 error (_("Symbol \"%s\" is not a function (class = %d)"),
11425 SYMBOL_LINKAGE_NAME (sym
), SYMBOL_CLASS (sym
));
11430 /* Inspect the Ada runtime and determine which exception info structure
11431 should be used to provide support for exception catchpoints.
11433 This function will always set the per-inferior exception_info,
11434 or raise an error. */
11437 ada_exception_support_info_sniffer (void)
11439 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11441 /* If the exception info is already known, then no need to recompute it. */
11442 if (data
->exception_info
!= NULL
)
11445 /* Check the latest (default) exception support info. */
11446 if (ada_has_this_exception_support (&default_exception_support_info
))
11448 data
->exception_info
= &default_exception_support_info
;
11452 /* Try our fallback exception suport info. */
11453 if (ada_has_this_exception_support (&exception_support_info_fallback
))
11455 data
->exception_info
= &exception_support_info_fallback
;
11459 /* Sometimes, it is normal for us to not be able to find the routine
11460 we are looking for. This happens when the program is linked with
11461 the shared version of the GNAT runtime, and the program has not been
11462 started yet. Inform the user of these two possible causes if
11465 if (ada_update_initial_language (language_unknown
) != language_ada
)
11466 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11468 /* If the symbol does not exist, then check that the program is
11469 already started, to make sure that shared libraries have been
11470 loaded. If it is not started, this may mean that the symbol is
11471 in a shared library. */
11473 if (ptid_get_pid (inferior_ptid
) == 0)
11474 error (_("Unable to insert catchpoint. Try to start the program first."));
11476 /* At this point, we know that we are debugging an Ada program and
11477 that the inferior has been started, but we still are not able to
11478 find the run-time symbols. That can mean that we are in
11479 configurable run time mode, or that a-except as been optimized
11480 out by the linker... In any case, at this point it is not worth
11481 supporting this feature. */
11483 error (_("Cannot insert Ada exception catchpoints in this configuration."));
11486 /* True iff FRAME is very likely to be that of a function that is
11487 part of the runtime system. This is all very heuristic, but is
11488 intended to be used as advice as to what frames are uninteresting
11492 is_known_support_routine (struct frame_info
*frame
)
11494 struct symtab_and_line sal
;
11496 enum language func_lang
;
11498 const char *fullname
;
11500 /* If this code does not have any debugging information (no symtab),
11501 This cannot be any user code. */
11503 find_frame_sal (frame
, &sal
);
11504 if (sal
.symtab
== NULL
)
11507 /* If there is a symtab, but the associated source file cannot be
11508 located, then assume this is not user code: Selecting a frame
11509 for which we cannot display the code would not be very helpful
11510 for the user. This should also take care of case such as VxWorks
11511 where the kernel has some debugging info provided for a few units. */
11513 fullname
= symtab_to_fullname (sal
.symtab
);
11514 if (access (fullname
, R_OK
) != 0)
11517 /* Check the unit filename againt the Ada runtime file naming.
11518 We also check the name of the objfile against the name of some
11519 known system libraries that sometimes come with debugging info
11522 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
11524 re_comp (known_runtime_file_name_patterns
[i
]);
11525 if (re_exec (lbasename (sal
.symtab
->filename
)))
11527 if (sal
.symtab
->objfile
!= NULL
11528 && re_exec (objfile_name (sal
.symtab
->objfile
)))
11532 /* Check whether the function is a GNAT-generated entity. */
11534 find_frame_funname (frame
, &func_name
, &func_lang
, NULL
);
11535 if (func_name
== NULL
)
11538 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
11540 re_comp (known_auxiliary_function_name_patterns
[i
]);
11541 if (re_exec (func_name
))
11552 /* Find the first frame that contains debugging information and that is not
11553 part of the Ada run-time, starting from FI and moving upward. */
11556 ada_find_printable_frame (struct frame_info
*fi
)
11558 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
11560 if (!is_known_support_routine (fi
))
11569 /* Assuming that the inferior just triggered an unhandled exception
11570 catchpoint, return the address in inferior memory where the name
11571 of the exception is stored.
11573 Return zero if the address could not be computed. */
11576 ada_unhandled_exception_name_addr (void)
11578 return parse_and_eval_address ("e.full_name");
11581 /* Same as ada_unhandled_exception_name_addr, except that this function
11582 should be used when the inferior uses an older version of the runtime,
11583 where the exception name needs to be extracted from a specific frame
11584 several frames up in the callstack. */
11587 ada_unhandled_exception_name_addr_from_raise (void)
11590 struct frame_info
*fi
;
11591 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11592 struct cleanup
*old_chain
;
11594 /* To determine the name of this exception, we need to select
11595 the frame corresponding to RAISE_SYM_NAME. This frame is
11596 at least 3 levels up, so we simply skip the first 3 frames
11597 without checking the name of their associated function. */
11598 fi
= get_current_frame ();
11599 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
11601 fi
= get_prev_frame (fi
);
11603 old_chain
= make_cleanup (null_cleanup
, NULL
);
11607 enum language func_lang
;
11609 find_frame_funname (fi
, &func_name
, &func_lang
, NULL
);
11610 if (func_name
!= NULL
)
11612 make_cleanup (xfree
, func_name
);
11614 if (strcmp (func_name
,
11615 data
->exception_info
->catch_exception_sym
) == 0)
11616 break; /* We found the frame we were looking for... */
11617 fi
= get_prev_frame (fi
);
11620 do_cleanups (old_chain
);
11626 return parse_and_eval_address ("id.full_name");
11629 /* Assuming the inferior just triggered an Ada exception catchpoint
11630 (of any type), return the address in inferior memory where the name
11631 of the exception is stored, if applicable.
11633 Return zero if the address could not be computed, or if not relevant. */
11636 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex
,
11637 struct breakpoint
*b
)
11639 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
11643 case ada_catch_exception
:
11644 return (parse_and_eval_address ("e.full_name"));
11647 case ada_catch_exception_unhandled
:
11648 return data
->exception_info
->unhandled_exception_name_addr ();
11651 case ada_catch_assert
:
11652 return 0; /* Exception name is not relevant in this case. */
11656 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
11660 return 0; /* Should never be reached. */
11663 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11664 any error that ada_exception_name_addr_1 might cause to be thrown.
11665 When an error is intercepted, a warning with the error message is printed,
11666 and zero is returned. */
11669 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex
,
11670 struct breakpoint
*b
)
11672 volatile struct gdb_exception e
;
11673 CORE_ADDR result
= 0;
11675 TRY_CATCH (e
, RETURN_MASK_ERROR
)
11677 result
= ada_exception_name_addr_1 (ex
, b
);
11682 warning (_("failed to get exception name: %s"), e
.message
);
11689 static char *ada_exception_catchpoint_cond_string (const char *excep_string
);
11691 /* Ada catchpoints.
11693 In the case of catchpoints on Ada exceptions, the catchpoint will
11694 stop the target on every exception the program throws. When a user
11695 specifies the name of a specific exception, we translate this
11696 request into a condition expression (in text form), and then parse
11697 it into an expression stored in each of the catchpoint's locations.
11698 We then use this condition to check whether the exception that was
11699 raised is the one the user is interested in. If not, then the
11700 target is resumed again. We store the name of the requested
11701 exception, in order to be able to re-set the condition expression
11702 when symbols change. */
11704 /* An instance of this type is used to represent an Ada catchpoint
11705 breakpoint location. It includes a "struct bp_location" as a kind
11706 of base class; users downcast to "struct bp_location *" when
11709 struct ada_catchpoint_location
11711 /* The base class. */
11712 struct bp_location base
;
11714 /* The condition that checks whether the exception that was raised
11715 is the specific exception the user specified on catchpoint
11717 struct expression
*excep_cond_expr
;
11720 /* Implement the DTOR method in the bp_location_ops structure for all
11721 Ada exception catchpoint kinds. */
11724 ada_catchpoint_location_dtor (struct bp_location
*bl
)
11726 struct ada_catchpoint_location
*al
= (struct ada_catchpoint_location
*) bl
;
11728 xfree (al
->excep_cond_expr
);
11731 /* The vtable to be used in Ada catchpoint locations. */
11733 static const struct bp_location_ops ada_catchpoint_location_ops
=
11735 ada_catchpoint_location_dtor
11738 /* An instance of this type is used to represent an Ada catchpoint.
11739 It includes a "struct breakpoint" as a kind of base class; users
11740 downcast to "struct breakpoint *" when needed. */
11742 struct ada_catchpoint
11744 /* The base class. */
11745 struct breakpoint base
;
11747 /* The name of the specific exception the user specified. */
11748 char *excep_string
;
11751 /* Parse the exception condition string in the context of each of the
11752 catchpoint's locations, and store them for later evaluation. */
11755 create_excep_cond_exprs (struct ada_catchpoint
*c
)
11757 struct cleanup
*old_chain
;
11758 struct bp_location
*bl
;
11761 /* Nothing to do if there's no specific exception to catch. */
11762 if (c
->excep_string
== NULL
)
11765 /* Same if there are no locations... */
11766 if (c
->base
.loc
== NULL
)
11769 /* Compute the condition expression in text form, from the specific
11770 expection we want to catch. */
11771 cond_string
= ada_exception_catchpoint_cond_string (c
->excep_string
);
11772 old_chain
= make_cleanup (xfree
, cond_string
);
11774 /* Iterate over all the catchpoint's locations, and parse an
11775 expression for each. */
11776 for (bl
= c
->base
.loc
; bl
!= NULL
; bl
= bl
->next
)
11778 struct ada_catchpoint_location
*ada_loc
11779 = (struct ada_catchpoint_location
*) bl
;
11780 struct expression
*exp
= NULL
;
11782 if (!bl
->shlib_disabled
)
11784 volatile struct gdb_exception e
;
11788 TRY_CATCH (e
, RETURN_MASK_ERROR
)
11790 exp
= parse_exp_1 (&s
, bl
->address
,
11791 block_for_pc (bl
->address
), 0);
11795 warning (_("failed to reevaluate internal exception condition "
11796 "for catchpoint %d: %s"),
11797 c
->base
.number
, e
.message
);
11798 /* There is a bug in GCC on sparc-solaris when building with
11799 optimization which causes EXP to change unexpectedly
11800 (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56982).
11801 The problem should be fixed starting with GCC 4.9.
11802 In the meantime, work around it by forcing EXP back
11808 ada_loc
->excep_cond_expr
= exp
;
11811 do_cleanups (old_chain
);
11814 /* Implement the DTOR method in the breakpoint_ops structure for all
11815 exception catchpoint kinds. */
11818 dtor_exception (enum ada_exception_catchpoint_kind ex
, struct breakpoint
*b
)
11820 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
11822 xfree (c
->excep_string
);
11824 bkpt_breakpoint_ops
.dtor (b
);
11827 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
11828 structure for all exception catchpoint kinds. */
11830 static struct bp_location
*
11831 allocate_location_exception (enum ada_exception_catchpoint_kind ex
,
11832 struct breakpoint
*self
)
11834 struct ada_catchpoint_location
*loc
;
11836 loc
= XNEW (struct ada_catchpoint_location
);
11837 init_bp_location (&loc
->base
, &ada_catchpoint_location_ops
, self
);
11838 loc
->excep_cond_expr
= NULL
;
11842 /* Implement the RE_SET method in the breakpoint_ops structure for all
11843 exception catchpoint kinds. */
11846 re_set_exception (enum ada_exception_catchpoint_kind ex
, struct breakpoint
*b
)
11848 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
11850 /* Call the base class's method. This updates the catchpoint's
11852 bkpt_breakpoint_ops
.re_set (b
);
11854 /* Reparse the exception conditional expressions. One for each
11856 create_excep_cond_exprs (c
);
11859 /* Returns true if we should stop for this breakpoint hit. If the
11860 user specified a specific exception, we only want to cause a stop
11861 if the program thrown that exception. */
11864 should_stop_exception (const struct bp_location
*bl
)
11866 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) bl
->owner
;
11867 const struct ada_catchpoint_location
*ada_loc
11868 = (const struct ada_catchpoint_location
*) bl
;
11869 volatile struct gdb_exception ex
;
11872 /* With no specific exception, should always stop. */
11873 if (c
->excep_string
== NULL
)
11876 if (ada_loc
->excep_cond_expr
== NULL
)
11878 /* We will have a NULL expression if back when we were creating
11879 the expressions, this location's had failed to parse. */
11884 TRY_CATCH (ex
, RETURN_MASK_ALL
)
11886 struct value
*mark
;
11888 mark
= value_mark ();
11889 stop
= value_true (evaluate_expression (ada_loc
->excep_cond_expr
));
11890 value_free_to_mark (mark
);
11893 exception_fprintf (gdb_stderr
, ex
,
11894 _("Error in testing exception condition:\n"));
11898 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
11899 for all exception catchpoint kinds. */
11902 check_status_exception (enum ada_exception_catchpoint_kind ex
, bpstat bs
)
11904 bs
->stop
= should_stop_exception (bs
->bp_location_at
);
11907 /* Implement the PRINT_IT method in the breakpoint_ops structure
11908 for all exception catchpoint kinds. */
11910 static enum print_stop_action
11911 print_it_exception (enum ada_exception_catchpoint_kind ex
, bpstat bs
)
11913 struct ui_out
*uiout
= current_uiout
;
11914 struct breakpoint
*b
= bs
->breakpoint_at
;
11916 annotate_catchpoint (b
->number
);
11918 if (ui_out_is_mi_like_p (uiout
))
11920 ui_out_field_string (uiout
, "reason",
11921 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT
));
11922 ui_out_field_string (uiout
, "disp", bpdisp_text (b
->disposition
));
11925 ui_out_text (uiout
,
11926 b
->disposition
== disp_del
? "\nTemporary catchpoint "
11927 : "\nCatchpoint ");
11928 ui_out_field_int (uiout
, "bkptno", b
->number
);
11929 ui_out_text (uiout
, ", ");
11933 case ada_catch_exception
:
11934 case ada_catch_exception_unhandled
:
11936 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
11937 char exception_name
[256];
11941 read_memory (addr
, (gdb_byte
*) exception_name
,
11942 sizeof (exception_name
) - 1);
11943 exception_name
[sizeof (exception_name
) - 1] = '\0';
11947 /* For some reason, we were unable to read the exception
11948 name. This could happen if the Runtime was compiled
11949 without debugging info, for instance. In that case,
11950 just replace the exception name by the generic string
11951 "exception" - it will read as "an exception" in the
11952 notification we are about to print. */
11953 memcpy (exception_name
, "exception", sizeof ("exception"));
11955 /* In the case of unhandled exception breakpoints, we print
11956 the exception name as "unhandled EXCEPTION_NAME", to make
11957 it clearer to the user which kind of catchpoint just got
11958 hit. We used ui_out_text to make sure that this extra
11959 info does not pollute the exception name in the MI case. */
11960 if (ex
== ada_catch_exception_unhandled
)
11961 ui_out_text (uiout
, "unhandled ");
11962 ui_out_field_string (uiout
, "exception-name", exception_name
);
11965 case ada_catch_assert
:
11966 /* In this case, the name of the exception is not really
11967 important. Just print "failed assertion" to make it clearer
11968 that his program just hit an assertion-failure catchpoint.
11969 We used ui_out_text because this info does not belong in
11971 ui_out_text (uiout
, "failed assertion");
11974 ui_out_text (uiout
, " at ");
11975 ada_find_printable_frame (get_current_frame ());
11977 return PRINT_SRC_AND_LOC
;
11980 /* Implement the PRINT_ONE method in the breakpoint_ops structure
11981 for all exception catchpoint kinds. */
11984 print_one_exception (enum ada_exception_catchpoint_kind ex
,
11985 struct breakpoint
*b
, struct bp_location
**last_loc
)
11987 struct ui_out
*uiout
= current_uiout
;
11988 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
11989 struct value_print_options opts
;
11991 get_user_print_options (&opts
);
11992 if (opts
.addressprint
)
11994 annotate_field (4);
11995 ui_out_field_core_addr (uiout
, "addr", b
->loc
->gdbarch
, b
->loc
->address
);
11998 annotate_field (5);
11999 *last_loc
= b
->loc
;
12002 case ada_catch_exception
:
12003 if (c
->excep_string
!= NULL
)
12005 char *msg
= xstrprintf (_("`%s' Ada exception"), c
->excep_string
);
12007 ui_out_field_string (uiout
, "what", msg
);
12011 ui_out_field_string (uiout
, "what", "all Ada exceptions");
12015 case ada_catch_exception_unhandled
:
12016 ui_out_field_string (uiout
, "what", "unhandled Ada exceptions");
12019 case ada_catch_assert
:
12020 ui_out_field_string (uiout
, "what", "failed Ada assertions");
12024 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12029 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12030 for all exception catchpoint kinds. */
12033 print_mention_exception (enum ada_exception_catchpoint_kind ex
,
12034 struct breakpoint
*b
)
12036 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12037 struct ui_out
*uiout
= current_uiout
;
12039 ui_out_text (uiout
, b
->disposition
== disp_del
? _("Temporary catchpoint ")
12040 : _("Catchpoint "));
12041 ui_out_field_int (uiout
, "bkptno", b
->number
);
12042 ui_out_text (uiout
, ": ");
12046 case ada_catch_exception
:
12047 if (c
->excep_string
!= NULL
)
12049 char *info
= xstrprintf (_("`%s' Ada exception"), c
->excep_string
);
12050 struct cleanup
*old_chain
= make_cleanup (xfree
, info
);
12052 ui_out_text (uiout
, info
);
12053 do_cleanups (old_chain
);
12056 ui_out_text (uiout
, _("all Ada exceptions"));
12059 case ada_catch_exception_unhandled
:
12060 ui_out_text (uiout
, _("unhandled Ada exceptions"));
12063 case ada_catch_assert
:
12064 ui_out_text (uiout
, _("failed Ada assertions"));
12068 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12073 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12074 for all exception catchpoint kinds. */
12077 print_recreate_exception (enum ada_exception_catchpoint_kind ex
,
12078 struct breakpoint
*b
, struct ui_file
*fp
)
12080 struct ada_catchpoint
*c
= (struct ada_catchpoint
*) b
;
12084 case ada_catch_exception
:
12085 fprintf_filtered (fp
, "catch exception");
12086 if (c
->excep_string
!= NULL
)
12087 fprintf_filtered (fp
, " %s", c
->excep_string
);
12090 case ada_catch_exception_unhandled
:
12091 fprintf_filtered (fp
, "catch exception unhandled");
12094 case ada_catch_assert
:
12095 fprintf_filtered (fp
, "catch assert");
12099 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
12101 print_recreate_thread (b
, fp
);
12104 /* Virtual table for "catch exception" breakpoints. */
12107 dtor_catch_exception (struct breakpoint
*b
)
12109 dtor_exception (ada_catch_exception
, b
);
12112 static struct bp_location
*
12113 allocate_location_catch_exception (struct breakpoint
*self
)
12115 return allocate_location_exception (ada_catch_exception
, self
);
12119 re_set_catch_exception (struct breakpoint
*b
)
12121 re_set_exception (ada_catch_exception
, b
);
12125 check_status_catch_exception (bpstat bs
)
12127 check_status_exception (ada_catch_exception
, bs
);
12130 static enum print_stop_action
12131 print_it_catch_exception (bpstat bs
)
12133 return print_it_exception (ada_catch_exception
, bs
);
12137 print_one_catch_exception (struct breakpoint
*b
, struct bp_location
**last_loc
)
12139 print_one_exception (ada_catch_exception
, b
, last_loc
);
12143 print_mention_catch_exception (struct breakpoint
*b
)
12145 print_mention_exception (ada_catch_exception
, b
);
12149 print_recreate_catch_exception (struct breakpoint
*b
, struct ui_file
*fp
)
12151 print_recreate_exception (ada_catch_exception
, b
, fp
);
12154 static struct breakpoint_ops catch_exception_breakpoint_ops
;
12156 /* Virtual table for "catch exception unhandled" breakpoints. */
12159 dtor_catch_exception_unhandled (struct breakpoint
*b
)
12161 dtor_exception (ada_catch_exception_unhandled
, b
);
12164 static struct bp_location
*
12165 allocate_location_catch_exception_unhandled (struct breakpoint
*self
)
12167 return allocate_location_exception (ada_catch_exception_unhandled
, self
);
12171 re_set_catch_exception_unhandled (struct breakpoint
*b
)
12173 re_set_exception (ada_catch_exception_unhandled
, b
);
12177 check_status_catch_exception_unhandled (bpstat bs
)
12179 check_status_exception (ada_catch_exception_unhandled
, bs
);
12182 static enum print_stop_action
12183 print_it_catch_exception_unhandled (bpstat bs
)
12185 return print_it_exception (ada_catch_exception_unhandled
, bs
);
12189 print_one_catch_exception_unhandled (struct breakpoint
*b
,
12190 struct bp_location
**last_loc
)
12192 print_one_exception (ada_catch_exception_unhandled
, b
, last_loc
);
12196 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
12198 print_mention_exception (ada_catch_exception_unhandled
, b
);
12202 print_recreate_catch_exception_unhandled (struct breakpoint
*b
,
12203 struct ui_file
*fp
)
12205 print_recreate_exception (ada_catch_exception_unhandled
, b
, fp
);
12208 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
;
12210 /* Virtual table for "catch assert" breakpoints. */
12213 dtor_catch_assert (struct breakpoint
*b
)
12215 dtor_exception (ada_catch_assert
, b
);
12218 static struct bp_location
*
12219 allocate_location_catch_assert (struct breakpoint
*self
)
12221 return allocate_location_exception (ada_catch_assert
, self
);
12225 re_set_catch_assert (struct breakpoint
*b
)
12227 re_set_exception (ada_catch_assert
, b
);
12231 check_status_catch_assert (bpstat bs
)
12233 check_status_exception (ada_catch_assert
, bs
);
12236 static enum print_stop_action
12237 print_it_catch_assert (bpstat bs
)
12239 return print_it_exception (ada_catch_assert
, bs
);
12243 print_one_catch_assert (struct breakpoint
*b
, struct bp_location
**last_loc
)
12245 print_one_exception (ada_catch_assert
, b
, last_loc
);
12249 print_mention_catch_assert (struct breakpoint
*b
)
12251 print_mention_exception (ada_catch_assert
, b
);
12255 print_recreate_catch_assert (struct breakpoint
*b
, struct ui_file
*fp
)
12257 print_recreate_exception (ada_catch_assert
, b
, fp
);
12260 static struct breakpoint_ops catch_assert_breakpoint_ops
;
12262 /* Return a newly allocated copy of the first space-separated token
12263 in ARGSP, and then adjust ARGSP to point immediately after that
12266 Return NULL if ARGPS does not contain any more tokens. */
12269 ada_get_next_arg (char **argsp
)
12271 char *args
= *argsp
;
12275 args
= skip_spaces (args
);
12276 if (args
[0] == '\0')
12277 return NULL
; /* No more arguments. */
12279 /* Find the end of the current argument. */
12281 end
= skip_to_space (args
);
12283 /* Adjust ARGSP to point to the start of the next argument. */
12287 /* Make a copy of the current argument and return it. */
12289 result
= xmalloc (end
- args
+ 1);
12290 strncpy (result
, args
, end
- args
);
12291 result
[end
- args
] = '\0';
12296 /* Split the arguments specified in a "catch exception" command.
12297 Set EX to the appropriate catchpoint type.
12298 Set EXCEP_STRING to the name of the specific exception if
12299 specified by the user.
12300 If a condition is found at the end of the arguments, the condition
12301 expression is stored in COND_STRING (memory must be deallocated
12302 after use). Otherwise COND_STRING is set to NULL. */
12305 catch_ada_exception_command_split (char *args
,
12306 enum ada_exception_catchpoint_kind
*ex
,
12307 char **excep_string
,
12308 char **cond_string
)
12310 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
12311 char *exception_name
;
12314 exception_name
= ada_get_next_arg (&args
);
12315 if (exception_name
!= NULL
&& strcmp (exception_name
, "if") == 0)
12317 /* This is not an exception name; this is the start of a condition
12318 expression for a catchpoint on all exceptions. So, "un-get"
12319 this token, and set exception_name to NULL. */
12320 xfree (exception_name
);
12321 exception_name
= NULL
;
12324 make_cleanup (xfree
, exception_name
);
12326 /* Check to see if we have a condition. */
12328 args
= skip_spaces (args
);
12329 if (strncmp (args
, "if", 2) == 0
12330 && (isspace (args
[2]) || args
[2] == '\0'))
12333 args
= skip_spaces (args
);
12335 if (args
[0] == '\0')
12336 error (_("Condition missing after `if' keyword"));
12337 cond
= xstrdup (args
);
12338 make_cleanup (xfree
, cond
);
12340 args
+= strlen (args
);
12343 /* Check that we do not have any more arguments. Anything else
12346 if (args
[0] != '\0')
12347 error (_("Junk at end of expression"));
12349 discard_cleanups (old_chain
);
12351 if (exception_name
== NULL
)
12353 /* Catch all exceptions. */
12354 *ex
= ada_catch_exception
;
12355 *excep_string
= NULL
;
12357 else if (strcmp (exception_name
, "unhandled") == 0)
12359 /* Catch unhandled exceptions. */
12360 *ex
= ada_catch_exception_unhandled
;
12361 *excep_string
= NULL
;
12365 /* Catch a specific exception. */
12366 *ex
= ada_catch_exception
;
12367 *excep_string
= exception_name
;
12369 *cond_string
= cond
;
12372 /* Return the name of the symbol on which we should break in order to
12373 implement a catchpoint of the EX kind. */
12375 static const char *
12376 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex
)
12378 struct ada_inferior_data
*data
= get_ada_inferior_data (current_inferior ());
12380 gdb_assert (data
->exception_info
!= NULL
);
12384 case ada_catch_exception
:
12385 return (data
->exception_info
->catch_exception_sym
);
12387 case ada_catch_exception_unhandled
:
12388 return (data
->exception_info
->catch_exception_unhandled_sym
);
12390 case ada_catch_assert
:
12391 return (data
->exception_info
->catch_assert_sym
);
12394 internal_error (__FILE__
, __LINE__
,
12395 _("unexpected catchpoint kind (%d)"), ex
);
12399 /* Return the breakpoint ops "virtual table" used for catchpoints
12402 static const struct breakpoint_ops
*
12403 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex
)
12407 case ada_catch_exception
:
12408 return (&catch_exception_breakpoint_ops
);
12410 case ada_catch_exception_unhandled
:
12411 return (&catch_exception_unhandled_breakpoint_ops
);
12413 case ada_catch_assert
:
12414 return (&catch_assert_breakpoint_ops
);
12417 internal_error (__FILE__
, __LINE__
,
12418 _("unexpected catchpoint kind (%d)"), ex
);
12422 /* Return the condition that will be used to match the current exception
12423 being raised with the exception that the user wants to catch. This
12424 assumes that this condition is used when the inferior just triggered
12425 an exception catchpoint.
12427 The string returned is a newly allocated string that needs to be
12428 deallocated later. */
12431 ada_exception_catchpoint_cond_string (const char *excep_string
)
12435 /* The standard exceptions are a special case. They are defined in
12436 runtime units that have been compiled without debugging info; if
12437 EXCEP_STRING is the not-fully-qualified name of a standard
12438 exception (e.g. "constraint_error") then, during the evaluation
12439 of the condition expression, the symbol lookup on this name would
12440 *not* return this standard exception. The catchpoint condition
12441 may then be set only on user-defined exceptions which have the
12442 same not-fully-qualified name (e.g. my_package.constraint_error).
12444 To avoid this unexcepted behavior, these standard exceptions are
12445 systematically prefixed by "standard". This means that "catch
12446 exception constraint_error" is rewritten into "catch exception
12447 standard.constraint_error".
12449 If an exception named contraint_error is defined in another package of
12450 the inferior program, then the only way to specify this exception as a
12451 breakpoint condition is to use its fully-qualified named:
12452 e.g. my_package.constraint_error. */
12454 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
12456 if (strcmp (standard_exc
[i
], excep_string
) == 0)
12458 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
12462 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string
);
12465 /* Return the symtab_and_line that should be used to insert an exception
12466 catchpoint of the TYPE kind.
12468 EXCEP_STRING should contain the name of a specific exception that
12469 the catchpoint should catch, or NULL otherwise.
12471 ADDR_STRING returns the name of the function where the real
12472 breakpoint that implements the catchpoints is set, depending on the
12473 type of catchpoint we need to create. */
12475 static struct symtab_and_line
12476 ada_exception_sal (enum ada_exception_catchpoint_kind ex
, char *excep_string
,
12477 char **addr_string
, const struct breakpoint_ops
**ops
)
12479 const char *sym_name
;
12480 struct symbol
*sym
;
12482 /* First, find out which exception support info to use. */
12483 ada_exception_support_info_sniffer ();
12485 /* Then lookup the function on which we will break in order to catch
12486 the Ada exceptions requested by the user. */
12487 sym_name
= ada_exception_sym_name (ex
);
12488 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
12490 /* We can assume that SYM is not NULL at this stage. If the symbol
12491 did not exist, ada_exception_support_info_sniffer would have
12492 raised an exception.
12494 Also, ada_exception_support_info_sniffer should have already
12495 verified that SYM is a function symbol. */
12496 gdb_assert (sym
!= NULL
);
12497 gdb_assert (SYMBOL_CLASS (sym
) == LOC_BLOCK
);
12499 /* Set ADDR_STRING. */
12500 *addr_string
= xstrdup (sym_name
);
12503 *ops
= ada_exception_breakpoint_ops (ex
);
12505 return find_function_start_sal (sym
, 1);
12508 /* Create an Ada exception catchpoint.
12510 EX_KIND is the kind of exception catchpoint to be created.
12512 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12513 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12514 of the exception to which this catchpoint applies. When not NULL,
12515 the string must be allocated on the heap, and its deallocation
12516 is no longer the responsibility of the caller.
12518 COND_STRING, if not NULL, is the catchpoint condition. This string
12519 must be allocated on the heap, and its deallocation is no longer
12520 the responsibility of the caller.
12522 TEMPFLAG, if nonzero, means that the underlying breakpoint
12523 should be temporary.
12525 FROM_TTY is the usual argument passed to all commands implementations. */
12528 create_ada_exception_catchpoint (struct gdbarch
*gdbarch
,
12529 enum ada_exception_catchpoint_kind ex_kind
,
12530 char *excep_string
,
12536 struct ada_catchpoint
*c
;
12537 char *addr_string
= NULL
;
12538 const struct breakpoint_ops
*ops
= NULL
;
12539 struct symtab_and_line sal
12540 = ada_exception_sal (ex_kind
, excep_string
, &addr_string
, &ops
);
12542 c
= XNEW (struct ada_catchpoint
);
12543 init_ada_exception_breakpoint (&c
->base
, gdbarch
, sal
, addr_string
,
12544 ops
, tempflag
, disabled
, from_tty
);
12545 c
->excep_string
= excep_string
;
12546 create_excep_cond_exprs (c
);
12547 if (cond_string
!= NULL
)
12548 set_breakpoint_condition (&c
->base
, cond_string
, from_tty
);
12549 install_breakpoint (0, &c
->base
, 1);
12552 /* Implement the "catch exception" command. */
12555 catch_ada_exception_command (char *arg
, int from_tty
,
12556 struct cmd_list_element
*command
)
12558 struct gdbarch
*gdbarch
= get_current_arch ();
12560 enum ada_exception_catchpoint_kind ex_kind
;
12561 char *excep_string
= NULL
;
12562 char *cond_string
= NULL
;
12564 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12568 catch_ada_exception_command_split (arg
, &ex_kind
, &excep_string
,
12570 create_ada_exception_catchpoint (gdbarch
, ex_kind
,
12571 excep_string
, cond_string
,
12572 tempflag
, 1 /* enabled */,
12576 /* Split the arguments specified in a "catch assert" command.
12578 ARGS contains the command's arguments (or the empty string if
12579 no arguments were passed).
12581 If ARGS contains a condition, set COND_STRING to that condition
12582 (the memory needs to be deallocated after use). */
12585 catch_ada_assert_command_split (char *args
, char **cond_string
)
12587 args
= skip_spaces (args
);
12589 /* Check whether a condition was provided. */
12590 if (strncmp (args
, "if", 2) == 0
12591 && (isspace (args
[2]) || args
[2] == '\0'))
12594 args
= skip_spaces (args
);
12595 if (args
[0] == '\0')
12596 error (_("condition missing after `if' keyword"));
12597 *cond_string
= xstrdup (args
);
12600 /* Otherwise, there should be no other argument at the end of
12602 else if (args
[0] != '\0')
12603 error (_("Junk at end of arguments."));
12606 /* Implement the "catch assert" command. */
12609 catch_assert_command (char *arg
, int from_tty
,
12610 struct cmd_list_element
*command
)
12612 struct gdbarch
*gdbarch
= get_current_arch ();
12614 char *cond_string
= NULL
;
12616 tempflag
= get_cmd_context (command
) == CATCH_TEMPORARY
;
12620 catch_ada_assert_command_split (arg
, &cond_string
);
12621 create_ada_exception_catchpoint (gdbarch
, ada_catch_assert
,
12623 tempflag
, 1 /* enabled */,
12627 /* Return non-zero if the symbol SYM is an Ada exception object. */
12630 ada_is_exception_sym (struct symbol
*sym
)
12632 const char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
12634 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
12635 && SYMBOL_CLASS (sym
) != LOC_BLOCK
12636 && SYMBOL_CLASS (sym
) != LOC_CONST
12637 && SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
12638 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
12641 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12642 Ada exception object. This matches all exceptions except the ones
12643 defined by the Ada language. */
12646 ada_is_non_standard_exception_sym (struct symbol
*sym
)
12650 if (!ada_is_exception_sym (sym
))
12653 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12654 if (strcmp (SYMBOL_LINKAGE_NAME (sym
), standard_exc
[i
]) == 0)
12655 return 0; /* A standard exception. */
12657 /* Numeric_Error is also a standard exception, so exclude it.
12658 See the STANDARD_EXC description for more details as to why
12659 this exception is not listed in that array. */
12660 if (strcmp (SYMBOL_LINKAGE_NAME (sym
), "numeric_error") == 0)
12666 /* A helper function for qsort, comparing two struct ada_exc_info
12669 The comparison is determined first by exception name, and then
12670 by exception address. */
12673 compare_ada_exception_info (const void *a
, const void *b
)
12675 const struct ada_exc_info
*exc_a
= (struct ada_exc_info
*) a
;
12676 const struct ada_exc_info
*exc_b
= (struct ada_exc_info
*) b
;
12679 result
= strcmp (exc_a
->name
, exc_b
->name
);
12683 if (exc_a
->addr
< exc_b
->addr
)
12685 if (exc_a
->addr
> exc_b
->addr
)
12691 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12692 routine, but keeping the first SKIP elements untouched.
12694 All duplicates are also removed. */
12697 sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info
) **exceptions
,
12700 struct ada_exc_info
*to_sort
12701 = VEC_address (ada_exc_info
, *exceptions
) + skip
;
12703 = VEC_length (ada_exc_info
, *exceptions
) - skip
;
12706 qsort (to_sort
, to_sort_len
, sizeof (struct ada_exc_info
),
12707 compare_ada_exception_info
);
12709 for (i
= 1, j
= 1; i
< to_sort_len
; i
++)
12710 if (compare_ada_exception_info (&to_sort
[i
], &to_sort
[j
- 1]) != 0)
12711 to_sort
[j
++] = to_sort
[i
];
12713 VEC_truncate(ada_exc_info
, *exceptions
, skip
+ to_sort_len
);
12716 /* A function intended as the "name_matcher" callback in the struct
12717 quick_symbol_functions' expand_symtabs_matching method.
12719 SEARCH_NAME is the symbol's search name.
12721 If USER_DATA is not NULL, it is a pointer to a regext_t object
12722 used to match the symbol (by natural name). Otherwise, when USER_DATA
12723 is null, no filtering is performed, and all symbols are a positive
12727 ada_exc_search_name_matches (const char *search_name
, void *user_data
)
12729 regex_t
*preg
= user_data
;
12734 /* In Ada, the symbol "search name" is a linkage name, whereas
12735 the regular expression used to do the matching refers to
12736 the natural name. So match against the decoded name. */
12737 return (regexec (preg
, ada_decode (search_name
), 0, NULL
, 0) == 0);
12740 /* Add all exceptions defined by the Ada standard whose name match
12741 a regular expression.
12743 If PREG is not NULL, then this regexp_t object is used to
12744 perform the symbol name matching. Otherwise, no name-based
12745 filtering is performed.
12747 EXCEPTIONS is a vector of exceptions to which matching exceptions
12751 ada_add_standard_exceptions (regex_t
*preg
, VEC(ada_exc_info
) **exceptions
)
12755 for (i
= 0; i
< ARRAY_SIZE (standard_exc
); i
++)
12758 || regexec (preg
, standard_exc
[i
], 0, NULL
, 0) == 0)
12760 struct bound_minimal_symbol msymbol
12761 = ada_lookup_simple_minsym (standard_exc
[i
]);
12763 if (msymbol
.minsym
!= NULL
)
12765 struct ada_exc_info info
12766 = {standard_exc
[i
], BMSYMBOL_VALUE_ADDRESS (msymbol
)};
12768 VEC_safe_push (ada_exc_info
, *exceptions
, &info
);
12774 /* Add all Ada exceptions defined locally and accessible from the given
12777 If PREG is not NULL, then this regexp_t object is used to
12778 perform the symbol name matching. Otherwise, no name-based
12779 filtering is performed.
12781 EXCEPTIONS is a vector of exceptions to which matching exceptions
12785 ada_add_exceptions_from_frame (regex_t
*preg
, struct frame_info
*frame
,
12786 VEC(ada_exc_info
) **exceptions
)
12788 const struct block
*block
= get_frame_block (frame
, 0);
12792 struct block_iterator iter
;
12793 struct symbol
*sym
;
12795 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
12797 switch (SYMBOL_CLASS (sym
))
12804 if (ada_is_exception_sym (sym
))
12806 struct ada_exc_info info
= {SYMBOL_PRINT_NAME (sym
),
12807 SYMBOL_VALUE_ADDRESS (sym
)};
12809 VEC_safe_push (ada_exc_info
, *exceptions
, &info
);
12813 if (BLOCK_FUNCTION (block
) != NULL
)
12815 block
= BLOCK_SUPERBLOCK (block
);
12819 /* Add all exceptions defined globally whose name name match
12820 a regular expression, excluding standard exceptions.
12822 The reason we exclude standard exceptions is that they need
12823 to be handled separately: Standard exceptions are defined inside
12824 a runtime unit which is normally not compiled with debugging info,
12825 and thus usually do not show up in our symbol search. However,
12826 if the unit was in fact built with debugging info, we need to
12827 exclude them because they would duplicate the entry we found
12828 during the special loop that specifically searches for those
12829 standard exceptions.
12831 If PREG is not NULL, then this regexp_t object is used to
12832 perform the symbol name matching. Otherwise, no name-based
12833 filtering is performed.
12835 EXCEPTIONS is a vector of exceptions to which matching exceptions
12839 ada_add_global_exceptions (regex_t
*preg
, VEC(ada_exc_info
) **exceptions
)
12841 struct objfile
*objfile
;
12844 expand_symtabs_matching (NULL
, ada_exc_search_name_matches
,
12845 VARIABLES_DOMAIN
, preg
);
12847 ALL_PRIMARY_SYMTABS (objfile
, s
)
12849 const struct blockvector
*bv
= BLOCKVECTOR (s
);
12852 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
12854 struct block
*b
= BLOCKVECTOR_BLOCK (bv
, i
);
12855 struct block_iterator iter
;
12856 struct symbol
*sym
;
12858 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
12859 if (ada_is_non_standard_exception_sym (sym
)
12861 || regexec (preg
, SYMBOL_NATURAL_NAME (sym
),
12864 struct ada_exc_info info
12865 = {SYMBOL_PRINT_NAME (sym
), SYMBOL_VALUE_ADDRESS (sym
)};
12867 VEC_safe_push (ada_exc_info
, *exceptions
, &info
);
12873 /* Implements ada_exceptions_list with the regular expression passed
12874 as a regex_t, rather than a string.
12876 If not NULL, PREG is used to filter out exceptions whose names
12877 do not match. Otherwise, all exceptions are listed. */
12879 static VEC(ada_exc_info
) *
12880 ada_exceptions_list_1 (regex_t
*preg
)
12882 VEC(ada_exc_info
) *result
= NULL
;
12883 struct cleanup
*old_chain
12884 = make_cleanup (VEC_cleanup (ada_exc_info
), &result
);
12887 /* First, list the known standard exceptions. These exceptions
12888 need to be handled separately, as they are usually defined in
12889 runtime units that have been compiled without debugging info. */
12891 ada_add_standard_exceptions (preg
, &result
);
12893 /* Next, find all exceptions whose scope is local and accessible
12894 from the currently selected frame. */
12896 if (has_stack_frames ())
12898 prev_len
= VEC_length (ada_exc_info
, result
);
12899 ada_add_exceptions_from_frame (preg
, get_selected_frame (NULL
),
12901 if (VEC_length (ada_exc_info
, result
) > prev_len
)
12902 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
12905 /* Add all exceptions whose scope is global. */
12907 prev_len
= VEC_length (ada_exc_info
, result
);
12908 ada_add_global_exceptions (preg
, &result
);
12909 if (VEC_length (ada_exc_info
, result
) > prev_len
)
12910 sort_remove_dups_ada_exceptions_list (&result
, prev_len
);
12912 discard_cleanups (old_chain
);
12916 /* Return a vector of ada_exc_info.
12918 If REGEXP is NULL, all exceptions are included in the result.
12919 Otherwise, it should contain a valid regular expression,
12920 and only the exceptions whose names match that regular expression
12921 are included in the result.
12923 The exceptions are sorted in the following order:
12924 - Standard exceptions (defined by the Ada language), in
12925 alphabetical order;
12926 - Exceptions only visible from the current frame, in
12927 alphabetical order;
12928 - Exceptions whose scope is global, in alphabetical order. */
12930 VEC(ada_exc_info
) *
12931 ada_exceptions_list (const char *regexp
)
12933 VEC(ada_exc_info
) *result
= NULL
;
12934 struct cleanup
*old_chain
= NULL
;
12937 if (regexp
!= NULL
)
12938 old_chain
= compile_rx_or_error (®
, regexp
,
12939 _("invalid regular expression"));
12941 result
= ada_exceptions_list_1 (regexp
!= NULL
? ®
: NULL
);
12943 if (old_chain
!= NULL
)
12944 do_cleanups (old_chain
);
12948 /* Implement the "info exceptions" command. */
12951 info_exceptions_command (char *regexp
, int from_tty
)
12953 VEC(ada_exc_info
) *exceptions
;
12954 struct cleanup
*cleanup
;
12955 struct gdbarch
*gdbarch
= get_current_arch ();
12957 struct ada_exc_info
*info
;
12959 exceptions
= ada_exceptions_list (regexp
);
12960 cleanup
= make_cleanup (VEC_cleanup (ada_exc_info
), &exceptions
);
12962 if (regexp
!= NULL
)
12964 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp
);
12966 printf_filtered (_("All defined Ada exceptions:\n"));
12968 for (ix
= 0; VEC_iterate(ada_exc_info
, exceptions
, ix
, info
); ix
++)
12969 printf_filtered ("%s: %s\n", info
->name
, paddress (gdbarch
, info
->addr
));
12971 do_cleanups (cleanup
);
12975 /* Information about operators given special treatment in functions
12977 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
12979 #define ADA_OPERATORS \
12980 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
12981 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
12982 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
12983 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
12984 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
12985 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
12986 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
12987 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
12988 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
12989 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
12990 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
12991 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
12992 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
12993 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
12994 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
12995 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
12996 OP_DEFN (OP_OTHERS, 1, 1, 0) \
12997 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
12998 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13001 ada_operator_length (const struct expression
*exp
, int pc
, int *oplenp
,
13004 switch (exp
->elts
[pc
- 1].opcode
)
13007 operator_length_standard (exp
, pc
, oplenp
, argsp
);
13010 #define OP_DEFN(op, len, args, binop) \
13011 case op: *oplenp = len; *argsp = args; break;
13017 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
13022 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
13027 /* Implementation of the exp_descriptor method operator_check. */
13030 ada_operator_check (struct expression
*exp
, int pos
,
13031 int (*objfile_func
) (struct objfile
*objfile
, void *data
),
13034 const union exp_element
*const elts
= exp
->elts
;
13035 struct type
*type
= NULL
;
13037 switch (elts
[pos
].opcode
)
13039 case UNOP_IN_RANGE
:
13041 type
= elts
[pos
+ 1].type
;
13045 return operator_check_standard (exp
, pos
, objfile_func
, data
);
13048 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13050 if (type
&& TYPE_OBJFILE (type
)
13051 && (*objfile_func
) (TYPE_OBJFILE (type
), data
))
13058 ada_op_name (enum exp_opcode opcode
)
13063 return op_name_standard (opcode
);
13065 #define OP_DEFN(op, len, args, binop) case op: return #op;
13070 return "OP_AGGREGATE";
13072 return "OP_CHOICES";
13078 /* As for operator_length, but assumes PC is pointing at the first
13079 element of the operator, and gives meaningful results only for the
13080 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13083 ada_forward_operator_length (struct expression
*exp
, int pc
,
13084 int *oplenp
, int *argsp
)
13086 switch (exp
->elts
[pc
].opcode
)
13089 *oplenp
= *argsp
= 0;
13092 #define OP_DEFN(op, len, args, binop) \
13093 case op: *oplenp = len; *argsp = args; break;
13099 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13104 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
13110 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
13112 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
13120 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
13122 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
13127 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
13131 /* Ada attributes ('Foo). */
13134 case OP_ATR_LENGTH
:
13138 case OP_ATR_MODULUS
:
13145 case UNOP_IN_RANGE
:
13147 /* XXX: gdb_sprint_host_address, type_sprint */
13148 fprintf_filtered (stream
, _("Type @"));
13149 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
13150 fprintf_filtered (stream
, " (");
13151 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
13152 fprintf_filtered (stream
, ")");
13154 case BINOP_IN_BOUNDS
:
13155 fprintf_filtered (stream
, " (%d)",
13156 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
13158 case TERNOP_IN_RANGE
:
13163 case OP_DISCRETE_RANGE
:
13164 case OP_POSITIONAL
:
13171 char *name
= &exp
->elts
[elt
+ 2].string
;
13172 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
13174 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
13179 return dump_subexp_body_standard (exp
, stream
, elt
);
13183 for (i
= 0; i
< nargs
; i
+= 1)
13184 elt
= dump_subexp (exp
, stream
, elt
);
13189 /* The Ada extension of print_subexp (q.v.). */
13192 ada_print_subexp (struct expression
*exp
, int *pos
,
13193 struct ui_file
*stream
, enum precedence prec
)
13195 int oplen
, nargs
, i
;
13197 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
13199 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
13206 print_subexp_standard (exp
, pos
, stream
, prec
);
13210 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
13213 case BINOP_IN_BOUNDS
:
13214 /* XXX: sprint_subexp */
13215 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13216 fputs_filtered (" in ", stream
);
13217 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13218 fputs_filtered ("'range", stream
);
13219 if (exp
->elts
[pc
+ 1].longconst
> 1)
13220 fprintf_filtered (stream
, "(%ld)",
13221 (long) exp
->elts
[pc
+ 1].longconst
);
13224 case TERNOP_IN_RANGE
:
13225 if (prec
>= PREC_EQUAL
)
13226 fputs_filtered ("(", stream
);
13227 /* XXX: sprint_subexp */
13228 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13229 fputs_filtered (" in ", stream
);
13230 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13231 fputs_filtered (" .. ", stream
);
13232 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
13233 if (prec
>= PREC_EQUAL
)
13234 fputs_filtered (")", stream
);
13239 case OP_ATR_LENGTH
:
13243 case OP_ATR_MODULUS
:
13248 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
13250 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
13251 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0,
13252 &type_print_raw_options
);
13256 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13257 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
13262 for (tem
= 1; tem
< nargs
; tem
+= 1)
13264 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
13265 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
13267 fputs_filtered (")", stream
);
13272 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
13273 fputs_filtered ("'(", stream
);
13274 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
13275 fputs_filtered (")", stream
);
13278 case UNOP_IN_RANGE
:
13279 /* XXX: sprint_subexp */
13280 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13281 fputs_filtered (" in ", stream
);
13282 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0,
13283 &type_print_raw_options
);
13286 case OP_DISCRETE_RANGE
:
13287 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13288 fputs_filtered ("..", stream
);
13289 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13293 fputs_filtered ("others => ", stream
);
13294 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13298 for (i
= 0; i
< nargs
-1; i
+= 1)
13301 fputs_filtered ("|", stream
);
13302 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13304 fputs_filtered (" => ", stream
);
13305 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13308 case OP_POSITIONAL
:
13309 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13313 fputs_filtered ("(", stream
);
13314 for (i
= 0; i
< nargs
; i
+= 1)
13317 fputs_filtered (", ", stream
);
13318 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
13320 fputs_filtered (")", stream
);
13325 /* Table mapping opcodes into strings for printing operators
13326 and precedences of the operators. */
13328 static const struct op_print ada_op_print_tab
[] = {
13329 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
13330 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
13331 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
13332 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
13333 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
13334 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
13335 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
13336 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
13337 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
13338 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
13339 {">", BINOP_GTR
, PREC_ORDER
, 0},
13340 {"<", BINOP_LESS
, PREC_ORDER
, 0},
13341 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
13342 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
13343 {"+", BINOP_ADD
, PREC_ADD
, 0},
13344 {"-", BINOP_SUB
, PREC_ADD
, 0},
13345 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
13346 {"*", BINOP_MUL
, PREC_MUL
, 0},
13347 {"/", BINOP_DIV
, PREC_MUL
, 0},
13348 {"rem", BINOP_REM
, PREC_MUL
, 0},
13349 {"mod", BINOP_MOD
, PREC_MUL
, 0},
13350 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
13351 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
13352 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
13353 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
13354 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
13355 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
13356 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
13357 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
13358 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
13359 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
13363 enum ada_primitive_types
{
13364 ada_primitive_type_int
,
13365 ada_primitive_type_long
,
13366 ada_primitive_type_short
,
13367 ada_primitive_type_char
,
13368 ada_primitive_type_float
,
13369 ada_primitive_type_double
,
13370 ada_primitive_type_void
,
13371 ada_primitive_type_long_long
,
13372 ada_primitive_type_long_double
,
13373 ada_primitive_type_natural
,
13374 ada_primitive_type_positive
,
13375 ada_primitive_type_system_address
,
13376 nr_ada_primitive_types
13380 ada_language_arch_info (struct gdbarch
*gdbarch
,
13381 struct language_arch_info
*lai
)
13383 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
13385 lai
->primitive_type_vector
13386 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
13389 lai
->primitive_type_vector
[ada_primitive_type_int
]
13390 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13392 lai
->primitive_type_vector
[ada_primitive_type_long
]
13393 = arch_integer_type (gdbarch
, gdbarch_long_bit (gdbarch
),
13394 0, "long_integer");
13395 lai
->primitive_type_vector
[ada_primitive_type_short
]
13396 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
),
13397 0, "short_integer");
13398 lai
->string_char_type
13399 = lai
->primitive_type_vector
[ada_primitive_type_char
]
13400 = arch_integer_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
13401 lai
->primitive_type_vector
[ada_primitive_type_float
]
13402 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
13404 lai
->primitive_type_vector
[ada_primitive_type_double
]
13405 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13406 "long_float", NULL
);
13407 lai
->primitive_type_vector
[ada_primitive_type_long_long
]
13408 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
),
13409 0, "long_long_integer");
13410 lai
->primitive_type_vector
[ada_primitive_type_long_double
]
13411 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
13412 "long_long_float", NULL
);
13413 lai
->primitive_type_vector
[ada_primitive_type_natural
]
13414 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13416 lai
->primitive_type_vector
[ada_primitive_type_positive
]
13417 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
),
13419 lai
->primitive_type_vector
[ada_primitive_type_void
]
13420 = builtin
->builtin_void
;
13422 lai
->primitive_type_vector
[ada_primitive_type_system_address
]
13423 = lookup_pointer_type (arch_type (gdbarch
, TYPE_CODE_VOID
, 1, "void"));
13424 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
13425 = "system__address";
13427 lai
->bool_type_symbol
= NULL
;
13428 lai
->bool_type_default
= builtin
->builtin_bool
;
13431 /* Language vector */
13433 /* Not really used, but needed in the ada_language_defn. */
13436 emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
13438 ada_emit_char (c
, type
, stream
, quoter
, 1);
13442 parse (struct parser_state
*ps
)
13444 warnings_issued
= 0;
13445 return ada_parse (ps
);
13448 static const struct exp_descriptor ada_exp_descriptor
= {
13450 ada_operator_length
,
13451 ada_operator_check
,
13453 ada_dump_subexp_body
,
13454 ada_evaluate_subexp
13457 /* Implement the "la_get_symbol_name_cmp" language_defn method
13460 static symbol_name_cmp_ftype
13461 ada_get_symbol_name_cmp (const char *lookup_name
)
13463 if (should_use_wild_match (lookup_name
))
13466 return compare_names
;
13469 /* Implement the "la_read_var_value" language_defn method for Ada. */
13471 static struct value
*
13472 ada_read_var_value (struct symbol
*var
, struct frame_info
*frame
)
13474 const struct block
*frame_block
= NULL
;
13475 struct symbol
*renaming_sym
= NULL
;
13477 /* The only case where default_read_var_value is not sufficient
13478 is when VAR is a renaming... */
13480 frame_block
= get_frame_block (frame
, NULL
);
13482 renaming_sym
= ada_find_renaming_symbol (var
, frame_block
);
13483 if (renaming_sym
!= NULL
)
13484 return ada_read_renaming_var_value (renaming_sym
, frame_block
);
13486 /* This is a typical case where we expect the default_read_var_value
13487 function to work. */
13488 return default_read_var_value (var
, frame
);
13491 const struct language_defn ada_language_defn
= {
13492 "ada", /* Language name */
13496 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
13497 that's not quite what this means. */
13499 macro_expansion_no
,
13500 &ada_exp_descriptor
,
13504 ada_printchar
, /* Print a character constant */
13505 ada_printstr
, /* Function to print string constant */
13506 emit_char
, /* Function to print single char (not used) */
13507 ada_print_type
, /* Print a type using appropriate syntax */
13508 ada_print_typedef
, /* Print a typedef using appropriate syntax */
13509 ada_val_print
, /* Print a value using appropriate syntax */
13510 ada_value_print
, /* Print a top-level value */
13511 ada_read_var_value
, /* la_read_var_value */
13512 NULL
, /* Language specific skip_trampoline */
13513 NULL
, /* name_of_this */
13514 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
13515 basic_lookup_transparent_type
, /* lookup_transparent_type */
13516 ada_la_decode
, /* Language specific symbol demangler */
13517 NULL
, /* Language specific
13518 class_name_from_physname */
13519 ada_op_print_tab
, /* expression operators for printing */
13520 0, /* c-style arrays */
13521 1, /* String lower bound */
13522 ada_get_gdb_completer_word_break_characters
,
13523 ada_make_symbol_completion_list
,
13524 ada_language_arch_info
,
13525 ada_print_array_index
,
13526 default_pass_by_reference
,
13528 ada_get_symbol_name_cmp
, /* la_get_symbol_name_cmp */
13529 ada_iterate_over_symbols
,
13534 /* Provide a prototype to silence -Wmissing-prototypes. */
13535 extern initialize_file_ftype _initialize_ada_language
;
13537 /* Command-list for the "set/show ada" prefix command. */
13538 static struct cmd_list_element
*set_ada_list
;
13539 static struct cmd_list_element
*show_ada_list
;
13541 /* Implement the "set ada" prefix command. */
13544 set_ada_command (char *arg
, int from_tty
)
13546 printf_unfiltered (_(\
13547 "\"set ada\" must be followed by the name of a setting.\n"));
13548 help_list (set_ada_list
, "set ada ", all_commands
, gdb_stdout
);
13551 /* Implement the "show ada" prefix command. */
13554 show_ada_command (char *args
, int from_tty
)
13556 cmd_show_list (show_ada_list
, from_tty
, "");
13560 initialize_ada_catchpoint_ops (void)
13562 struct breakpoint_ops
*ops
;
13564 initialize_breakpoint_ops ();
13566 ops
= &catch_exception_breakpoint_ops
;
13567 *ops
= bkpt_breakpoint_ops
;
13568 ops
->dtor
= dtor_catch_exception
;
13569 ops
->allocate_location
= allocate_location_catch_exception
;
13570 ops
->re_set
= re_set_catch_exception
;
13571 ops
->check_status
= check_status_catch_exception
;
13572 ops
->print_it
= print_it_catch_exception
;
13573 ops
->print_one
= print_one_catch_exception
;
13574 ops
->print_mention
= print_mention_catch_exception
;
13575 ops
->print_recreate
= print_recreate_catch_exception
;
13577 ops
= &catch_exception_unhandled_breakpoint_ops
;
13578 *ops
= bkpt_breakpoint_ops
;
13579 ops
->dtor
= dtor_catch_exception_unhandled
;
13580 ops
->allocate_location
= allocate_location_catch_exception_unhandled
;
13581 ops
->re_set
= re_set_catch_exception_unhandled
;
13582 ops
->check_status
= check_status_catch_exception_unhandled
;
13583 ops
->print_it
= print_it_catch_exception_unhandled
;
13584 ops
->print_one
= print_one_catch_exception_unhandled
;
13585 ops
->print_mention
= print_mention_catch_exception_unhandled
;
13586 ops
->print_recreate
= print_recreate_catch_exception_unhandled
;
13588 ops
= &catch_assert_breakpoint_ops
;
13589 *ops
= bkpt_breakpoint_ops
;
13590 ops
->dtor
= dtor_catch_assert
;
13591 ops
->allocate_location
= allocate_location_catch_assert
;
13592 ops
->re_set
= re_set_catch_assert
;
13593 ops
->check_status
= check_status_catch_assert
;
13594 ops
->print_it
= print_it_catch_assert
;
13595 ops
->print_one
= print_one_catch_assert
;
13596 ops
->print_mention
= print_mention_catch_assert
;
13597 ops
->print_recreate
= print_recreate_catch_assert
;
13600 /* This module's 'new_objfile' observer. */
13603 ada_new_objfile_observer (struct objfile
*objfile
)
13605 ada_clear_symbol_cache ();
13608 /* This module's 'free_objfile' observer. */
13611 ada_free_objfile_observer (struct objfile
*objfile
)
13613 ada_clear_symbol_cache ();
13617 _initialize_ada_language (void)
13619 add_language (&ada_language_defn
);
13621 initialize_ada_catchpoint_ops ();
13623 add_prefix_cmd ("ada", no_class
, set_ada_command
,
13624 _("Prefix command for changing Ada-specfic settings"),
13625 &set_ada_list
, "set ada ", 0, &setlist
);
13627 add_prefix_cmd ("ada", no_class
, show_ada_command
,
13628 _("Generic command for showing Ada-specific settings."),
13629 &show_ada_list
, "show ada ", 0, &showlist
);
13631 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure
,
13632 &trust_pad_over_xvs
, _("\
13633 Enable or disable an optimization trusting PAD types over XVS types"), _("\
13634 Show whether an optimization trusting PAD types over XVS types is activated"),
13636 This is related to the encoding used by the GNAT compiler. The debugger\n\
13637 should normally trust the contents of PAD types, but certain older versions\n\
13638 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13639 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13640 work around this bug. It is always safe to turn this option \"off\", but\n\
13641 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13642 this option to \"off\" unless necessary."),
13643 NULL
, NULL
, &set_ada_list
, &show_ada_list
);
13645 add_catch_command ("exception", _("\
13646 Catch Ada exceptions, when raised.\n\
13647 With an argument, catch only exceptions with the given name."),
13648 catch_ada_exception_command
,
13652 add_catch_command ("assert", _("\
13653 Catch failed Ada assertions, when raised.\n\
13654 With an argument, catch only exceptions with the given name."),
13655 catch_assert_command
,
13660 varsize_limit
= 65536;
13662 add_info ("exceptions", info_exceptions_command
,
13664 List all Ada exception names.\n\
13665 If a regular expression is passed as an argument, only those matching\n\
13666 the regular expression are listed."));
13668 add_prefix_cmd ("ada", class_maintenance
, maint_set_ada_cmd
,
13669 _("Set Ada maintenance-related variables."),
13670 &maint_set_ada_cmdlist
, "maintenance set ada ",
13671 0/*allow-unknown*/, &maintenance_set_cmdlist
);
13673 add_prefix_cmd ("ada", class_maintenance
, maint_show_ada_cmd
,
13674 _("Show Ada maintenance-related variables"),
13675 &maint_show_ada_cmdlist
, "maintenance show ada ",
13676 0/*allow-unknown*/, &maintenance_show_cmdlist
);
13678 add_setshow_boolean_cmd
13679 ("ignore-descriptive-types", class_maintenance
,
13680 &ada_ignore_descriptive_types_p
,
13681 _("Set whether descriptive types generated by GNAT should be ignored."),
13682 _("Show whether descriptive types generated by GNAT should be ignored."),
13684 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13685 DWARF attribute."),
13686 NULL
, NULL
, &maint_set_ada_cmdlist
, &maint_show_ada_cmdlist
);
13688 obstack_init (&symbol_list_obstack
);
13690 decoded_names_store
= htab_create_alloc
13691 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
13692 NULL
, xcalloc
, xfree
);
13694 /* The ada-lang observers. */
13695 observer_attach_new_objfile (ada_new_objfile_observer
);
13696 observer_attach_free_objfile (ada_free_objfile_observer
);
13697 observer_attach_inferior_exit (ada_inferior_exit
);
13699 /* Setup various context-specific data. */
13701 = register_inferior_data_with_cleanup (NULL
, ada_inferior_data_cleanup
);
13702 ada_pspace_data_handle
13703 = register_program_space_data_with_cleanup (NULL
, ada_pspace_data_cleanup
);