1 /* Ada language support routines for GDB, the GNU debugger. Copyright (C)
3 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005, 2007, 2008,
4 2009 Free Software Foundation, Inc.
6 This file is part of GDB.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
24 #include "gdb_string.h"
28 #include "gdb_regex.h"
33 #include "expression.h"
34 #include "parser-defs.h"
40 #include "breakpoint.h"
43 #include "gdb_obstack.h"
45 #include "completer.h"
52 #include "dictionary.h"
53 #include "exceptions.h"
60 /* Define whether or not the C operator '/' truncates towards zero for
61 differently signed operands (truncation direction is undefined in C).
62 Copied from valarith.c. */
64 #ifndef TRUNCATION_TOWARDS_ZERO
65 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
68 static void extract_string (CORE_ADDR addr
, char *buf
);
70 static void modify_general_field (char *, LONGEST
, int, int);
72 static struct type
*desc_base_type (struct type
*);
74 static struct type
*desc_bounds_type (struct type
*);
76 static struct value
*desc_bounds (struct value
*);
78 static int fat_pntr_bounds_bitpos (struct type
*);
80 static int fat_pntr_bounds_bitsize (struct type
*);
82 static struct type
*desc_data_type (struct type
*);
84 static struct value
*desc_data (struct value
*);
86 static int fat_pntr_data_bitpos (struct type
*);
88 static int fat_pntr_data_bitsize (struct type
*);
90 static struct value
*desc_one_bound (struct value
*, int, int);
92 static int desc_bound_bitpos (struct type
*, int, int);
94 static int desc_bound_bitsize (struct type
*, int, int);
96 static struct type
*desc_index_type (struct type
*, int);
98 static int desc_arity (struct type
*);
100 static int ada_type_match (struct type
*, struct type
*, int);
102 static int ada_args_match (struct symbol
*, struct value
**, int);
104 static struct value
*ensure_lval (struct value
*, CORE_ADDR
*);
106 static struct value
*convert_actual (struct value
*, struct type
*,
109 static struct value
*make_array_descriptor (struct type
*, struct value
*,
112 static void ada_add_block_symbols (struct obstack
*,
113 struct block
*, const char *,
114 domain_enum
, struct objfile
*, int);
116 static int is_nonfunction (struct ada_symbol_info
*, int);
118 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
121 static int num_defns_collected (struct obstack
*);
123 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
125 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
126 *, const char *, int,
129 static struct symtab
*symtab_for_sym (struct symbol
*);
131 static struct value
*resolve_subexp (struct expression
**, int *, int,
134 static void replace_operator_with_call (struct expression
**, int, int, int,
135 struct symbol
*, struct block
*);
137 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
139 static char *ada_op_name (enum exp_opcode
);
141 static const char *ada_decoded_op_name (enum exp_opcode
);
143 static int numeric_type_p (struct type
*);
145 static int integer_type_p (struct type
*);
147 static int scalar_type_p (struct type
*);
149 static int discrete_type_p (struct type
*);
151 static enum ada_renaming_category
parse_old_style_renaming (struct type
*,
156 static struct symbol
*find_old_style_renaming_symbol (const char *,
159 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
162 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
165 static struct value
*evaluate_subexp_type (struct expression
*, int *);
167 static int is_dynamic_field (struct type
*, int);
169 static struct type
*to_fixed_variant_branch_type (struct type
*,
171 CORE_ADDR
, struct value
*);
173 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
175 static struct type
*to_fixed_range_type (char *, struct value
*,
178 static struct type
*to_static_fixed_type (struct type
*);
179 static struct type
*static_unwrap_type (struct type
*type
);
181 static struct value
*unwrap_value (struct value
*);
183 static struct type
*packed_array_type (struct type
*, long *);
185 static struct type
*decode_packed_array_type (struct type
*);
187 static struct value
*decode_packed_array (struct value
*);
189 static struct value
*value_subscript_packed (struct value
*, int,
192 static void move_bits (gdb_byte
*, int, const gdb_byte
*, int, int);
194 static struct value
*coerce_unspec_val_to_type (struct value
*,
197 static struct value
*get_var_value (char *, char *);
199 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
201 static int equiv_types (struct type
*, struct type
*);
203 static int is_name_suffix (const char *);
205 static int wild_match (const char *, int, const char *);
207 static struct value
*ada_coerce_ref (struct value
*);
209 static LONGEST
pos_atr (struct value
*);
211 static struct value
*value_pos_atr (struct type
*, struct value
*);
213 static struct value
*value_val_atr (struct type
*, struct value
*);
215 static struct symbol
*standard_lookup (const char *, const struct block
*,
218 static struct value
*ada_search_struct_field (char *, struct value
*, int,
221 static struct value
*ada_value_primitive_field (struct value
*, int, int,
224 static int find_struct_field (char *, struct type
*, int,
225 struct type
**, int *, int *, int *, int *);
227 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
230 static struct value
*ada_to_fixed_value (struct value
*);
232 static int ada_resolve_function (struct ada_symbol_info
*, int,
233 struct value
**, int, const char *,
236 static struct value
*ada_coerce_to_simple_array (struct value
*);
238 static int ada_is_direct_array_type (struct type
*);
240 static void ada_language_arch_info (struct gdbarch
*,
241 struct language_arch_info
*);
243 static void check_size (const struct type
*);
245 static struct value
*ada_index_struct_field (int, struct value
*, int,
248 static struct value
*assign_aggregate (struct value
*, struct value
*,
249 struct expression
*, int *, enum noside
);
251 static void aggregate_assign_from_choices (struct value
*, struct value
*,
253 int *, LONGEST
*, int *,
254 int, LONGEST
, LONGEST
);
256 static void aggregate_assign_positional (struct value
*, struct value
*,
258 int *, LONGEST
*, int *, int,
262 static void aggregate_assign_others (struct value
*, struct value
*,
264 int *, LONGEST
*, int, LONGEST
, LONGEST
);
267 static void add_component_interval (LONGEST
, LONGEST
, LONGEST
*, int *, int);
270 static struct value
*ada_evaluate_subexp (struct type
*, struct expression
*,
273 static void ada_forward_operator_length (struct expression
*, int, int *,
278 /* Maximum-sized dynamic type. */
279 static unsigned int varsize_limit
;
281 /* FIXME: brobecker/2003-09-17: No longer a const because it is
282 returned by a function that does not return a const char *. */
283 static char *ada_completer_word_break_characters
=
285 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
287 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
290 /* The name of the symbol to use to get the name of the main subprogram. */
291 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
292 = "__gnat_ada_main_program_name";
294 /* Limit on the number of warnings to raise per expression evaluation. */
295 static int warning_limit
= 2;
297 /* Number of warning messages issued; reset to 0 by cleanups after
298 expression evaluation. */
299 static int warnings_issued
= 0;
301 static const char *known_runtime_file_name_patterns
[] = {
302 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
305 static const char *known_auxiliary_function_name_patterns
[] = {
306 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
309 /* Space for allocating results of ada_lookup_symbol_list. */
310 static struct obstack symbol_list_obstack
;
314 /* Given DECODED_NAME a string holding a symbol name in its
315 decoded form (ie using the Ada dotted notation), returns
316 its unqualified name. */
319 ada_unqualified_name (const char *decoded_name
)
321 const char *result
= strrchr (decoded_name
, '.');
324 result
++; /* Skip the dot... */
326 result
= decoded_name
;
331 /* Return a string starting with '<', followed by STR, and '>'.
332 The result is good until the next call. */
335 add_angle_brackets (const char *str
)
337 static char *result
= NULL
;
340 result
= (char *) xmalloc ((strlen (str
) + 3) * sizeof (char));
342 sprintf (result
, "<%s>", str
);
347 ada_get_gdb_completer_word_break_characters (void)
349 return ada_completer_word_break_characters
;
352 /* Print an array element index using the Ada syntax. */
355 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
356 const struct value_print_options
*options
)
358 LA_VALUE_PRINT (index_value
, stream
, options
);
359 fprintf_filtered (stream
, " => ");
362 /* Read the string located at ADDR from the inferior and store the
366 extract_string (CORE_ADDR addr
, char *buf
)
370 /* Loop, reading one byte at a time, until we reach the '\000'
371 end-of-string marker. */
374 target_read_memory (addr
+ char_index
* sizeof (char),
375 buf
+ char_index
* sizeof (char), sizeof (char));
378 while (buf
[char_index
- 1] != '\000');
381 /* Assuming VECT points to an array of *SIZE objects of size
382 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
383 updating *SIZE as necessary and returning the (new) array. */
386 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
388 if (*size
< min_size
)
391 if (*size
< min_size
)
393 vect
= xrealloc (vect
, *size
* element_size
);
398 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
399 suffix of FIELD_NAME beginning "___". */
402 field_name_match (const char *field_name
, const char *target
)
404 int len
= strlen (target
);
406 (strncmp (field_name
, target
, len
) == 0
407 && (field_name
[len
] == '\0'
408 || (strncmp (field_name
+ len
, "___", 3) == 0
409 && strcmp (field_name
+ strlen (field_name
) - 6,
414 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
415 FIELD_NAME, and return its index. This function also handles fields
416 whose name have ___ suffixes because the compiler sometimes alters
417 their name by adding such a suffix to represent fields with certain
418 constraints. If the field could not be found, return a negative
419 number if MAYBE_MISSING is set. Otherwise raise an error. */
422 ada_get_field_index (const struct type
*type
, const char *field_name
,
426 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (type
); fieldno
++)
427 if (field_name_match (TYPE_FIELD_NAME (type
, fieldno
), field_name
))
431 error (_("Unable to find field %s in struct %s. Aborting"),
432 field_name
, TYPE_NAME (type
));
437 /* The length of the prefix of NAME prior to any "___" suffix. */
440 ada_name_prefix_len (const char *name
)
446 const char *p
= strstr (name
, "___");
448 return strlen (name
);
454 /* Return non-zero if SUFFIX is a suffix of STR.
455 Return zero if STR is null. */
458 is_suffix (const char *str
, const char *suffix
)
464 len2
= strlen (suffix
);
465 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
468 /* The contents of value VAL, treated as a value of type TYPE. The
469 result is an lval in memory if VAL is. */
471 static struct value
*
472 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
474 type
= ada_check_typedef (type
);
475 if (value_type (val
) == type
)
479 struct value
*result
;
481 /* Make sure that the object size is not unreasonable before
482 trying to allocate some memory for it. */
485 result
= allocate_value (type
);
486 set_value_component_location (result
, val
);
487 set_value_bitsize (result
, value_bitsize (val
));
488 set_value_bitpos (result
, value_bitpos (val
));
489 VALUE_ADDRESS (result
) += value_offset (val
);
491 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
492 set_value_lazy (result
, 1);
494 memcpy (value_contents_raw (result
), value_contents (val
),
500 static const gdb_byte
*
501 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
506 return valaddr
+ offset
;
510 cond_offset_target (CORE_ADDR address
, long offset
)
515 return address
+ offset
;
518 /* Issue a warning (as for the definition of warning in utils.c, but
519 with exactly one argument rather than ...), unless the limit on the
520 number of warnings has passed during the evaluation of the current
523 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
524 provided by "complaint". */
525 static void lim_warning (const char *format
, ...) ATTR_FORMAT (printf
, 1, 2);
528 lim_warning (const char *format
, ...)
531 va_start (args
, format
);
533 warnings_issued
+= 1;
534 if (warnings_issued
<= warning_limit
)
535 vwarning (format
, args
);
540 /* Issue an error if the size of an object of type T is unreasonable,
541 i.e. if it would be a bad idea to allocate a value of this type in
545 check_size (const struct type
*type
)
547 if (TYPE_LENGTH (type
) > varsize_limit
)
548 error (_("object size is larger than varsize-limit"));
552 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
553 gdbtypes.h, but some of the necessary definitions in that file
554 seem to have gone missing. */
556 /* Maximum value of a SIZE-byte signed integer type. */
558 max_of_size (int size
)
560 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
561 return top_bit
| (top_bit
- 1);
564 /* Minimum value of a SIZE-byte signed integer type. */
566 min_of_size (int size
)
568 return -max_of_size (size
) - 1;
571 /* Maximum value of a SIZE-byte unsigned integer type. */
573 umax_of_size (int size
)
575 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
576 return top_bit
| (top_bit
- 1);
579 /* Maximum value of integral type T, as a signed quantity. */
581 max_of_type (struct type
*t
)
583 if (TYPE_UNSIGNED (t
))
584 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
586 return max_of_size (TYPE_LENGTH (t
));
589 /* Minimum value of integral type T, as a signed quantity. */
591 min_of_type (struct type
*t
)
593 if (TYPE_UNSIGNED (t
))
596 return min_of_size (TYPE_LENGTH (t
));
599 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
601 discrete_type_high_bound (struct type
*type
)
603 switch (TYPE_CODE (type
))
605 case TYPE_CODE_RANGE
:
606 return TYPE_HIGH_BOUND (type
);
608 return TYPE_FIELD_BITPOS (type
, TYPE_NFIELDS (type
) - 1);
613 return max_of_type (type
);
615 error (_("Unexpected type in discrete_type_high_bound."));
619 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
621 discrete_type_low_bound (struct type
*type
)
623 switch (TYPE_CODE (type
))
625 case TYPE_CODE_RANGE
:
626 return TYPE_LOW_BOUND (type
);
628 return TYPE_FIELD_BITPOS (type
, 0);
633 return min_of_type (type
);
635 error (_("Unexpected type in discrete_type_low_bound."));
639 /* The identity on non-range types. For range types, the underlying
640 non-range scalar type. */
643 base_type (struct type
*type
)
645 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
647 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
649 type
= TYPE_TARGET_TYPE (type
);
655 /* Language Selection */
657 /* If the main program is in Ada, return language_ada, otherwise return LANG
658 (the main program is in Ada iif the adainit symbol is found).
660 MAIN_PST is not used. */
663 ada_update_initial_language (enum language lang
,
664 struct partial_symtab
*main_pst
)
666 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
667 (struct objfile
*) NULL
) != NULL
)
673 /* If the main procedure is written in Ada, then return its name.
674 The result is good until the next call. Return NULL if the main
675 procedure doesn't appear to be in Ada. */
680 struct minimal_symbol
*msym
;
681 CORE_ADDR main_program_name_addr
;
682 static char main_program_name
[1024];
684 /* For Ada, the name of the main procedure is stored in a specific
685 string constant, generated by the binder. Look for that symbol,
686 extract its address, and then read that string. If we didn't find
687 that string, then most probably the main procedure is not written
689 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
693 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
694 if (main_program_name_addr
== 0)
695 error (_("Invalid address for Ada main program name."));
697 extract_string (main_program_name_addr
, main_program_name
);
698 return main_program_name
;
701 /* The main procedure doesn't seem to be in Ada. */
707 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
710 const struct ada_opname_map ada_opname_table
[] = {
711 {"Oadd", "\"+\"", BINOP_ADD
},
712 {"Osubtract", "\"-\"", BINOP_SUB
},
713 {"Omultiply", "\"*\"", BINOP_MUL
},
714 {"Odivide", "\"/\"", BINOP_DIV
},
715 {"Omod", "\"mod\"", BINOP_MOD
},
716 {"Orem", "\"rem\"", BINOP_REM
},
717 {"Oexpon", "\"**\"", BINOP_EXP
},
718 {"Olt", "\"<\"", BINOP_LESS
},
719 {"Ole", "\"<=\"", BINOP_LEQ
},
720 {"Ogt", "\">\"", BINOP_GTR
},
721 {"Oge", "\">=\"", BINOP_GEQ
},
722 {"Oeq", "\"=\"", BINOP_EQUAL
},
723 {"One", "\"/=\"", BINOP_NOTEQUAL
},
724 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
725 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
726 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
727 {"Oconcat", "\"&\"", BINOP_CONCAT
},
728 {"Oabs", "\"abs\"", UNOP_ABS
},
729 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
730 {"Oadd", "\"+\"", UNOP_PLUS
},
731 {"Osubtract", "\"-\"", UNOP_NEG
},
735 /* Return non-zero if STR should be suppressed in info listings. */
738 is_suppressed_name (const char *str
)
740 if (strncmp (str
, "_ada_", 5) == 0)
742 if (str
[0] == '_' || str
[0] == '\000')
747 const char *suffix
= strstr (str
, "___");
748 if (suffix
!= NULL
&& suffix
[3] != 'X')
751 suffix
= str
+ strlen (str
);
752 for (p
= suffix
- 1; p
!= str
; p
-= 1)
756 if (p
[0] == 'X' && p
[-1] != '_')
760 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
761 if (strncmp (ada_opname_table
[i
].encoded
, p
,
762 strlen (ada_opname_table
[i
].encoded
)) == 0)
771 /* The "encoded" form of DECODED, according to GNAT conventions.
772 The result is valid until the next call to ada_encode. */
775 ada_encode (const char *decoded
)
777 static char *encoding_buffer
= NULL
;
778 static size_t encoding_buffer_size
= 0;
785 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
786 2 * strlen (decoded
) + 10);
789 for (p
= decoded
; *p
!= '\0'; p
+= 1)
793 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
798 const struct ada_opname_map
*mapping
;
800 for (mapping
= ada_opname_table
;
801 mapping
->encoded
!= NULL
802 && strncmp (mapping
->decoded
, p
,
803 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
805 if (mapping
->encoded
== NULL
)
806 error (_("invalid Ada operator name: %s"), p
);
807 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
808 k
+= strlen (mapping
->encoded
);
813 encoding_buffer
[k
] = *p
;
818 encoding_buffer
[k
] = '\0';
819 return encoding_buffer
;
822 /* Return NAME folded to lower case, or, if surrounded by single
823 quotes, unfolded, but with the quotes stripped away. Result good
827 ada_fold_name (const char *name
)
829 static char *fold_buffer
= NULL
;
830 static size_t fold_buffer_size
= 0;
832 int len
= strlen (name
);
833 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
837 strncpy (fold_buffer
, name
+ 1, len
- 2);
838 fold_buffer
[len
- 2] = '\000';
843 for (i
= 0; i
<= len
; i
+= 1)
844 fold_buffer
[i
] = tolower (name
[i
]);
850 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
853 is_lower_alphanum (const char c
)
855 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
858 /* Remove either of these suffixes:
863 These are suffixes introduced by the compiler for entities such as
864 nested subprogram for instance, in order to avoid name clashes.
865 They do not serve any purpose for the debugger. */
868 ada_remove_trailing_digits (const char *encoded
, int *len
)
870 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
873 while (i
> 0 && isdigit (encoded
[i
]))
875 if (i
>= 0 && encoded
[i
] == '.')
877 else if (i
>= 0 && encoded
[i
] == '$')
879 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
881 else if (i
>= 1 && strncmp (encoded
+ i
- 1, "__", 2) == 0)
886 /* Remove the suffix introduced by the compiler for protected object
890 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
892 /* Remove trailing N. */
894 /* Protected entry subprograms are broken into two
895 separate subprograms: The first one is unprotected, and has
896 a 'N' suffix; the second is the protected version, and has
897 the 'P' suffix. The second calls the first one after handling
898 the protection. Since the P subprograms are internally generated,
899 we leave these names undecoded, giving the user a clue that this
900 entity is internal. */
903 && encoded
[*len
- 1] == 'N'
904 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
908 /* If ENCODED follows the GNAT entity encoding conventions, then return
909 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
912 The resulting string is valid until the next call of ada_decode.
913 If the string is unchanged by decoding, the original string pointer
917 ada_decode (const char *encoded
)
924 static char *decoding_buffer
= NULL
;
925 static size_t decoding_buffer_size
= 0;
927 /* The name of the Ada main procedure starts with "_ada_".
928 This prefix is not part of the decoded name, so skip this part
929 if we see this prefix. */
930 if (strncmp (encoded
, "_ada_", 5) == 0)
933 /* If the name starts with '_', then it is not a properly encoded
934 name, so do not attempt to decode it. Similarly, if the name
935 starts with '<', the name should not be decoded. */
936 if (encoded
[0] == '_' || encoded
[0] == '<')
939 len0
= strlen (encoded
);
941 ada_remove_trailing_digits (encoded
, &len0
);
942 ada_remove_po_subprogram_suffix (encoded
, &len0
);
944 /* Remove the ___X.* suffix if present. Do not forget to verify that
945 the suffix is located before the current "end" of ENCODED. We want
946 to avoid re-matching parts of ENCODED that have previously been
947 marked as discarded (by decrementing LEN0). */
948 p
= strstr (encoded
, "___");
949 if (p
!= NULL
&& p
- encoded
< len0
- 3)
957 /* Remove any trailing TKB suffix. It tells us that this symbol
958 is for the body of a task, but that information does not actually
959 appear in the decoded name. */
961 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
964 /* Remove trailing "B" suffixes. */
965 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
967 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
970 /* Make decoded big enough for possible expansion by operator name. */
972 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
973 decoded
= decoding_buffer
;
975 /* Remove trailing __{digit}+ or trailing ${digit}+. */
977 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
980 while ((i
>= 0 && isdigit (encoded
[i
]))
981 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
983 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
985 else if (encoded
[i
] == '$')
989 /* The first few characters that are not alphabetic are not part
990 of any encoding we use, so we can copy them over verbatim. */
992 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
993 decoded
[j
] = encoded
[i
];
998 /* Is this a symbol function? */
999 if (at_start_name
&& encoded
[i
] == 'O')
1002 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1004 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1005 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1007 && !isalnum (encoded
[i
+ op_len
]))
1009 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1012 j
+= strlen (ada_opname_table
[k
].decoded
);
1016 if (ada_opname_table
[k
].encoded
!= NULL
)
1021 /* Replace "TK__" with "__", which will eventually be translated
1022 into "." (just below). */
1024 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
1027 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1028 be translated into "." (just below). These are internal names
1029 generated for anonymous blocks inside which our symbol is nested. */
1031 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1032 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1033 && isdigit (encoded
[i
+4]))
1037 while (k
< len0
&& isdigit (encoded
[k
]))
1038 k
++; /* Skip any extra digit. */
1040 /* Double-check that the "__B_{DIGITS}+" sequence we found
1041 is indeed followed by "__". */
1042 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1046 /* Remove _E{DIGITS}+[sb] */
1048 /* Just as for protected object subprograms, there are 2 categories
1049 of subprograms created by the compiler for each entry. The first
1050 one implements the actual entry code, and has a suffix following
1051 the convention above; the second one implements the barrier and
1052 uses the same convention as above, except that the 'E' is replaced
1055 Just as above, we do not decode the name of barrier functions
1056 to give the user a clue that the code he is debugging has been
1057 internally generated. */
1059 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1060 && isdigit (encoded
[i
+2]))
1064 while (k
< len0
&& isdigit (encoded
[k
]))
1068 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1071 /* Just as an extra precaution, make sure that if this
1072 suffix is followed by anything else, it is a '_'.
1073 Otherwise, we matched this sequence by accident. */
1075 || (k
< len0
&& encoded
[k
] == '_'))
1080 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1081 the GNAT front-end in protected object subprograms. */
1084 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1086 /* Backtrack a bit up until we reach either the begining of
1087 the encoded name, or "__". Make sure that we only find
1088 digits or lowercase characters. */
1089 const char *ptr
= encoded
+ i
- 1;
1091 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1094 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1098 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1100 /* This is a X[bn]* sequence not separated from the previous
1101 part of the name with a non-alpha-numeric character (in other
1102 words, immediately following an alpha-numeric character), then
1103 verify that it is placed at the end of the encoded name. If
1104 not, then the encoding is not valid and we should abort the
1105 decoding. Otherwise, just skip it, it is used in body-nested
1109 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1113 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1115 /* Replace '__' by '.'. */
1123 /* It's a character part of the decoded name, so just copy it
1125 decoded
[j
] = encoded
[i
];
1130 decoded
[j
] = '\000';
1132 /* Decoded names should never contain any uppercase character.
1133 Double-check this, and abort the decoding if we find one. */
1135 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1136 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1139 if (strcmp (decoded
, encoded
) == 0)
1145 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1146 decoded
= decoding_buffer
;
1147 if (encoded
[0] == '<')
1148 strcpy (decoded
, encoded
);
1150 sprintf (decoded
, "<%s>", encoded
);
1155 /* Table for keeping permanent unique copies of decoded names. Once
1156 allocated, names in this table are never released. While this is a
1157 storage leak, it should not be significant unless there are massive
1158 changes in the set of decoded names in successive versions of a
1159 symbol table loaded during a single session. */
1160 static struct htab
*decoded_names_store
;
1162 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1163 in the language-specific part of GSYMBOL, if it has not been
1164 previously computed. Tries to save the decoded name in the same
1165 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1166 in any case, the decoded symbol has a lifetime at least that of
1168 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1169 const, but nevertheless modified to a semantically equivalent form
1170 when a decoded name is cached in it.
1174 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1177 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
1178 if (*resultp
== NULL
)
1180 const char *decoded
= ada_decode (gsymbol
->name
);
1181 if (gsymbol
->obj_section
!= NULL
)
1183 struct objfile
*objf
= gsymbol
->obj_section
->objfile
;
1184 *resultp
= obsavestring (decoded
, strlen (decoded
),
1185 &objf
->objfile_obstack
);
1187 /* Sometimes, we can't find a corresponding objfile, in which
1188 case, we put the result on the heap. Since we only decode
1189 when needed, we hope this usually does not cause a
1190 significant memory leak (FIXME). */
1191 if (*resultp
== NULL
)
1193 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1196 *slot
= xstrdup (decoded
);
1205 ada_la_decode (const char *encoded
, int options
)
1207 return xstrdup (ada_decode (encoded
));
1210 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1211 suffixes that encode debugging information or leading _ada_ on
1212 SYM_NAME (see is_name_suffix commentary for the debugging
1213 information that is ignored). If WILD, then NAME need only match a
1214 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1215 either argument is NULL. */
1218 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1220 if (sym_name
== NULL
|| name
== NULL
)
1223 return wild_match (name
, strlen (name
), sym_name
);
1226 int len_name
= strlen (name
);
1227 return (strncmp (sym_name
, name
, len_name
) == 0
1228 && is_name_suffix (sym_name
+ len_name
))
1229 || (strncmp (sym_name
, "_ada_", 5) == 0
1230 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1231 && is_name_suffix (sym_name
+ len_name
+ 5));
1235 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1236 suppressed in info listings. */
1239 ada_suppress_symbol_printing (struct symbol
*sym
)
1241 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1244 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1250 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1252 static char *bound_name
[] = {
1253 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1254 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1257 /* Maximum number of array dimensions we are prepared to handle. */
1259 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1261 /* Like modify_field, but allows bitpos > wordlength. */
1264 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1266 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1270 /* The desc_* routines return primitive portions of array descriptors
1273 /* The descriptor or array type, if any, indicated by TYPE; removes
1274 level of indirection, if needed. */
1276 static struct type
*
1277 desc_base_type (struct type
*type
)
1281 type
= ada_check_typedef (type
);
1283 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1284 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1285 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1290 /* True iff TYPE indicates a "thin" array pointer type. */
1293 is_thin_pntr (struct type
*type
)
1296 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1297 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1300 /* The descriptor type for thin pointer type TYPE. */
1302 static struct type
*
1303 thin_descriptor_type (struct type
*type
)
1305 struct type
*base_type
= desc_base_type (type
);
1306 if (base_type
== NULL
)
1308 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1312 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1313 if (alt_type
== NULL
)
1320 /* A pointer to the array data for thin-pointer value VAL. */
1322 static struct value
*
1323 thin_data_pntr (struct value
*val
)
1325 struct type
*type
= value_type (val
);
1326 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1327 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1330 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1331 VALUE_ADDRESS (val
) + value_offset (val
));
1334 /* True iff TYPE indicates a "thick" array pointer type. */
1337 is_thick_pntr (struct type
*type
)
1339 type
= desc_base_type (type
);
1340 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1341 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1344 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1345 pointer to one, the type of its bounds data; otherwise, NULL. */
1347 static struct type
*
1348 desc_bounds_type (struct type
*type
)
1352 type
= desc_base_type (type
);
1356 else if (is_thin_pntr (type
))
1358 type
= thin_descriptor_type (type
);
1361 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1363 return ada_check_typedef (r
);
1365 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1367 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1369 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1374 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1375 one, a pointer to its bounds data. Otherwise NULL. */
1377 static struct value
*
1378 desc_bounds (struct value
*arr
)
1380 struct type
*type
= ada_check_typedef (value_type (arr
));
1381 if (is_thin_pntr (type
))
1383 struct type
*bounds_type
=
1384 desc_bounds_type (thin_descriptor_type (type
));
1387 if (bounds_type
== NULL
)
1388 error (_("Bad GNAT array descriptor"));
1390 /* NOTE: The following calculation is not really kosher, but
1391 since desc_type is an XVE-encoded type (and shouldn't be),
1392 the correct calculation is a real pain. FIXME (and fix GCC). */
1393 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1394 addr
= value_as_long (arr
);
1396 addr
= VALUE_ADDRESS (arr
) + value_offset (arr
);
1399 value_from_longest (lookup_pointer_type (bounds_type
),
1400 addr
- TYPE_LENGTH (bounds_type
));
1403 else if (is_thick_pntr (type
))
1404 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1405 _("Bad GNAT array descriptor"));
1410 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1411 position of the field containing the address of the bounds data. */
1414 fat_pntr_bounds_bitpos (struct type
*type
)
1416 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1419 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1420 size of the field containing the address of the bounds data. */
1423 fat_pntr_bounds_bitsize (struct type
*type
)
1425 type
= desc_base_type (type
);
1427 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1428 return TYPE_FIELD_BITSIZE (type
, 1);
1430 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1433 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1434 pointer to one, the type of its array data (a
1435 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1436 ada_type_of_array to get an array type with bounds data. */
1438 static struct type
*
1439 desc_data_type (struct type
*type
)
1441 type
= desc_base_type (type
);
1443 /* NOTE: The following is bogus; see comment in desc_bounds. */
1444 if (is_thin_pntr (type
))
1445 return lookup_pointer_type
1446 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1447 else if (is_thick_pntr (type
))
1448 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1453 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1456 static struct value
*
1457 desc_data (struct value
*arr
)
1459 struct type
*type
= value_type (arr
);
1460 if (is_thin_pntr (type
))
1461 return thin_data_pntr (arr
);
1462 else if (is_thick_pntr (type
))
1463 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1464 _("Bad GNAT array descriptor"));
1470 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1471 position of the field containing the address of the data. */
1474 fat_pntr_data_bitpos (struct type
*type
)
1476 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1479 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1480 size of the field containing the address of the data. */
1483 fat_pntr_data_bitsize (struct type
*type
)
1485 type
= desc_base_type (type
);
1487 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1488 return TYPE_FIELD_BITSIZE (type
, 0);
1490 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1493 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1494 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1495 bound, if WHICH is 1. The first bound is I=1. */
1497 static struct value
*
1498 desc_one_bound (struct value
*bounds
, int i
, int which
)
1500 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1501 _("Bad GNAT array descriptor bounds"));
1504 /* If BOUNDS is an array-bounds structure type, return the bit position
1505 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1506 bound, if WHICH is 1. The first bound is I=1. */
1509 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1511 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1514 /* If BOUNDS is an array-bounds structure type, return the bit field size
1515 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1516 bound, if WHICH is 1. The first bound is I=1. */
1519 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1521 type
= desc_base_type (type
);
1523 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1524 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1526 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1529 /* If TYPE is the type of an array-bounds structure, the type of its
1530 Ith bound (numbering from 1). Otherwise, NULL. */
1532 static struct type
*
1533 desc_index_type (struct type
*type
, int i
)
1535 type
= desc_base_type (type
);
1537 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1538 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1543 /* The number of index positions in the array-bounds type TYPE.
1544 Return 0 if TYPE is NULL. */
1547 desc_arity (struct type
*type
)
1549 type
= desc_base_type (type
);
1552 return TYPE_NFIELDS (type
) / 2;
1556 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1557 an array descriptor type (representing an unconstrained array
1561 ada_is_direct_array_type (struct type
*type
)
1565 type
= ada_check_typedef (type
);
1566 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1567 || ada_is_array_descriptor_type (type
));
1570 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1574 ada_is_array_type (struct type
*type
)
1577 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1578 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1579 type
= TYPE_TARGET_TYPE (type
);
1580 return ada_is_direct_array_type (type
);
1583 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1586 ada_is_simple_array_type (struct type
*type
)
1590 type
= ada_check_typedef (type
);
1591 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1592 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1593 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1596 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1599 ada_is_array_descriptor_type (struct type
*type
)
1601 struct type
*data_type
= desc_data_type (type
);
1605 type
= ada_check_typedef (type
);
1608 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1609 && TYPE_TARGET_TYPE (data_type
) != NULL
1610 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1611 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1612 && desc_arity (desc_bounds_type (type
)) > 0;
1615 /* Non-zero iff type is a partially mal-formed GNAT array
1616 descriptor. FIXME: This is to compensate for some problems with
1617 debugging output from GNAT. Re-examine periodically to see if it
1621 ada_is_bogus_array_descriptor (struct type
*type
)
1625 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1626 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1627 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1628 && !ada_is_array_descriptor_type (type
);
1632 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1633 (fat pointer) returns the type of the array data described---specifically,
1634 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1635 in from the descriptor; otherwise, they are left unspecified. If
1636 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1637 returns NULL. The result is simply the type of ARR if ARR is not
1640 ada_type_of_array (struct value
*arr
, int bounds
)
1642 if (ada_is_packed_array_type (value_type (arr
)))
1643 return decode_packed_array_type (value_type (arr
));
1645 if (!ada_is_array_descriptor_type (value_type (arr
)))
1646 return value_type (arr
);
1650 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr
))));
1653 struct type
*elt_type
;
1655 struct value
*descriptor
;
1656 struct objfile
*objf
= TYPE_OBJFILE (value_type (arr
));
1658 elt_type
= ada_array_element_type (value_type (arr
), -1);
1659 arity
= ada_array_arity (value_type (arr
));
1661 if (elt_type
== NULL
|| arity
== 0)
1662 return ada_check_typedef (value_type (arr
));
1664 descriptor
= desc_bounds (arr
);
1665 if (value_as_long (descriptor
) == 0)
1669 struct type
*range_type
= alloc_type (objf
);
1670 struct type
*array_type
= alloc_type (objf
);
1671 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1672 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1675 create_range_type (range_type
, value_type (low
),
1676 longest_to_int (value_as_long (low
)),
1677 longest_to_int (value_as_long (high
)));
1678 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1681 return lookup_pointer_type (elt_type
);
1685 /* If ARR does not represent an array, returns ARR unchanged.
1686 Otherwise, returns either a standard GDB array with bounds set
1687 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1688 GDB array. Returns NULL if ARR is a null fat pointer. */
1691 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1693 if (ada_is_array_descriptor_type (value_type (arr
)))
1695 struct type
*arrType
= ada_type_of_array (arr
, 1);
1696 if (arrType
== NULL
)
1698 return value_cast (arrType
, value_copy (desc_data (arr
)));
1700 else if (ada_is_packed_array_type (value_type (arr
)))
1701 return decode_packed_array (arr
);
1706 /* If ARR does not represent an array, returns ARR unchanged.
1707 Otherwise, returns a standard GDB array describing ARR (which may
1708 be ARR itself if it already is in the proper form). */
1710 static struct value
*
1711 ada_coerce_to_simple_array (struct value
*arr
)
1713 if (ada_is_array_descriptor_type (value_type (arr
)))
1715 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1717 error (_("Bounds unavailable for null array pointer."));
1718 check_size (TYPE_TARGET_TYPE (value_type (arrVal
)));
1719 return value_ind (arrVal
);
1721 else if (ada_is_packed_array_type (value_type (arr
)))
1722 return decode_packed_array (arr
);
1727 /* If TYPE represents a GNAT array type, return it translated to an
1728 ordinary GDB array type (possibly with BITSIZE fields indicating
1729 packing). For other types, is the identity. */
1732 ada_coerce_to_simple_array_type (struct type
*type
)
1734 struct value
*mark
= value_mark ();
1735 struct value
*dummy
= value_from_longest (builtin_type_int32
, 0);
1736 struct type
*result
;
1737 deprecated_set_value_type (dummy
, type
);
1738 result
= ada_type_of_array (dummy
, 0);
1739 value_free_to_mark (mark
);
1743 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1746 ada_is_packed_array_type (struct type
*type
)
1750 type
= desc_base_type (type
);
1751 type
= ada_check_typedef (type
);
1753 ada_type_name (type
) != NULL
1754 && strstr (ada_type_name (type
), "___XP") != NULL
;
1757 /* Given that TYPE is a standard GDB array type with all bounds filled
1758 in, and that the element size of its ultimate scalar constituents
1759 (that is, either its elements, or, if it is an array of arrays, its
1760 elements' elements, etc.) is *ELT_BITS, return an identical type,
1761 but with the bit sizes of its elements (and those of any
1762 constituent arrays) recorded in the BITSIZE components of its
1763 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1766 static struct type
*
1767 packed_array_type (struct type
*type
, long *elt_bits
)
1769 struct type
*new_elt_type
;
1770 struct type
*new_type
;
1771 LONGEST low_bound
, high_bound
;
1773 type
= ada_check_typedef (type
);
1774 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1777 new_type
= alloc_type (TYPE_OBJFILE (type
));
1778 new_elt_type
= packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1780 create_array_type (new_type
, new_elt_type
, TYPE_INDEX_TYPE (type
));
1781 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1782 TYPE_NAME (new_type
) = ada_type_name (type
);
1784 if (get_discrete_bounds (TYPE_INDEX_TYPE (type
),
1785 &low_bound
, &high_bound
) < 0)
1786 low_bound
= high_bound
= 0;
1787 if (high_bound
< low_bound
)
1788 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1791 *elt_bits
*= (high_bound
- low_bound
+ 1);
1792 TYPE_LENGTH (new_type
) =
1793 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1796 TYPE_FIXED_INSTANCE (new_type
) = 1;
1800 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1802 static struct type
*
1803 decode_packed_array_type (struct type
*type
)
1806 struct block
**blocks
;
1807 char *raw_name
= ada_type_name (ada_check_typedef (type
));
1810 struct type
*shadow_type
;
1815 raw_name
= ada_type_name (desc_base_type (type
));
1820 name
= (char *) alloca (strlen (raw_name
) + 1);
1821 tail
= strstr (raw_name
, "___XP");
1822 type
= desc_base_type (type
);
1824 memcpy (name
, raw_name
, tail
- raw_name
);
1825 name
[tail
- raw_name
] = '\000';
1827 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1828 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1830 lim_warning (_("could not find bounds information on packed array"));
1833 shadow_type
= SYMBOL_TYPE (sym
);
1835 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1837 lim_warning (_("could not understand bounds information on packed array"));
1841 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1844 (_("could not understand bit size information on packed array"));
1848 return packed_array_type (shadow_type
, &bits
);
1851 /* Given that ARR is a struct value *indicating a GNAT packed array,
1852 returns a simple array that denotes that array. Its type is a
1853 standard GDB array type except that the BITSIZEs of the array
1854 target types are set to the number of bits in each element, and the
1855 type length is set appropriately. */
1857 static struct value
*
1858 decode_packed_array (struct value
*arr
)
1862 arr
= ada_coerce_ref (arr
);
1863 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
1864 arr
= ada_value_ind (arr
);
1866 type
= decode_packed_array_type (value_type (arr
));
1869 error (_("can't unpack array"));
1873 if (gdbarch_bits_big_endian (current_gdbarch
)
1874 && ada_is_modular_type (value_type (arr
)))
1876 /* This is a (right-justified) modular type representing a packed
1877 array with no wrapper. In order to interpret the value through
1878 the (left-justified) packed array type we just built, we must
1879 first left-justify it. */
1880 int bit_size
, bit_pos
;
1883 mod
= ada_modulus (value_type (arr
)) - 1;
1890 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
1891 arr
= ada_value_primitive_packed_val (arr
, NULL
,
1892 bit_pos
/ HOST_CHAR_BIT
,
1893 bit_pos
% HOST_CHAR_BIT
,
1898 return coerce_unspec_val_to_type (arr
, type
);
1902 /* The value of the element of packed array ARR at the ARITY indices
1903 given in IND. ARR must be a simple array. */
1905 static struct value
*
1906 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1909 int bits
, elt_off
, bit_off
;
1910 long elt_total_bit_offset
;
1911 struct type
*elt_type
;
1915 elt_total_bit_offset
= 0;
1916 elt_type
= ada_check_typedef (value_type (arr
));
1917 for (i
= 0; i
< arity
; i
+= 1)
1919 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1920 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1922 (_("attempt to do packed indexing of something other than a packed array"));
1925 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1926 LONGEST lowerbound
, upperbound
;
1929 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1931 lim_warning (_("don't know bounds of array"));
1932 lowerbound
= upperbound
= 0;
1935 idx
= pos_atr (ind
[i
]);
1936 if (idx
< lowerbound
|| idx
> upperbound
)
1937 lim_warning (_("packed array index %ld out of bounds"), (long) idx
);
1938 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1939 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1940 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
1943 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1944 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1946 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1951 /* Non-zero iff TYPE includes negative integer values. */
1954 has_negatives (struct type
*type
)
1956 switch (TYPE_CODE (type
))
1961 return !TYPE_UNSIGNED (type
);
1962 case TYPE_CODE_RANGE
:
1963 return TYPE_LOW_BOUND (type
) < 0;
1968 /* Create a new value of type TYPE from the contents of OBJ starting
1969 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1970 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1971 assigning through the result will set the field fetched from.
1972 VALADDR is ignored unless OBJ is NULL, in which case,
1973 VALADDR+OFFSET must address the start of storage containing the
1974 packed value. The value returned in this case is never an lval.
1975 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1978 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
1979 long offset
, int bit_offset
, int bit_size
,
1983 int src
, /* Index into the source area */
1984 targ
, /* Index into the target area */
1985 srcBitsLeft
, /* Number of source bits left to move */
1986 nsrc
, ntarg
, /* Number of source and target bytes */
1987 unusedLS
, /* Number of bits in next significant
1988 byte of source that are unused */
1989 accumSize
; /* Number of meaningful bits in accum */
1990 unsigned char *bytes
; /* First byte containing data to unpack */
1991 unsigned char *unpacked
;
1992 unsigned long accum
; /* Staging area for bits being transferred */
1994 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1995 /* Transmit bytes from least to most significant; delta is the direction
1996 the indices move. */
1997 int delta
= gdbarch_bits_big_endian (current_gdbarch
) ? -1 : 1;
1999 type
= ada_check_typedef (type
);
2003 v
= allocate_value (type
);
2004 bytes
= (unsigned char *) (valaddr
+ offset
);
2006 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2009 VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
);
2010 bytes
= (unsigned char *) alloca (len
);
2011 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
2015 v
= allocate_value (type
);
2016 bytes
= (unsigned char *) value_contents (obj
) + offset
;
2021 set_value_component_location (v
, obj
);
2022 VALUE_ADDRESS (v
) += value_offset (obj
) + offset
;
2023 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2024 set_value_bitsize (v
, bit_size
);
2025 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2027 VALUE_ADDRESS (v
) += 1;
2028 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2032 set_value_bitsize (v
, bit_size
);
2033 unpacked
= (unsigned char *) value_contents (v
);
2035 srcBitsLeft
= bit_size
;
2037 ntarg
= TYPE_LENGTH (type
);
2041 memset (unpacked
, 0, TYPE_LENGTH (type
));
2044 else if (gdbarch_bits_big_endian (current_gdbarch
))
2047 if (has_negatives (type
)
2048 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2052 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2055 switch (TYPE_CODE (type
))
2057 case TYPE_CODE_ARRAY
:
2058 case TYPE_CODE_UNION
:
2059 case TYPE_CODE_STRUCT
:
2060 /* Non-scalar values must be aligned at a byte boundary... */
2062 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2063 /* ... And are placed at the beginning (most-significant) bytes
2065 targ
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2069 targ
= TYPE_LENGTH (type
) - 1;
2075 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2078 unusedLS
= bit_offset
;
2081 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
2088 /* Mask for removing bits of the next source byte that are not
2089 part of the value. */
2090 unsigned int unusedMSMask
=
2091 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2093 /* Sign-extend bits for this byte. */
2094 unsigned int signMask
= sign
& ~unusedMSMask
;
2096 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2097 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2098 if (accumSize
>= HOST_CHAR_BIT
)
2100 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2101 accumSize
-= HOST_CHAR_BIT
;
2102 accum
>>= HOST_CHAR_BIT
;
2106 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2113 accum
|= sign
<< accumSize
;
2114 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2115 accumSize
-= HOST_CHAR_BIT
;
2116 accum
>>= HOST_CHAR_BIT
;
2124 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2125 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2128 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
2129 int src_offset
, int n
)
2131 unsigned int accum
, mask
;
2132 int accum_bits
, chunk_size
;
2134 target
+= targ_offset
/ HOST_CHAR_BIT
;
2135 targ_offset
%= HOST_CHAR_BIT
;
2136 source
+= src_offset
/ HOST_CHAR_BIT
;
2137 src_offset
%= HOST_CHAR_BIT
;
2138 if (gdbarch_bits_big_endian (current_gdbarch
))
2140 accum
= (unsigned char) *source
;
2142 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2147 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2148 accum_bits
+= HOST_CHAR_BIT
;
2150 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2153 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2154 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2157 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2159 accum_bits
-= chunk_size
;
2166 accum
= (unsigned char) *source
>> src_offset
;
2168 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2172 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2173 accum_bits
+= HOST_CHAR_BIT
;
2175 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2178 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2179 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2181 accum_bits
-= chunk_size
;
2182 accum
>>= chunk_size
;
2189 /* Store the contents of FROMVAL into the location of TOVAL.
2190 Return a new value with the location of TOVAL and contents of
2191 FROMVAL. Handles assignment into packed fields that have
2192 floating-point or non-scalar types. */
2194 static struct value
*
2195 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2197 struct type
*type
= value_type (toval
);
2198 int bits
= value_bitsize (toval
);
2200 toval
= ada_coerce_ref (toval
);
2201 fromval
= ada_coerce_ref (fromval
);
2203 if (ada_is_direct_array_type (value_type (toval
)))
2204 toval
= ada_coerce_to_simple_array (toval
);
2205 if (ada_is_direct_array_type (value_type (fromval
)))
2206 fromval
= ada_coerce_to_simple_array (fromval
);
2208 if (!deprecated_value_modifiable (toval
))
2209 error (_("Left operand of assignment is not a modifiable lvalue."));
2211 if (VALUE_LVAL (toval
) == lval_memory
2213 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2214 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2216 int len
= (value_bitpos (toval
)
2217 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2219 char *buffer
= (char *) alloca (len
);
2221 CORE_ADDR to_addr
= VALUE_ADDRESS (toval
) + value_offset (toval
);
2223 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2224 fromval
= value_cast (type
, fromval
);
2226 read_memory (to_addr
, buffer
, len
);
2227 from_size
= value_bitsize (fromval
);
2229 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2230 if (gdbarch_bits_big_endian (current_gdbarch
))
2231 move_bits (buffer
, value_bitpos (toval
),
2232 value_contents (fromval
), from_size
- bits
, bits
);
2234 move_bits (buffer
, value_bitpos (toval
), value_contents (fromval
),
2236 write_memory (to_addr
, buffer
, len
);
2237 if (deprecated_memory_changed_hook
)
2238 deprecated_memory_changed_hook (to_addr
, len
);
2240 val
= value_copy (toval
);
2241 memcpy (value_contents_raw (val
), value_contents (fromval
),
2242 TYPE_LENGTH (type
));
2243 deprecated_set_value_type (val
, type
);
2248 return value_assign (toval
, fromval
);
2252 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2253 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2254 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2255 * COMPONENT, and not the inferior's memory. The current contents
2256 * of COMPONENT are ignored. */
2258 value_assign_to_component (struct value
*container
, struct value
*component
,
2261 LONGEST offset_in_container
=
2262 (LONGEST
) (VALUE_ADDRESS (component
) + value_offset (component
)
2263 - VALUE_ADDRESS (container
) - value_offset (container
));
2264 int bit_offset_in_container
=
2265 value_bitpos (component
) - value_bitpos (container
);
2268 val
= value_cast (value_type (component
), val
);
2270 if (value_bitsize (component
) == 0)
2271 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2273 bits
= value_bitsize (component
);
2275 if (gdbarch_bits_big_endian (current_gdbarch
))
2276 move_bits (value_contents_writeable (container
) + offset_in_container
,
2277 value_bitpos (container
) + bit_offset_in_container
,
2278 value_contents (val
),
2279 TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
,
2282 move_bits (value_contents_writeable (container
) + offset_in_container
,
2283 value_bitpos (container
) + bit_offset_in_container
,
2284 value_contents (val
), 0, bits
);
2287 /* The value of the element of array ARR at the ARITY indices given in IND.
2288 ARR may be either a simple array, GNAT array descriptor, or pointer
2292 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2296 struct type
*elt_type
;
2298 elt
= ada_coerce_to_simple_array (arr
);
2300 elt_type
= ada_check_typedef (value_type (elt
));
2301 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2302 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2303 return value_subscript_packed (elt
, arity
, ind
);
2305 for (k
= 0; k
< arity
; k
+= 1)
2307 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2308 error (_("too many subscripts (%d expected)"), k
);
2309 elt
= value_subscript (elt
, value_pos_atr (builtin_type_int32
, ind
[k
]));
2314 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2315 value of the element of *ARR at the ARITY indices given in
2316 IND. Does not read the entire array into memory. */
2319 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2324 for (k
= 0; k
< arity
; k
+= 1)
2329 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2330 error (_("too many subscripts (%d expected)"), k
);
2331 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2333 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2334 idx
= value_pos_atr (builtin_type_int32
, ind
[k
]);
2336 idx
= value_binop (idx
, value_from_longest (value_type (idx
), lwb
),
2339 arr
= value_ptradd (arr
, idx
);
2340 type
= TYPE_TARGET_TYPE (type
);
2343 return value_ind (arr
);
2346 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2347 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2348 elements starting at index LOW. The lower bound of this array is LOW, as
2350 static struct value
*
2351 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2354 CORE_ADDR base
= value_as_address (array_ptr
)
2355 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2356 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2357 struct type
*index_type
=
2358 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2360 struct type
*slice_type
=
2361 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2362 return value_at_lazy (slice_type
, base
);
2366 static struct value
*
2367 ada_value_slice (struct value
*array
, int low
, int high
)
2369 struct type
*type
= value_type (array
);
2370 struct type
*index_type
=
2371 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2372 struct type
*slice_type
=
2373 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2374 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2377 /* If type is a record type in the form of a standard GNAT array
2378 descriptor, returns the number of dimensions for type. If arr is a
2379 simple array, returns the number of "array of"s that prefix its
2380 type designation. Otherwise, returns 0. */
2383 ada_array_arity (struct type
*type
)
2390 type
= desc_base_type (type
);
2393 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2394 return desc_arity (desc_bounds_type (type
));
2396 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2399 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2405 /* If TYPE is a record type in the form of a standard GNAT array
2406 descriptor or a simple array type, returns the element type for
2407 TYPE after indexing by NINDICES indices, or by all indices if
2408 NINDICES is -1. Otherwise, returns NULL. */
2411 ada_array_element_type (struct type
*type
, int nindices
)
2413 type
= desc_base_type (type
);
2415 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2418 struct type
*p_array_type
;
2420 p_array_type
= desc_data_type (type
);
2422 k
= ada_array_arity (type
);
2426 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2427 if (nindices
>= 0 && k
> nindices
)
2429 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2430 while (k
> 0 && p_array_type
!= NULL
)
2432 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2435 return p_array_type
;
2437 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2439 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2441 type
= TYPE_TARGET_TYPE (type
);
2450 /* The type of nth index in arrays of given type (n numbering from 1).
2451 Does not examine memory. */
2454 ada_index_type (struct type
*type
, int n
)
2456 struct type
*result_type
;
2458 type
= desc_base_type (type
);
2460 if (n
> ada_array_arity (type
))
2463 if (ada_is_simple_array_type (type
))
2467 for (i
= 1; i
< n
; i
+= 1)
2468 type
= TYPE_TARGET_TYPE (type
);
2469 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2470 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2471 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2472 perhaps stabsread.c would make more sense. */
2473 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2474 result_type
= builtin_type_int32
;
2479 return desc_index_type (desc_bounds_type (type
), n
);
2482 /* Given that arr is an array type, returns the lower bound of the
2483 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2484 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2485 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2486 bounds type. It works for other arrays with bounds supplied by
2487 run-time quantities other than discriminants. */
2490 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2491 struct type
** typep
)
2493 struct type
*type
, *index_type_desc
, *index_type
;
2496 gdb_assert (which
== 0 || which
== 1);
2498 if (ada_is_packed_array_type (arr_type
))
2499 arr_type
= decode_packed_array_type (arr_type
);
2501 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2504 *typep
= builtin_type_int32
;
2505 return (LONGEST
) - which
;
2508 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2509 type
= TYPE_TARGET_TYPE (arr_type
);
2513 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2514 if (index_type_desc
!= NULL
)
2515 index_type
= to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2516 NULL
, TYPE_OBJFILE (arr_type
));
2521 type
= TYPE_TARGET_TYPE (type
);
2525 index_type
= TYPE_INDEX_TYPE (type
);
2528 switch (TYPE_CODE (index_type
))
2530 case TYPE_CODE_RANGE
:
2531 retval
= which
== 0 ? TYPE_LOW_BOUND (index_type
)
2532 : TYPE_HIGH_BOUND (index_type
);
2534 case TYPE_CODE_ENUM
:
2535 retval
= which
== 0 ? TYPE_FIELD_BITPOS (index_type
, 0)
2536 : TYPE_FIELD_BITPOS (index_type
,
2537 TYPE_NFIELDS (index_type
) - 1);
2540 internal_error (__FILE__
, __LINE__
, _("invalid type code of index type"));
2544 *typep
= index_type
;
2549 /* Given that arr is an array value, returns the lower bound of the
2550 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2551 WHICH is 1. This routine will also work for arrays with bounds
2552 supplied by run-time quantities other than discriminants. */
2555 ada_array_bound (struct value
*arr
, int n
, int which
)
2557 struct type
*arr_type
= value_type (arr
);
2559 if (ada_is_packed_array_type (arr_type
))
2560 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2561 else if (ada_is_simple_array_type (arr_type
))
2564 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2565 return value_from_longest (type
, v
);
2568 return desc_one_bound (desc_bounds (arr
), n
, which
);
2571 /* Given that arr is an array value, returns the length of the
2572 nth index. This routine will also work for arrays with bounds
2573 supplied by run-time quantities other than discriminants.
2574 Does not work for arrays indexed by enumeration types with representation
2575 clauses at the moment. */
2578 ada_array_length (struct value
*arr
, int n
)
2580 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2582 if (ada_is_packed_array_type (arr_type
))
2583 return ada_array_length (decode_packed_array (arr
), n
);
2585 if (ada_is_simple_array_type (arr_type
))
2589 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2590 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2591 return value_from_longest (type
, v
);
2595 value_from_longest (builtin_type_int32
,
2596 value_as_long (desc_one_bound (desc_bounds (arr
),
2598 - value_as_long (desc_one_bound (desc_bounds (arr
),
2602 /* An empty array whose type is that of ARR_TYPE (an array type),
2603 with bounds LOW to LOW-1. */
2605 static struct value
*
2606 empty_array (struct type
*arr_type
, int low
)
2608 struct type
*index_type
=
2609 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2611 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2612 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2616 /* Name resolution */
2618 /* The "decoded" name for the user-definable Ada operator corresponding
2622 ada_decoded_op_name (enum exp_opcode op
)
2626 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2628 if (ada_opname_table
[i
].op
== op
)
2629 return ada_opname_table
[i
].decoded
;
2631 error (_("Could not find operator name for opcode"));
2635 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2636 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2637 undefined namespace) and converts operators that are
2638 user-defined into appropriate function calls. If CONTEXT_TYPE is
2639 non-null, it provides a preferred result type [at the moment, only
2640 type void has any effect---causing procedures to be preferred over
2641 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2642 return type is preferred. May change (expand) *EXP. */
2645 resolve (struct expression
**expp
, int void_context_p
)
2649 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2652 /* Resolve the operator of the subexpression beginning at
2653 position *POS of *EXPP. "Resolving" consists of replacing
2654 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2655 with their resolutions, replacing built-in operators with
2656 function calls to user-defined operators, where appropriate, and,
2657 when DEPROCEDURE_P is non-zero, converting function-valued variables
2658 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2659 are as in ada_resolve, above. */
2661 static struct value
*
2662 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2663 struct type
*context_type
)
2667 struct expression
*exp
; /* Convenience: == *expp. */
2668 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2669 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2670 int nargs
; /* Number of operands. */
2677 /* Pass one: resolve operands, saving their types and updating *pos,
2682 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2683 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2688 resolve_subexp (expp
, pos
, 0, NULL
);
2690 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2695 resolve_subexp (expp
, pos
, 0, NULL
);
2700 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2703 case OP_ATR_MODULUS
:
2713 case TERNOP_IN_RANGE
:
2714 case BINOP_IN_BOUNDS
:
2720 case OP_DISCRETE_RANGE
:
2722 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
2731 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2733 resolve_subexp (expp
, pos
, 1, NULL
);
2735 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2752 case BINOP_LOGICAL_AND
:
2753 case BINOP_LOGICAL_OR
:
2754 case BINOP_BITWISE_AND
:
2755 case BINOP_BITWISE_IOR
:
2756 case BINOP_BITWISE_XOR
:
2759 case BINOP_NOTEQUAL
:
2766 case BINOP_SUBSCRIPT
:
2774 case UNOP_LOGICAL_NOT
:
2790 case OP_INTERNALVAR
:
2800 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2803 case STRUCTOP_STRUCT
:
2804 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2817 error (_("Unexpected operator during name resolution"));
2820 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2821 for (i
= 0; i
< nargs
; i
+= 1)
2822 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2826 /* Pass two: perform any resolution on principal operator. */
2833 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2835 struct ada_symbol_info
*candidates
;
2839 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2840 (exp
->elts
[pc
+ 2].symbol
),
2841 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2844 if (n_candidates
> 1)
2846 /* Types tend to get re-introduced locally, so if there
2847 are any local symbols that are not types, first filter
2850 for (j
= 0; j
< n_candidates
; j
+= 1)
2851 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2856 case LOC_REGPARM_ADDR
:
2864 if (j
< n_candidates
)
2867 while (j
< n_candidates
)
2869 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2871 candidates
[j
] = candidates
[n_candidates
- 1];
2880 if (n_candidates
== 0)
2881 error (_("No definition found for %s"),
2882 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2883 else if (n_candidates
== 1)
2885 else if (deprocedure_p
2886 && !is_nonfunction (candidates
, n_candidates
))
2888 i
= ada_resolve_function
2889 (candidates
, n_candidates
, NULL
, 0,
2890 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2893 error (_("Could not find a match for %s"),
2894 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2898 printf_filtered (_("Multiple matches for %s\n"),
2899 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2900 user_select_syms (candidates
, n_candidates
, 1);
2904 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2905 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2906 if (innermost_block
== NULL
2907 || contained_in (candidates
[i
].block
, innermost_block
))
2908 innermost_block
= candidates
[i
].block
;
2912 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2915 replace_operator_with_call (expp
, pc
, 0, 0,
2916 exp
->elts
[pc
+ 2].symbol
,
2917 exp
->elts
[pc
+ 1].block
);
2924 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2925 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2927 struct ada_symbol_info
*candidates
;
2931 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2932 (exp
->elts
[pc
+ 5].symbol
),
2933 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2935 if (n_candidates
== 1)
2939 i
= ada_resolve_function
2940 (candidates
, n_candidates
,
2942 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2945 error (_("Could not find a match for %s"),
2946 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2949 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2950 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2951 if (innermost_block
== NULL
2952 || contained_in (candidates
[i
].block
, innermost_block
))
2953 innermost_block
= candidates
[i
].block
;
2964 case BINOP_BITWISE_AND
:
2965 case BINOP_BITWISE_IOR
:
2966 case BINOP_BITWISE_XOR
:
2968 case BINOP_NOTEQUAL
:
2976 case UNOP_LOGICAL_NOT
:
2978 if (possible_user_operator_p (op
, argvec
))
2980 struct ada_symbol_info
*candidates
;
2984 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2985 (struct block
*) NULL
, VAR_DOMAIN
,
2987 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2988 ada_decoded_op_name (op
), NULL
);
2992 replace_operator_with_call (expp
, pc
, nargs
, 1,
2993 candidates
[i
].sym
, candidates
[i
].block
);
3004 return evaluate_subexp_type (exp
, pos
);
3007 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3008 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3009 a non-pointer. A type of 'void' (which is never a valid expression type)
3010 by convention matches anything. */
3011 /* The term "match" here is rather loose. The match is heuristic and
3012 liberal. FIXME: TOO liberal, in fact. */
3015 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3017 ftype
= ada_check_typedef (ftype
);
3018 atype
= ada_check_typedef (atype
);
3020 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3021 ftype
= TYPE_TARGET_TYPE (ftype
);
3022 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3023 atype
= TYPE_TARGET_TYPE (atype
);
3025 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
3026 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
3029 switch (TYPE_CODE (ftype
))
3034 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3035 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3036 TYPE_TARGET_TYPE (atype
), 0);
3039 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3041 case TYPE_CODE_ENUM
:
3042 case TYPE_CODE_RANGE
:
3043 switch (TYPE_CODE (atype
))
3046 case TYPE_CODE_ENUM
:
3047 case TYPE_CODE_RANGE
:
3053 case TYPE_CODE_ARRAY
:
3054 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3055 || ada_is_array_descriptor_type (atype
));
3057 case TYPE_CODE_STRUCT
:
3058 if (ada_is_array_descriptor_type (ftype
))
3059 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3060 || ada_is_array_descriptor_type (atype
));
3062 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3063 && !ada_is_array_descriptor_type (atype
));
3065 case TYPE_CODE_UNION
:
3067 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3071 /* Return non-zero if the formals of FUNC "sufficiently match" the
3072 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3073 may also be an enumeral, in which case it is treated as a 0-
3074 argument function. */
3077 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3080 struct type
*func_type
= SYMBOL_TYPE (func
);
3082 if (SYMBOL_CLASS (func
) == LOC_CONST
3083 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3084 return (n_actuals
== 0);
3085 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3088 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3091 for (i
= 0; i
< n_actuals
; i
+= 1)
3093 if (actuals
[i
] == NULL
)
3097 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
3098 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3100 if (!ada_type_match (ftype
, atype
, 1))
3107 /* False iff function type FUNC_TYPE definitely does not produce a value
3108 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3109 FUNC_TYPE is not a valid function type with a non-null return type
3110 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3113 return_match (struct type
*func_type
, struct type
*context_type
)
3115 struct type
*return_type
;
3117 if (func_type
== NULL
)
3120 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3121 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
3123 return_type
= base_type (func_type
);
3124 if (return_type
== NULL
)
3127 context_type
= base_type (context_type
);
3129 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3130 return context_type
== NULL
|| return_type
== context_type
;
3131 else if (context_type
== NULL
)
3132 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3134 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3138 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3139 function (if any) that matches the types of the NARGS arguments in
3140 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3141 that returns that type, then eliminate matches that don't. If
3142 CONTEXT_TYPE is void and there is at least one match that does not
3143 return void, eliminate all matches that do.
3145 Asks the user if there is more than one match remaining. Returns -1
3146 if there is no such symbol or none is selected. NAME is used
3147 solely for messages. May re-arrange and modify SYMS in
3148 the process; the index returned is for the modified vector. */
3151 ada_resolve_function (struct ada_symbol_info syms
[],
3152 int nsyms
, struct value
**args
, int nargs
,
3153 const char *name
, struct type
*context_type
)
3156 int m
; /* Number of hits */
3157 struct type
*fallback
;
3158 struct type
*return_type
;
3160 return_type
= context_type
;
3161 if (context_type
== NULL
)
3162 fallback
= builtin_type_void
;
3169 for (k
= 0; k
< nsyms
; k
+= 1)
3171 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3173 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3174 && return_match (type
, return_type
))
3180 if (m
> 0 || return_type
== fallback
)
3183 return_type
= fallback
;
3190 printf_filtered (_("Multiple matches for %s\n"), name
);
3191 user_select_syms (syms
, m
, 1);
3197 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3198 in a listing of choices during disambiguation (see sort_choices, below).
3199 The idea is that overloadings of a subprogram name from the
3200 same package should sort in their source order. We settle for ordering
3201 such symbols by their trailing number (__N or $N). */
3204 encoded_ordered_before (char *N0
, char *N1
)
3208 else if (N0
== NULL
)
3213 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3215 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3217 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3218 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3222 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3225 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3227 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3228 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3230 return (strcmp (N0
, N1
) < 0);
3234 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3238 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3241 for (i
= 1; i
< nsyms
; i
+= 1)
3243 struct ada_symbol_info sym
= syms
[i
];
3246 for (j
= i
- 1; j
>= 0; j
-= 1)
3248 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3249 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3251 syms
[j
+ 1] = syms
[j
];
3257 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3258 by asking the user (if necessary), returning the number selected,
3259 and setting the first elements of SYMS items. Error if no symbols
3262 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3263 to be re-integrated one of these days. */
3266 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3269 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3271 int first_choice
= (max_results
== 1) ? 1 : 2;
3272 const char *select_mode
= multiple_symbols_select_mode ();
3274 if (max_results
< 1)
3275 error (_("Request to select 0 symbols!"));
3279 if (select_mode
== multiple_symbols_cancel
)
3281 canceled because the command is ambiguous\n\
3282 See set/show multiple-symbol."));
3284 /* If select_mode is "all", then return all possible symbols.
3285 Only do that if more than one symbol can be selected, of course.
3286 Otherwise, display the menu as usual. */
3287 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3290 printf_unfiltered (_("[0] cancel\n"));
3291 if (max_results
> 1)
3292 printf_unfiltered (_("[1] all\n"));
3294 sort_choices (syms
, nsyms
);
3296 for (i
= 0; i
< nsyms
; i
+= 1)
3298 if (syms
[i
].sym
== NULL
)
3301 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3303 struct symtab_and_line sal
=
3304 find_function_start_sal (syms
[i
].sym
, 1);
3305 if (sal
.symtab
== NULL
)
3306 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3308 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3311 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3312 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3313 sal
.symtab
->filename
, sal
.line
);
3319 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3320 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3321 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3322 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3324 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3325 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3327 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3328 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3329 else if (is_enumeral
3330 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3332 printf_unfiltered (("[%d] "), i
+ first_choice
);
3333 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3335 printf_unfiltered (_("'(%s) (enumeral)\n"),
3336 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3338 else if (symtab
!= NULL
)
3339 printf_unfiltered (is_enumeral
3340 ? _("[%d] %s in %s (enumeral)\n")
3341 : _("[%d] %s at %s:?\n"),
3343 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3346 printf_unfiltered (is_enumeral
3347 ? _("[%d] %s (enumeral)\n")
3348 : _("[%d] %s at ?\n"),
3350 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3354 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3357 for (i
= 0; i
< n_chosen
; i
+= 1)
3358 syms
[i
] = syms
[chosen
[i
]];
3363 /* Read and validate a set of numeric choices from the user in the
3364 range 0 .. N_CHOICES-1. Place the results in increasing
3365 order in CHOICES[0 .. N-1], and return N.
3367 The user types choices as a sequence of numbers on one line
3368 separated by blanks, encoding them as follows:
3370 + A choice of 0 means to cancel the selection, throwing an error.
3371 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3372 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3374 The user is not allowed to choose more than MAX_RESULTS values.
3376 ANNOTATION_SUFFIX, if present, is used to annotate the input
3377 prompts (for use with the -f switch). */
3380 get_selections (int *choices
, int n_choices
, int max_results
,
3381 int is_all_choice
, char *annotation_suffix
)
3386 int first_choice
= is_all_choice
? 2 : 1;
3388 prompt
= getenv ("PS2");
3392 args
= command_line_input (prompt
, 0, annotation_suffix
);
3395 error_no_arg (_("one or more choice numbers"));
3399 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3400 order, as given in args. Choices are validated. */
3406 while (isspace (*args
))
3408 if (*args
== '\0' && n_chosen
== 0)
3409 error_no_arg (_("one or more choice numbers"));
3410 else if (*args
== '\0')
3413 choice
= strtol (args
, &args2
, 10);
3414 if (args
== args2
|| choice
< 0
3415 || choice
> n_choices
+ first_choice
- 1)
3416 error (_("Argument must be choice number"));
3420 error (_("cancelled"));
3422 if (choice
< first_choice
)
3424 n_chosen
= n_choices
;
3425 for (j
= 0; j
< n_choices
; j
+= 1)
3429 choice
-= first_choice
;
3431 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3435 if (j
< 0 || choice
!= choices
[j
])
3438 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3439 choices
[k
+ 1] = choices
[k
];
3440 choices
[j
+ 1] = choice
;
3445 if (n_chosen
> max_results
)
3446 error (_("Select no more than %d of the above"), max_results
);
3451 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3452 on the function identified by SYM and BLOCK, and taking NARGS
3453 arguments. Update *EXPP as needed to hold more space. */
3456 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3457 int oplen
, struct symbol
*sym
,
3458 struct block
*block
)
3460 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3461 symbol, -oplen for operator being replaced). */
3462 struct expression
*newexp
= (struct expression
*)
3463 xmalloc (sizeof (struct expression
)
3464 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3465 struct expression
*exp
= *expp
;
3467 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3468 newexp
->language_defn
= exp
->language_defn
;
3469 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3470 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3471 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3473 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3474 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3476 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3477 newexp
->elts
[pc
+ 4].block
= block
;
3478 newexp
->elts
[pc
+ 5].symbol
= sym
;
3484 /* Type-class predicates */
3486 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3490 numeric_type_p (struct type
*type
)
3496 switch (TYPE_CODE (type
))
3501 case TYPE_CODE_RANGE
:
3502 return (type
== TYPE_TARGET_TYPE (type
)
3503 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3510 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3513 integer_type_p (struct type
*type
)
3519 switch (TYPE_CODE (type
))
3523 case TYPE_CODE_RANGE
:
3524 return (type
== TYPE_TARGET_TYPE (type
)
3525 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3532 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3535 scalar_type_p (struct type
*type
)
3541 switch (TYPE_CODE (type
))
3544 case TYPE_CODE_RANGE
:
3545 case TYPE_CODE_ENUM
:
3554 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3557 discrete_type_p (struct type
*type
)
3563 switch (TYPE_CODE (type
))
3566 case TYPE_CODE_RANGE
:
3567 case TYPE_CODE_ENUM
:
3575 /* Returns non-zero if OP with operands in the vector ARGS could be
3576 a user-defined function. Errs on the side of pre-defined operators
3577 (i.e., result 0). */
3580 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3582 struct type
*type0
=
3583 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3584 struct type
*type1
=
3585 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3599 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3603 case BINOP_BITWISE_AND
:
3604 case BINOP_BITWISE_IOR
:
3605 case BINOP_BITWISE_XOR
:
3606 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3609 case BINOP_NOTEQUAL
:
3614 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3617 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
3620 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3624 case UNOP_LOGICAL_NOT
:
3626 return (!numeric_type_p (type0
));
3635 1. In the following, we assume that a renaming type's name may
3636 have an ___XD suffix. It would be nice if this went away at some
3638 2. We handle both the (old) purely type-based representation of
3639 renamings and the (new) variable-based encoding. At some point,
3640 it is devoutly to be hoped that the former goes away
3641 (FIXME: hilfinger-2007-07-09).
3642 3. Subprogram renamings are not implemented, although the XRS
3643 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3645 /* If SYM encodes a renaming,
3647 <renaming> renames <renamed entity>,
3649 sets *LEN to the length of the renamed entity's name,
3650 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3651 the string describing the subcomponent selected from the renamed
3652 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3653 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3654 are undefined). Otherwise, returns a value indicating the category
3655 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3656 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3657 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3658 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3659 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3660 may be NULL, in which case they are not assigned.
3662 [Currently, however, GCC does not generate subprogram renamings.] */
3664 enum ada_renaming_category
3665 ada_parse_renaming (struct symbol
*sym
,
3666 const char **renamed_entity
, int *len
,
3667 const char **renaming_expr
)
3669 enum ada_renaming_category kind
;
3674 return ADA_NOT_RENAMING
;
3675 switch (SYMBOL_CLASS (sym
))
3678 return ADA_NOT_RENAMING
;
3680 return parse_old_style_renaming (SYMBOL_TYPE (sym
),
3681 renamed_entity
, len
, renaming_expr
);
3685 case LOC_OPTIMIZED_OUT
:
3686 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
3688 return ADA_NOT_RENAMING
;
3692 kind
= ADA_OBJECT_RENAMING
;
3696 kind
= ADA_EXCEPTION_RENAMING
;
3700 kind
= ADA_PACKAGE_RENAMING
;
3704 kind
= ADA_SUBPROGRAM_RENAMING
;
3708 return ADA_NOT_RENAMING
;
3712 if (renamed_entity
!= NULL
)
3713 *renamed_entity
= info
;
3714 suffix
= strstr (info
, "___XE");
3715 if (suffix
== NULL
|| suffix
== info
)
3716 return ADA_NOT_RENAMING
;
3718 *len
= strlen (info
) - strlen (suffix
);
3720 if (renaming_expr
!= NULL
)
3721 *renaming_expr
= suffix
;
3725 /* Assuming TYPE encodes a renaming according to the old encoding in
3726 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3727 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3728 ADA_NOT_RENAMING otherwise. */
3729 static enum ada_renaming_category
3730 parse_old_style_renaming (struct type
*type
,
3731 const char **renamed_entity
, int *len
,
3732 const char **renaming_expr
)
3734 enum ada_renaming_category kind
;
3739 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
3740 || TYPE_NFIELDS (type
) != 1)
3741 return ADA_NOT_RENAMING
;
3743 name
= type_name_no_tag (type
);
3745 return ADA_NOT_RENAMING
;
3747 name
= strstr (name
, "___XR");
3749 return ADA_NOT_RENAMING
;
3754 kind
= ADA_OBJECT_RENAMING
;
3757 kind
= ADA_EXCEPTION_RENAMING
;
3760 kind
= ADA_PACKAGE_RENAMING
;
3763 kind
= ADA_SUBPROGRAM_RENAMING
;
3766 return ADA_NOT_RENAMING
;
3769 info
= TYPE_FIELD_NAME (type
, 0);
3771 return ADA_NOT_RENAMING
;
3772 if (renamed_entity
!= NULL
)
3773 *renamed_entity
= info
;
3774 suffix
= strstr (info
, "___XE");
3775 if (renaming_expr
!= NULL
)
3776 *renaming_expr
= suffix
+ 5;
3777 if (suffix
== NULL
|| suffix
== info
)
3778 return ADA_NOT_RENAMING
;
3780 *len
= suffix
- info
;
3786 /* Evaluation: Function Calls */
3788 /* Return an lvalue containing the value VAL. This is the identity on
3789 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3790 on the stack, using and updating *SP as the stack pointer, and
3791 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3793 static struct value
*
3794 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3796 if (! VALUE_LVAL (val
))
3798 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3800 /* The following is taken from the structure-return code in
3801 call_function_by_hand. FIXME: Therefore, some refactoring seems
3803 if (gdbarch_inner_than (current_gdbarch
, 1, 2))
3805 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3806 reserving sufficient space. */
3808 if (gdbarch_frame_align_p (current_gdbarch
))
3809 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3810 VALUE_ADDRESS (val
) = *sp
;
3814 /* Stack grows upward. Align the frame, allocate space, and
3815 then again, re-align the frame. */
3816 if (gdbarch_frame_align_p (current_gdbarch
))
3817 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3818 VALUE_ADDRESS (val
) = *sp
;
3820 if (gdbarch_frame_align_p (current_gdbarch
))
3821 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3823 VALUE_LVAL (val
) = lval_memory
;
3825 write_memory (VALUE_ADDRESS (val
), value_contents_raw (val
), len
);
3831 /* Return the value ACTUAL, converted to be an appropriate value for a
3832 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3833 allocating any necessary descriptors (fat pointers), or copies of
3834 values not residing in memory, updating it as needed. */
3837 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
,
3840 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3841 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3842 struct type
*formal_target
=
3843 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3844 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3845 struct type
*actual_target
=
3846 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3847 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3849 if (ada_is_array_descriptor_type (formal_target
)
3850 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3851 return make_array_descriptor (formal_type
, actual
, sp
);
3852 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3853 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
3855 struct value
*result
;
3856 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3857 && ada_is_array_descriptor_type (actual_target
))
3858 result
= desc_data (actual
);
3859 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3861 if (VALUE_LVAL (actual
) != lval_memory
)
3864 actual_type
= ada_check_typedef (value_type (actual
));
3865 val
= allocate_value (actual_type
);
3866 memcpy ((char *) value_contents_raw (val
),
3867 (char *) value_contents (actual
),
3868 TYPE_LENGTH (actual_type
));
3869 actual
= ensure_lval (val
, sp
);
3871 result
= value_addr (actual
);
3875 return value_cast_pointers (formal_type
, result
);
3877 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3878 return ada_value_ind (actual
);
3884 /* Push a descriptor of type TYPE for array value ARR on the stack at
3885 *SP, updating *SP to reflect the new descriptor. Return either
3886 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3887 to-descriptor type rather than a descriptor type), a struct value *
3888 representing a pointer to this descriptor. */
3890 static struct value
*
3891 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3893 struct type
*bounds_type
= desc_bounds_type (type
);
3894 struct type
*desc_type
= desc_base_type (type
);
3895 struct value
*descriptor
= allocate_value (desc_type
);
3896 struct value
*bounds
= allocate_value (bounds_type
);
3899 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
3901 modify_general_field (value_contents_writeable (bounds
),
3902 value_as_long (ada_array_bound (arr
, i
, 0)),
3903 desc_bound_bitpos (bounds_type
, i
, 0),
3904 desc_bound_bitsize (bounds_type
, i
, 0));
3905 modify_general_field (value_contents_writeable (bounds
),
3906 value_as_long (ada_array_bound (arr
, i
, 1)),
3907 desc_bound_bitpos (bounds_type
, i
, 1),
3908 desc_bound_bitsize (bounds_type
, i
, 1));
3911 bounds
= ensure_lval (bounds
, sp
);
3913 modify_general_field (value_contents_writeable (descriptor
),
3914 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3915 fat_pntr_data_bitpos (desc_type
),
3916 fat_pntr_data_bitsize (desc_type
));
3918 modify_general_field (value_contents_writeable (descriptor
),
3919 VALUE_ADDRESS (bounds
),
3920 fat_pntr_bounds_bitpos (desc_type
),
3921 fat_pntr_bounds_bitsize (desc_type
));
3923 descriptor
= ensure_lval (descriptor
, sp
);
3925 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3926 return value_addr (descriptor
);
3931 /* Dummy definitions for an experimental caching module that is not
3932 * used in the public sources. */
3935 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3936 struct symbol
**sym
, struct block
**block
)
3942 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3943 struct block
*block
)
3949 /* Return the result of a standard (literal, C-like) lookup of NAME in
3950 given DOMAIN, visible from lexical block BLOCK. */
3952 static struct symbol
*
3953 standard_lookup (const char *name
, const struct block
*block
,
3958 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
))
3960 sym
= lookup_symbol_in_language (name
, block
, domain
, language_c
, 0);
3961 cache_symbol (name
, domain
, sym
, block_found
);
3966 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3967 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3968 since they contend in overloading in the same way. */
3970 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3974 for (i
= 0; i
< n
; i
+= 1)
3975 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3976 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3977 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3983 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3984 struct types. Otherwise, they may not. */
3987 equiv_types (struct type
*type0
, struct type
*type1
)
3991 if (type0
== NULL
|| type1
== NULL
3992 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3994 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3995 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3996 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3997 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4003 /* True iff SYM0 represents the same entity as SYM1, or one that is
4004 no more defined than that of SYM1. */
4007 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4011 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4012 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4015 switch (SYMBOL_CLASS (sym0
))
4021 struct type
*type0
= SYMBOL_TYPE (sym0
);
4022 struct type
*type1
= SYMBOL_TYPE (sym1
);
4023 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4024 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4025 int len0
= strlen (name0
);
4027 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4028 && (equiv_types (type0
, type1
)
4029 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4030 && strncmp (name1
+ len0
, "___XV", 5) == 0));
4033 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4034 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4040 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4041 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4044 add_defn_to_vec (struct obstack
*obstackp
,
4046 struct block
*block
)
4050 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
4052 /* Do not try to complete stub types, as the debugger is probably
4053 already scanning all symbols matching a certain name at the
4054 time when this function is called. Trying to replace the stub
4055 type by its associated full type will cause us to restart a scan
4056 which may lead to an infinite recursion. Instead, the client
4057 collecting the matching symbols will end up collecting several
4058 matches, with at least one of them complete. It can then filter
4059 out the stub ones if needed. */
4061 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4063 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
4065 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
4067 prevDefns
[i
].sym
= sym
;
4068 prevDefns
[i
].block
= block
;
4074 struct ada_symbol_info info
;
4078 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
4082 /* Number of ada_symbol_info structures currently collected in
4083 current vector in *OBSTACKP. */
4086 num_defns_collected (struct obstack
*obstackp
)
4088 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
4091 /* Vector of ada_symbol_info structures currently collected in current
4092 vector in *OBSTACKP. If FINISH, close off the vector and return
4093 its final address. */
4095 static struct ada_symbol_info
*
4096 defns_collected (struct obstack
*obstackp
, int finish
)
4099 return obstack_finish (obstackp
);
4101 return (struct ada_symbol_info
*) obstack_base (obstackp
);
4104 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
4105 Check the global symbols if GLOBAL, the static symbols if not.
4106 Do wild-card match if WILD. */
4108 static struct partial_symbol
*
4109 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
4110 int global
, domain_enum
namespace, int wild
)
4112 struct partial_symbol
**start
;
4113 int name_len
= strlen (name
);
4114 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
4123 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
4124 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
4128 for (i
= 0; i
< length
; i
+= 1)
4130 struct partial_symbol
*psym
= start
[i
];
4132 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4133 SYMBOL_DOMAIN (psym
), namespace)
4134 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
4148 int M
= (U
+ i
) >> 1;
4149 struct partial_symbol
*psym
= start
[M
];
4150 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
4152 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
4154 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
4165 struct partial_symbol
*psym
= start
[i
];
4167 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4168 SYMBOL_DOMAIN (psym
), namespace))
4170 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
4178 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4192 int M
= (U
+ i
) >> 1;
4193 struct partial_symbol
*psym
= start
[M
];
4194 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
4196 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
4198 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
4209 struct partial_symbol
*psym
= start
[i
];
4211 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4212 SYMBOL_DOMAIN (psym
), namespace))
4216 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
4219 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
4221 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
4231 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4241 /* Find a symbol table containing symbol SYM or NULL if none. */
4243 static struct symtab
*
4244 symtab_for_sym (struct symbol
*sym
)
4247 struct objfile
*objfile
;
4249 struct symbol
*tmp_sym
;
4250 struct dict_iterator iter
;
4253 ALL_PRIMARY_SYMTABS (objfile
, s
)
4255 switch (SYMBOL_CLASS (sym
))
4263 case LOC_CONST_BYTES
:
4264 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
4265 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4267 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
4268 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4274 switch (SYMBOL_CLASS (sym
))
4279 case LOC_REGPARM_ADDR
:
4283 for (j
= FIRST_LOCAL_BLOCK
;
4284 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
4286 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
4287 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4298 /* Return a minimal symbol matching NAME according to Ada decoding
4299 rules. Returns NULL if there is no such minimal symbol. Names
4300 prefixed with "standard__" are handled specially: "standard__" is
4301 first stripped off, and only static and global symbols are searched. */
4303 struct minimal_symbol
*
4304 ada_lookup_simple_minsym (const char *name
)
4306 struct objfile
*objfile
;
4307 struct minimal_symbol
*msymbol
;
4310 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4312 name
+= sizeof ("standard__") - 1;
4316 wild_match
= (strstr (name
, "__") == NULL
);
4318 ALL_MSYMBOLS (objfile
, msymbol
)
4320 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4321 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4328 /* For all subprograms that statically enclose the subprogram of the
4329 selected frame, add symbols matching identifier NAME in DOMAIN
4330 and their blocks to the list of data in OBSTACKP, as for
4331 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4335 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4336 const char *name
, domain_enum
namespace,
4341 /* True if TYPE is definitely an artificial type supplied to a symbol
4342 for which no debugging information was given in the symbol file. */
4345 is_nondebugging_type (struct type
*type
)
4347 char *name
= ada_type_name (type
);
4348 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4351 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4352 duplicate other symbols in the list (The only case I know of where
4353 this happens is when object files containing stabs-in-ecoff are
4354 linked with files containing ordinary ecoff debugging symbols (or no
4355 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4356 Returns the number of items in the modified list. */
4359 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4368 /* If two symbols have the same name and one of them is a stub type,
4369 the get rid of the stub. */
4371 if (TYPE_STUB (SYMBOL_TYPE (syms
[i
].sym
))
4372 && SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
)
4374 for (j
= 0; j
< nsyms
; j
++)
4377 && !TYPE_STUB (SYMBOL_TYPE (syms
[j
].sym
))
4378 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4379 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4380 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0)
4385 /* Two symbols with the same name, same class and same address
4386 should be identical. */
4388 else if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4389 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4390 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4392 for (j
= 0; j
< nsyms
; j
+= 1)
4395 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4396 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4397 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4398 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4399 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4400 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4407 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4408 syms
[j
- 1] = syms
[j
];
4417 /* Given a type that corresponds to a renaming entity, use the type name
4418 to extract the scope (package name or function name, fully qualified,
4419 and following the GNAT encoding convention) where this renaming has been
4420 defined. The string returned needs to be deallocated after use. */
4423 xget_renaming_scope (struct type
*renaming_type
)
4425 /* The renaming types adhere to the following convention:
4426 <scope>__<rename>___<XR extension>.
4427 So, to extract the scope, we search for the "___XR" extension,
4428 and then backtrack until we find the first "__". */
4430 const char *name
= type_name_no_tag (renaming_type
);
4431 char *suffix
= strstr (name
, "___XR");
4436 /* Now, backtrack a bit until we find the first "__". Start looking
4437 at suffix - 3, as the <rename> part is at least one character long. */
4439 for (last
= suffix
- 3; last
> name
; last
--)
4440 if (last
[0] == '_' && last
[1] == '_')
4443 /* Make a copy of scope and return it. */
4445 scope_len
= last
- name
;
4446 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4448 strncpy (scope
, name
, scope_len
);
4449 scope
[scope_len
] = '\0';
4454 /* Return nonzero if NAME corresponds to a package name. */
4457 is_package_name (const char *name
)
4459 /* Here, We take advantage of the fact that no symbols are generated
4460 for packages, while symbols are generated for each function.
4461 So the condition for NAME represent a package becomes equivalent
4462 to NAME not existing in our list of symbols. There is only one
4463 small complication with library-level functions (see below). */
4467 /* If it is a function that has not been defined at library level,
4468 then we should be able to look it up in the symbols. */
4469 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4472 /* Library-level function names start with "_ada_". See if function
4473 "_ada_" followed by NAME can be found. */
4475 /* Do a quick check that NAME does not contain "__", since library-level
4476 functions names cannot contain "__" in them. */
4477 if (strstr (name
, "__") != NULL
)
4480 fun_name
= xstrprintf ("_ada_%s", name
);
4482 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4485 /* Return nonzero if SYM corresponds to a renaming entity that is
4486 not visible from FUNCTION_NAME. */
4489 old_renaming_is_invisible (const struct symbol
*sym
, char *function_name
)
4493 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
4496 scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4498 make_cleanup (xfree
, scope
);
4500 /* If the rename has been defined in a package, then it is visible. */
4501 if (is_package_name (scope
))
4504 /* Check that the rename is in the current function scope by checking
4505 that its name starts with SCOPE. */
4507 /* If the function name starts with "_ada_", it means that it is
4508 a library-level function. Strip this prefix before doing the
4509 comparison, as the encoding for the renaming does not contain
4511 if (strncmp (function_name
, "_ada_", 5) == 0)
4514 return (strncmp (function_name
, scope
, strlen (scope
)) != 0);
4517 /* Remove entries from SYMS that corresponds to a renaming entity that
4518 is not visible from the function associated with CURRENT_BLOCK or
4519 that is superfluous due to the presence of more specific renaming
4520 information. Places surviving symbols in the initial entries of
4521 SYMS and returns the number of surviving symbols.
4524 First, in cases where an object renaming is implemented as a
4525 reference variable, GNAT may produce both the actual reference
4526 variable and the renaming encoding. In this case, we discard the
4529 Second, GNAT emits a type following a specified encoding for each renaming
4530 entity. Unfortunately, STABS currently does not support the definition
4531 of types that are local to a given lexical block, so all renamings types
4532 are emitted at library level. As a consequence, if an application
4533 contains two renaming entities using the same name, and a user tries to
4534 print the value of one of these entities, the result of the ada symbol
4535 lookup will also contain the wrong renaming type.
4537 This function partially covers for this limitation by attempting to
4538 remove from the SYMS list renaming symbols that should be visible
4539 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4540 method with the current information available. The implementation
4541 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4543 - When the user tries to print a rename in a function while there
4544 is another rename entity defined in a package: Normally, the
4545 rename in the function has precedence over the rename in the
4546 package, so the latter should be removed from the list. This is
4547 currently not the case.
4549 - This function will incorrectly remove valid renames if
4550 the CURRENT_BLOCK corresponds to a function which symbol name
4551 has been changed by an "Export" pragma. As a consequence,
4552 the user will be unable to print such rename entities. */
4555 remove_irrelevant_renamings (struct ada_symbol_info
*syms
,
4556 int nsyms
, const struct block
*current_block
)
4558 struct symbol
*current_function
;
4559 char *current_function_name
;
4561 int is_new_style_renaming
;
4563 /* If there is both a renaming foo___XR... encoded as a variable and
4564 a simple variable foo in the same block, discard the latter.
4565 First, zero out such symbols, then compress. */
4566 is_new_style_renaming
= 0;
4567 for (i
= 0; i
< nsyms
; i
+= 1)
4569 struct symbol
*sym
= syms
[i
].sym
;
4570 struct block
*block
= syms
[i
].block
;
4574 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
4576 name
= SYMBOL_LINKAGE_NAME (sym
);
4577 suffix
= strstr (name
, "___XR");
4581 int name_len
= suffix
- name
;
4583 is_new_style_renaming
= 1;
4584 for (j
= 0; j
< nsyms
; j
+= 1)
4585 if (i
!= j
&& syms
[j
].sym
!= NULL
4586 && strncmp (name
, SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
4588 && block
== syms
[j
].block
)
4592 if (is_new_style_renaming
)
4596 for (j
= k
= 0; j
< nsyms
; j
+= 1)
4597 if (syms
[j
].sym
!= NULL
)
4605 /* Extract the function name associated to CURRENT_BLOCK.
4606 Abort if unable to do so. */
4608 if (current_block
== NULL
)
4611 current_function
= block_linkage_function (current_block
);
4612 if (current_function
== NULL
)
4615 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4616 if (current_function_name
== NULL
)
4619 /* Check each of the symbols, and remove it from the list if it is
4620 a type corresponding to a renaming that is out of the scope of
4621 the current block. */
4626 if (ada_parse_renaming (syms
[i
].sym
, NULL
, NULL
, NULL
)
4627 == ADA_OBJECT_RENAMING
4628 && old_renaming_is_invisible (syms
[i
].sym
, current_function_name
))
4631 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4632 syms
[j
- 1] = syms
[j
];
4642 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4643 whose name and domain match NAME and DOMAIN respectively.
4644 If no match was found, then extend the search to "enclosing"
4645 routines (in other words, if we're inside a nested function,
4646 search the symbols defined inside the enclosing functions).
4648 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4651 ada_add_local_symbols (struct obstack
*obstackp
, const char *name
,
4652 struct block
*block
, domain_enum domain
,
4655 int block_depth
= 0;
4657 while (block
!= NULL
)
4660 ada_add_block_symbols (obstackp
, block
, name
, domain
, NULL
, wild_match
);
4662 /* If we found a non-function match, assume that's the one. */
4663 if (is_nonfunction (defns_collected (obstackp
, 0),
4664 num_defns_collected (obstackp
)))
4667 block
= BLOCK_SUPERBLOCK (block
);
4670 /* If no luck so far, try to find NAME as a local symbol in some lexically
4671 enclosing subprogram. */
4672 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
4673 add_symbols_from_enclosing_procs (obstackp
, name
, domain
, wild_match
);
4676 /* Add to OBSTACKP all non-local symbols whose name and domain match
4677 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
4678 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
4681 ada_add_non_local_symbols (struct obstack
*obstackp
, const char *name
,
4682 domain_enum domain
, int global
,
4685 struct objfile
*objfile
;
4686 struct partial_symtab
*ps
;
4688 ALL_PSYMTABS (objfile
, ps
)
4692 || ada_lookup_partial_symbol (ps
, name
, global
, domain
, wild_match
))
4694 struct symtab
*s
= PSYMTAB_TO_SYMTAB (ps
);
4695 const int block_kind
= global
? GLOBAL_BLOCK
: STATIC_BLOCK
;
4697 if (s
== NULL
|| !s
->primary
)
4699 ada_add_block_symbols (obstackp
,
4700 BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), block_kind
),
4701 name
, domain
, objfile
, wild_match
);
4706 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4707 scope and in global scopes, returning the number of matches. Sets
4708 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4709 indicating the symbols found and the blocks and symbol tables (if
4710 any) in which they were found. This vector are transient---good only to
4711 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4712 symbol match within the nest of blocks whose innermost member is BLOCK0,
4713 is the one match returned (no other matches in that or
4714 enclosing blocks is returned). If there are any matches in or
4715 surrounding BLOCK0, then these alone are returned. Otherwise, the
4716 search extends to global and file-scope (static) symbol tables.
4717 Names prefixed with "standard__" are handled specially: "standard__"
4718 is first stripped off, and only static and global symbols are searched. */
4721 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4722 domain_enum
namespace,
4723 struct ada_symbol_info
**results
)
4726 struct block
*block
;
4732 obstack_free (&symbol_list_obstack
, NULL
);
4733 obstack_init (&symbol_list_obstack
);
4737 /* Search specified block and its superiors. */
4739 wild_match
= (strstr (name0
, "__") == NULL
);
4741 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4742 needed, but adding const will
4743 have a cascade effect. */
4745 /* Special case: If the user specifies a symbol name inside package
4746 Standard, do a non-wild matching of the symbol name without
4747 the "standard__" prefix. This was primarily introduced in order
4748 to allow the user to specifically access the standard exceptions
4749 using, for instance, Standard.Constraint_Error when Constraint_Error
4750 is ambiguous (due to the user defining its own Constraint_Error
4751 entity inside its program). */
4752 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4756 name
= name0
+ sizeof ("standard__") - 1;
4759 /* Check the non-global symbols. If we have ANY match, then we're done. */
4761 ada_add_local_symbols (&symbol_list_obstack
, name
, block
, namespace,
4763 if (num_defns_collected (&symbol_list_obstack
) > 0)
4766 /* No non-global symbols found. Check our cache to see if we have
4767 already performed this search before. If we have, then return
4771 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
))
4774 add_defn_to_vec (&symbol_list_obstack
, sym
, block
);
4778 /* Search symbols from all global blocks. */
4780 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 1,
4783 /* Now add symbols from all per-file blocks if we've gotten no hits
4784 (not strictly correct, but perhaps better than an error). */
4786 if (num_defns_collected (&symbol_list_obstack
) == 0)
4787 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 0,
4791 ndefns
= num_defns_collected (&symbol_list_obstack
);
4792 *results
= defns_collected (&symbol_list_obstack
, 1);
4794 ndefns
= remove_extra_symbols (*results
, ndefns
);
4797 cache_symbol (name0
, namespace, NULL
, NULL
);
4799 if (ndefns
== 1 && cacheIfUnique
)
4800 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
);
4802 ndefns
= remove_irrelevant_renamings (*results
, ndefns
, block0
);
4808 ada_lookup_encoded_symbol (const char *name
, const struct block
*block0
,
4809 domain_enum
namespace, struct block
**block_found
)
4811 struct ada_symbol_info
*candidates
;
4814 n_candidates
= ada_lookup_symbol_list (name
, block0
, namespace, &candidates
);
4816 if (n_candidates
== 0)
4819 if (block_found
!= NULL
)
4820 *block_found
= candidates
[0].block
;
4822 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4825 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4826 scope and in global scopes, or NULL if none. NAME is folded and
4827 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4828 choosing the first symbol if there are multiple choices.
4829 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4830 table in which the symbol was found (in both cases, these
4831 assignments occur only if the pointers are non-null). */
4833 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4834 domain_enum
namespace, int *is_a_field_of_this
)
4836 if (is_a_field_of_this
!= NULL
)
4837 *is_a_field_of_this
= 0;
4840 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name
)),
4841 block0
, namespace, NULL
);
4844 static struct symbol
*
4845 ada_lookup_symbol_nonlocal (const char *name
,
4846 const char *linkage_name
,
4847 const struct block
*block
,
4848 const domain_enum domain
)
4850 if (linkage_name
== NULL
)
4851 linkage_name
= name
;
4852 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4857 /* True iff STR is a possible encoded suffix of a normal Ada name
4858 that is to be ignored for matching purposes. Suffixes of parallel
4859 names (e.g., XVE) are not included here. Currently, the possible suffixes
4860 are given by any of the regular expressions:
4862 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
4863 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4864 _E[0-9]+[bs]$ [protected object entry suffixes]
4865 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4867 Also, any leading "__[0-9]+" sequence is skipped before the suffix
4868 match is performed. This sequence is used to differentiate homonyms,
4869 is an optional part of a valid name suffix. */
4872 is_name_suffix (const char *str
)
4875 const char *matching
;
4876 const int len
= strlen (str
);
4878 /* Skip optional leading __[0-9]+. */
4880 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4883 while (isdigit (str
[0]))
4889 if (str
[0] == '.' || str
[0] == '$')
4892 while (isdigit (matching
[0]))
4894 if (matching
[0] == '\0')
4900 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4903 while (isdigit (matching
[0]))
4905 if (matching
[0] == '\0')
4910 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4911 with a N at the end. Unfortunately, the compiler uses the same
4912 convention for other internal types it creates. So treating
4913 all entity names that end with an "N" as a name suffix causes
4914 some regressions. For instance, consider the case of an enumerated
4915 type. To support the 'Image attribute, it creates an array whose
4917 Having a single character like this as a suffix carrying some
4918 information is a bit risky. Perhaps we should change the encoding
4919 to be something like "_N" instead. In the meantime, do not do
4920 the following check. */
4921 /* Protected Object Subprograms */
4922 if (len
== 1 && str
[0] == 'N')
4927 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
4930 while (isdigit (matching
[0]))
4932 if ((matching
[0] == 'b' || matching
[0] == 's')
4933 && matching
[1] == '\0')
4937 /* ??? We should not modify STR directly, as we are doing below. This
4938 is fine in this case, but may become problematic later if we find
4939 that this alternative did not work, and want to try matching
4940 another one from the begining of STR. Since we modified it, we
4941 won't be able to find the begining of the string anymore! */
4945 while (str
[0] != '_' && str
[0] != '\0')
4947 if (str
[0] != 'n' && str
[0] != 'b')
4953 if (str
[0] == '\000')
4958 if (str
[1] != '_' || str
[2] == '\000')
4962 if (strcmp (str
+ 3, "JM") == 0)
4964 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4965 the LJM suffix in favor of the JM one. But we will
4966 still accept LJM as a valid suffix for a reasonable
4967 amount of time, just to allow ourselves to debug programs
4968 compiled using an older version of GNAT. */
4969 if (strcmp (str
+ 3, "LJM") == 0)
4973 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4974 || str
[4] == 'U' || str
[4] == 'P')
4976 if (str
[4] == 'R' && str
[5] != 'T')
4980 if (!isdigit (str
[2]))
4982 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4983 if (!isdigit (str
[k
]) && str
[k
] != '_')
4987 if (str
[0] == '$' && isdigit (str
[1]))
4989 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4990 if (!isdigit (str
[k
]) && str
[k
] != '_')
4997 /* Return non-zero if the string starting at NAME and ending before
4998 NAME_END contains no capital letters. */
5001 is_valid_name_for_wild_match (const char *name0
)
5003 const char *decoded_name
= ada_decode (name0
);
5006 /* If the decoded name starts with an angle bracket, it means that
5007 NAME0 does not follow the GNAT encoding format. It should then
5008 not be allowed as a possible wild match. */
5009 if (decoded_name
[0] == '<')
5012 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5013 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5019 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
5020 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
5021 informational suffixes of NAME (i.e., for which is_name_suffix is
5025 wild_match (const char *patn0
, int patn_len
, const char *name0
)
5032 match
= strstr (start
, patn0
);
5037 || (match
> name0
+ 1 && match
[-1] == '_' && match
[-2] == '_')
5038 || (match
== name0
+ 5 && strncmp ("_ada_", name0
, 5) == 0))
5039 && is_name_suffix (match
+ patn_len
))
5040 return (match
== name0
|| is_valid_name_for_wild_match (name0
));
5046 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5047 vector *defn_symbols, updating the list of symbols in OBSTACKP
5048 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5049 OBJFILE is the section containing BLOCK.
5050 SYMTAB is recorded with each symbol added. */
5053 ada_add_block_symbols (struct obstack
*obstackp
,
5054 struct block
*block
, const char *name
,
5055 domain_enum domain
, struct objfile
*objfile
,
5058 struct dict_iterator iter
;
5059 int name_len
= strlen (name
);
5060 /* A matching argument symbol, if any. */
5061 struct symbol
*arg_sym
;
5062 /* Set true when we find a matching non-argument symbol. */
5071 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5073 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5074 SYMBOL_DOMAIN (sym
), domain
)
5075 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
5077 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5079 else if (SYMBOL_IS_ARGUMENT (sym
))
5084 add_defn_to_vec (obstackp
,
5085 fixup_symbol_section (sym
, objfile
),
5093 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5095 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5096 SYMBOL_DOMAIN (sym
), domain
))
5098 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
5100 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5102 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5104 if (SYMBOL_IS_ARGUMENT (sym
))
5109 add_defn_to_vec (obstackp
,
5110 fixup_symbol_section (sym
, objfile
),
5119 if (!found_sym
&& arg_sym
!= NULL
)
5121 add_defn_to_vec (obstackp
,
5122 fixup_symbol_section (arg_sym
, objfile
),
5131 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5133 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5134 SYMBOL_DOMAIN (sym
), domain
))
5138 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5141 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5143 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5148 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5150 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5152 if (SYMBOL_IS_ARGUMENT (sym
))
5157 add_defn_to_vec (obstackp
,
5158 fixup_symbol_section (sym
, objfile
),
5166 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5167 They aren't parameters, right? */
5168 if (!found_sym
&& arg_sym
!= NULL
)
5170 add_defn_to_vec (obstackp
,
5171 fixup_symbol_section (arg_sym
, objfile
),
5178 /* Symbol Completion */
5180 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5181 name in a form that's appropriate for the completion. The result
5182 does not need to be deallocated, but is only good until the next call.
5184 TEXT_LEN is equal to the length of TEXT.
5185 Perform a wild match if WILD_MATCH is set.
5186 ENCODED should be set if TEXT represents the start of a symbol name
5187 in its encoded form. */
5190 symbol_completion_match (const char *sym_name
,
5191 const char *text
, int text_len
,
5192 int wild_match
, int encoded
)
5195 const int verbatim_match
= (text
[0] == '<');
5200 /* Strip the leading angle bracket. */
5205 /* First, test against the fully qualified name of the symbol. */
5207 if (strncmp (sym_name
, text
, text_len
) == 0)
5210 if (match
&& !encoded
)
5212 /* One needed check before declaring a positive match is to verify
5213 that iff we are doing a verbatim match, the decoded version
5214 of the symbol name starts with '<'. Otherwise, this symbol name
5215 is not a suitable completion. */
5216 const char *sym_name_copy
= sym_name
;
5217 int has_angle_bracket
;
5219 sym_name
= ada_decode (sym_name
);
5220 has_angle_bracket
= (sym_name
[0] == '<');
5221 match
= (has_angle_bracket
== verbatim_match
);
5222 sym_name
= sym_name_copy
;
5225 if (match
&& !verbatim_match
)
5227 /* When doing non-verbatim match, another check that needs to
5228 be done is to verify that the potentially matching symbol name
5229 does not include capital letters, because the ada-mode would
5230 not be able to understand these symbol names without the
5231 angle bracket notation. */
5234 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
5239 /* Second: Try wild matching... */
5241 if (!match
&& wild_match
)
5243 /* Since we are doing wild matching, this means that TEXT
5244 may represent an unqualified symbol name. We therefore must
5245 also compare TEXT against the unqualified name of the symbol. */
5246 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
5248 if (strncmp (sym_name
, text
, text_len
) == 0)
5252 /* Finally: If we found a mach, prepare the result to return. */
5258 sym_name
= add_angle_brackets (sym_name
);
5261 sym_name
= ada_decode (sym_name
);
5266 typedef char *char_ptr
;
5267 DEF_VEC_P (char_ptr
);
5269 /* A companion function to ada_make_symbol_completion_list().
5270 Check if SYM_NAME represents a symbol which name would be suitable
5271 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5272 it is appended at the end of the given string vector SV.
5274 ORIG_TEXT is the string original string from the user command
5275 that needs to be completed. WORD is the entire command on which
5276 completion should be performed. These two parameters are used to
5277 determine which part of the symbol name should be added to the
5279 if WILD_MATCH is set, then wild matching is performed.
5280 ENCODED should be set if TEXT represents a symbol name in its
5281 encoded formed (in which case the completion should also be
5285 symbol_completion_add (VEC(char_ptr
) **sv
,
5286 const char *sym_name
,
5287 const char *text
, int text_len
,
5288 const char *orig_text
, const char *word
,
5289 int wild_match
, int encoded
)
5291 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
5292 wild_match
, encoded
);
5298 /* We found a match, so add the appropriate completion to the given
5301 if (word
== orig_text
)
5303 completion
= xmalloc (strlen (match
) + 5);
5304 strcpy (completion
, match
);
5306 else if (word
> orig_text
)
5308 /* Return some portion of sym_name. */
5309 completion
= xmalloc (strlen (match
) + 5);
5310 strcpy (completion
, match
+ (word
- orig_text
));
5314 /* Return some of ORIG_TEXT plus sym_name. */
5315 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
5316 strncpy (completion
, word
, orig_text
- word
);
5317 completion
[orig_text
- word
] = '\0';
5318 strcat (completion
, match
);
5321 VEC_safe_push (char_ptr
, *sv
, completion
);
5324 /* Return a list of possible symbol names completing TEXT0. The list
5325 is NULL terminated. WORD is the entire command on which completion
5329 ada_make_symbol_completion_list (char *text0
, char *word
)
5335 VEC(char_ptr
) *completions
= VEC_alloc (char_ptr
, 128);
5338 struct partial_symtab
*ps
;
5339 struct minimal_symbol
*msymbol
;
5340 struct objfile
*objfile
;
5341 struct block
*b
, *surrounding_static_block
= 0;
5343 struct dict_iterator iter
;
5345 if (text0
[0] == '<')
5347 text
= xstrdup (text0
);
5348 make_cleanup (xfree
, text
);
5349 text_len
= strlen (text
);
5355 text
= xstrdup (ada_encode (text0
));
5356 make_cleanup (xfree
, text
);
5357 text_len
= strlen (text
);
5358 for (i
= 0; i
< text_len
; i
++)
5359 text
[i
] = tolower (text
[i
]);
5361 encoded
= (strstr (text0
, "__") != NULL
);
5362 /* If the name contains a ".", then the user is entering a fully
5363 qualified entity name, and the match must not be done in wild
5364 mode. Similarly, if the user wants to complete what looks like
5365 an encoded name, the match must not be done in wild mode. */
5366 wild_match
= (strchr (text0
, '.') == NULL
&& !encoded
);
5369 /* First, look at the partial symtab symbols. */
5370 ALL_PSYMTABS (objfile
, ps
)
5372 struct partial_symbol
**psym
;
5374 /* If the psymtab's been read in we'll get it when we search
5375 through the blockvector. */
5379 for (psym
= objfile
->global_psymbols
.list
+ ps
->globals_offset
;
5380 psym
< (objfile
->global_psymbols
.list
+ ps
->globals_offset
5381 + ps
->n_global_syms
); psym
++)
5384 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (*psym
),
5385 text
, text_len
, text0
, word
,
5386 wild_match
, encoded
);
5389 for (psym
= objfile
->static_psymbols
.list
+ ps
->statics_offset
;
5390 psym
< (objfile
->static_psymbols
.list
+ ps
->statics_offset
5391 + ps
->n_static_syms
); psym
++)
5394 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (*psym
),
5395 text
, text_len
, text0
, word
,
5396 wild_match
, encoded
);
5400 /* At this point scan through the misc symbol vectors and add each
5401 symbol you find to the list. Eventually we want to ignore
5402 anything that isn't a text symbol (everything else will be
5403 handled by the psymtab code above). */
5405 ALL_MSYMBOLS (objfile
, msymbol
)
5408 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (msymbol
),
5409 text
, text_len
, text0
, word
, wild_match
, encoded
);
5412 /* Search upwards from currently selected frame (so that we can
5413 complete on local vars. */
5415 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
5417 if (!BLOCK_SUPERBLOCK (b
))
5418 surrounding_static_block
= b
; /* For elmin of dups */
5420 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5422 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5423 text
, text_len
, text0
, word
,
5424 wild_match
, encoded
);
5428 /* Go through the symtabs and check the externs and statics for
5429 symbols which match. */
5431 ALL_SYMTABS (objfile
, s
)
5434 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
5435 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5437 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5438 text
, text_len
, text0
, word
,
5439 wild_match
, encoded
);
5443 ALL_SYMTABS (objfile
, s
)
5446 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
5447 /* Don't do this block twice. */
5448 if (b
== surrounding_static_block
)
5450 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5452 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5453 text
, text_len
, text0
, word
,
5454 wild_match
, encoded
);
5458 /* Append the closing NULL entry. */
5459 VEC_safe_push (char_ptr
, completions
, NULL
);
5461 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5462 return the copy. It's unfortunate that we have to make a copy
5463 of an array that we're about to destroy, but there is nothing much
5464 we can do about it. Fortunately, it's typically not a very large
5467 const size_t completions_size
=
5468 VEC_length (char_ptr
, completions
) * sizeof (char *);
5469 char **result
= malloc (completions_size
);
5471 memcpy (result
, VEC_address (char_ptr
, completions
), completions_size
);
5473 VEC_free (char_ptr
, completions
);
5480 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5481 for tagged types. */
5484 ada_is_dispatch_table_ptr_type (struct type
*type
)
5488 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
5491 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
5495 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
5498 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5499 to be invisible to users. */
5502 ada_is_ignored_field (struct type
*type
, int field_num
)
5504 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5507 /* Check the name of that field. */
5509 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5511 /* Anonymous field names should not be printed.
5512 brobecker/2007-02-20: I don't think this can actually happen
5513 but we don't want to print the value of annonymous fields anyway. */
5517 /* A field named "_parent" is internally generated by GNAT for
5518 tagged types, and should not be printed either. */
5519 if (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0)
5523 /* If this is the dispatch table of a tagged type, then ignore. */
5524 if (ada_is_tagged_type (type
, 1)
5525 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
)))
5528 /* Not a special field, so it should not be ignored. */
5532 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5533 pointer or reference type whose ultimate target has a tag field. */
5536 ada_is_tagged_type (struct type
*type
, int refok
)
5538 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
5541 /* True iff TYPE represents the type of X'Tag */
5544 ada_is_tag_type (struct type
*type
)
5546 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
5550 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
5551 return (name
!= NULL
5552 && strcmp (name
, "ada__tags__dispatch_table") == 0);
5556 /* The type of the tag on VAL. */
5559 ada_tag_type (struct value
*val
)
5561 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
5564 /* The value of the tag on VAL. */
5567 ada_value_tag (struct value
*val
)
5569 return ada_value_struct_elt (val
, "_tag", 0);
5572 /* The value of the tag on the object of type TYPE whose contents are
5573 saved at VALADDR, if it is non-null, or is at memory address
5576 static struct value
*
5577 value_tag_from_contents_and_address (struct type
*type
,
5578 const gdb_byte
*valaddr
,
5581 int tag_byte_offset
, dummy1
, dummy2
;
5582 struct type
*tag_type
;
5583 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5586 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
5588 : valaddr
+ tag_byte_offset
);
5589 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5591 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5596 static struct type
*
5597 type_from_tag (struct value
*tag
)
5599 const char *type_name
= ada_tag_name (tag
);
5600 if (type_name
!= NULL
)
5601 return ada_find_any_type (ada_encode (type_name
));
5612 static int ada_tag_name_1 (void *);
5613 static int ada_tag_name_2 (struct tag_args
*);
5615 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5616 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5617 The value stored in ARGS->name is valid until the next call to
5621 ada_tag_name_1 (void *args0
)
5623 struct tag_args
*args
= (struct tag_args
*) args0
;
5624 static char name
[1024];
5628 val
= ada_value_struct_elt (args
->tag
, "tsd", 1);
5630 return ada_tag_name_2 (args
);
5631 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5634 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5635 for (p
= name
; *p
!= '\0'; p
+= 1)
5642 /* Utility function for ada_tag_name_1 that tries the second
5643 representation for the dispatch table (in which there is no
5644 explicit 'tsd' field in the referent of the tag pointer, and instead
5645 the tsd pointer is stored just before the dispatch table. */
5648 ada_tag_name_2 (struct tag_args
*args
)
5650 struct type
*info_type
;
5651 static char name
[1024];
5653 struct value
*val
, *valp
;
5656 info_type
= ada_find_any_type ("ada__tags__type_specific_data");
5657 if (info_type
== NULL
)
5659 info_type
= lookup_pointer_type (lookup_pointer_type (info_type
));
5660 valp
= value_cast (info_type
, args
->tag
);
5663 val
= value_ind (value_ptradd (valp
,
5664 value_from_longest (builtin_type_int8
, -1)));
5667 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5670 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5671 for (p
= name
; *p
!= '\0'; p
+= 1)
5678 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5682 ada_tag_name (struct value
*tag
)
5684 struct tag_args args
;
5685 if (!ada_is_tag_type (value_type (tag
)))
5689 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5693 /* The parent type of TYPE, or NULL if none. */
5696 ada_parent_type (struct type
*type
)
5700 type
= ada_check_typedef (type
);
5702 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5705 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5706 if (ada_is_parent_field (type
, i
))
5708 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
5710 /* If the _parent field is a pointer, then dereference it. */
5711 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
5712 parent_type
= TYPE_TARGET_TYPE (parent_type
);
5713 /* If there is a parallel XVS type, get the actual base type. */
5714 parent_type
= ada_get_base_type (parent_type
);
5716 return ada_check_typedef (parent_type
);
5722 /* True iff field number FIELD_NUM of structure type TYPE contains the
5723 parent-type (inherited) fields of a derived type. Assumes TYPE is
5724 a structure type with at least FIELD_NUM+1 fields. */
5727 ada_is_parent_field (struct type
*type
, int field_num
)
5729 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5730 return (name
!= NULL
5731 && (strncmp (name
, "PARENT", 6) == 0
5732 || strncmp (name
, "_parent", 7) == 0));
5735 /* True iff field number FIELD_NUM of structure type TYPE is a
5736 transparent wrapper field (which should be silently traversed when doing
5737 field selection and flattened when printing). Assumes TYPE is a
5738 structure type with at least FIELD_NUM+1 fields. Such fields are always
5742 ada_is_wrapper_field (struct type
*type
, int field_num
)
5744 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5745 return (name
!= NULL
5746 && (strncmp (name
, "PARENT", 6) == 0
5747 || strcmp (name
, "REP") == 0
5748 || strncmp (name
, "_parent", 7) == 0
5749 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5752 /* True iff field number FIELD_NUM of structure or union type TYPE
5753 is a variant wrapper. Assumes TYPE is a structure type with at least
5754 FIELD_NUM+1 fields. */
5757 ada_is_variant_part (struct type
*type
, int field_num
)
5759 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5760 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5761 || (is_dynamic_field (type
, field_num
)
5762 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5763 == TYPE_CODE_UNION
)));
5766 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5767 whose discriminants are contained in the record type OUTER_TYPE,
5768 returns the type of the controlling discriminant for the variant. */
5771 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5773 char *name
= ada_variant_discrim_name (var_type
);
5775 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5777 return builtin_type_int32
;
5782 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5783 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5784 represents a 'when others' clause; otherwise 0. */
5787 ada_is_others_clause (struct type
*type
, int field_num
)
5789 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5790 return (name
!= NULL
&& name
[0] == 'O');
5793 /* Assuming that TYPE0 is the type of the variant part of a record,
5794 returns the name of the discriminant controlling the variant.
5795 The value is valid until the next call to ada_variant_discrim_name. */
5798 ada_variant_discrim_name (struct type
*type0
)
5800 static char *result
= NULL
;
5801 static size_t result_len
= 0;
5804 const char *discrim_end
;
5805 const char *discrim_start
;
5807 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5808 type
= TYPE_TARGET_TYPE (type0
);
5812 name
= ada_type_name (type
);
5814 if (name
== NULL
|| name
[0] == '\000')
5817 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5820 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5823 if (discrim_end
== name
)
5826 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5829 if (discrim_start
== name
+ 1)
5831 if ((discrim_start
> name
+ 3
5832 && strncmp (discrim_start
- 3, "___", 3) == 0)
5833 || discrim_start
[-1] == '.')
5837 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5838 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5839 result
[discrim_end
- discrim_start
] = '\0';
5843 /* Scan STR for a subtype-encoded number, beginning at position K.
5844 Put the position of the character just past the number scanned in
5845 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5846 Return 1 if there was a valid number at the given position, and 0
5847 otherwise. A "subtype-encoded" number consists of the absolute value
5848 in decimal, followed by the letter 'm' to indicate a negative number.
5849 Assumes 0m does not occur. */
5852 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5856 if (!isdigit (str
[k
]))
5859 /* Do it the hard way so as not to make any assumption about
5860 the relationship of unsigned long (%lu scan format code) and
5863 while (isdigit (str
[k
]))
5865 RU
= RU
* 10 + (str
[k
] - '0');
5872 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5878 /* NOTE on the above: Technically, C does not say what the results of
5879 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5880 number representable as a LONGEST (although either would probably work
5881 in most implementations). When RU>0, the locution in the then branch
5882 above is always equivalent to the negative of RU. */
5889 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5890 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5891 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5894 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5896 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5909 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5918 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5919 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5921 if (val
>= L
&& val
<= U
)
5933 /* FIXME: Lots of redundancy below. Try to consolidate. */
5935 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5936 ARG_TYPE, extract and return the value of one of its (non-static)
5937 fields. FIELDNO says which field. Differs from value_primitive_field
5938 only in that it can handle packed values of arbitrary type. */
5940 static struct value
*
5941 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5942 struct type
*arg_type
)
5946 arg_type
= ada_check_typedef (arg_type
);
5947 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5949 /* Handle packed fields. */
5951 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5953 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5954 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5956 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
5957 offset
+ bit_pos
/ 8,
5958 bit_pos
% 8, bit_size
, type
);
5961 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5964 /* Find field with name NAME in object of type TYPE. If found,
5965 set the following for each argument that is non-null:
5966 - *FIELD_TYPE_P to the field's type;
5967 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
5968 an object of that type;
5969 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
5970 - *BIT_SIZE_P to its size in bits if the field is packed, and
5972 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
5973 fields up to but not including the desired field, or by the total
5974 number of fields if not found. A NULL value of NAME never
5975 matches; the function just counts visible fields in this case.
5977 Returns 1 if found, 0 otherwise. */
5980 find_struct_field (char *name
, struct type
*type
, int offset
,
5981 struct type
**field_type_p
,
5982 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
5987 type
= ada_check_typedef (type
);
5989 if (field_type_p
!= NULL
)
5990 *field_type_p
= NULL
;
5991 if (byte_offset_p
!= NULL
)
5993 if (bit_offset_p
!= NULL
)
5995 if (bit_size_p
!= NULL
)
5998 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6000 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6001 int fld_offset
= offset
+ bit_pos
/ 8;
6002 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6004 if (t_field_name
== NULL
)
6007 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
6009 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6010 if (field_type_p
!= NULL
)
6011 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6012 if (byte_offset_p
!= NULL
)
6013 *byte_offset_p
= fld_offset
;
6014 if (bit_offset_p
!= NULL
)
6015 *bit_offset_p
= bit_pos
% 8;
6016 if (bit_size_p
!= NULL
)
6017 *bit_size_p
= bit_size
;
6020 else if (ada_is_wrapper_field (type
, i
))
6022 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6023 field_type_p
, byte_offset_p
, bit_offset_p
,
6024 bit_size_p
, index_p
))
6027 else if (ada_is_variant_part (type
, i
))
6029 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6032 struct type
*field_type
6033 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6035 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6037 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
6039 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6040 field_type_p
, byte_offset_p
,
6041 bit_offset_p
, bit_size_p
, index_p
))
6045 else if (index_p
!= NULL
)
6051 /* Number of user-visible fields in record type TYPE. */
6054 num_visible_fields (struct type
*type
)
6058 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
6062 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6063 and search in it assuming it has (class) type TYPE.
6064 If found, return value, else return NULL.
6066 Searches recursively through wrapper fields (e.g., '_parent'). */
6068 static struct value
*
6069 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
6073 type
= ada_check_typedef (type
);
6075 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6077 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6079 if (t_field_name
== NULL
)
6082 else if (field_name_match (t_field_name
, name
))
6083 return ada_value_primitive_field (arg
, offset
, i
, type
);
6085 else if (ada_is_wrapper_field (type
, i
))
6087 struct value
*v
= /* Do not let indent join lines here. */
6088 ada_search_struct_field (name
, arg
,
6089 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6090 TYPE_FIELD_TYPE (type
, i
));
6095 else if (ada_is_variant_part (type
, i
))
6097 /* PNH: Do we ever get here? See find_struct_field. */
6099 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6100 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6102 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6104 struct value
*v
= ada_search_struct_field
/* Force line break. */
6106 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6107 TYPE_FIELD_TYPE (field_type
, j
));
6116 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
6117 int, struct type
*);
6120 /* Return field #INDEX in ARG, where the index is that returned by
6121 * find_struct_field through its INDEX_P argument. Adjust the address
6122 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6123 * If found, return value, else return NULL. */
6125 static struct value
*
6126 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
6129 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
6133 /* Auxiliary function for ada_index_struct_field. Like
6134 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6137 static struct value
*
6138 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
6142 type
= ada_check_typedef (type
);
6144 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6146 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
6148 else if (ada_is_wrapper_field (type
, i
))
6150 struct value
*v
= /* Do not let indent join lines here. */
6151 ada_index_struct_field_1 (index_p
, arg
,
6152 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6153 TYPE_FIELD_TYPE (type
, i
));
6158 else if (ada_is_variant_part (type
, i
))
6160 /* PNH: Do we ever get here? See ada_search_struct_field,
6161 find_struct_field. */
6162 error (_("Cannot assign this kind of variant record"));
6164 else if (*index_p
== 0)
6165 return ada_value_primitive_field (arg
, offset
, i
, type
);
6172 /* Given ARG, a value of type (pointer or reference to a)*
6173 structure/union, extract the component named NAME from the ultimate
6174 target structure/union and return it as a value with its
6177 The routine searches for NAME among all members of the structure itself
6178 and (recursively) among all members of any wrapper members
6181 If NO_ERR, then simply return NULL in case of error, rather than
6185 ada_value_struct_elt (struct value
*arg
, char *name
, int no_err
)
6187 struct type
*t
, *t1
;
6191 t1
= t
= ada_check_typedef (value_type (arg
));
6192 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6194 t1
= TYPE_TARGET_TYPE (t
);
6197 t1
= ada_check_typedef (t1
);
6198 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6200 arg
= coerce_ref (arg
);
6205 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6207 t1
= TYPE_TARGET_TYPE (t
);
6210 t1
= ada_check_typedef (t1
);
6211 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6213 arg
= value_ind (arg
);
6220 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
6224 v
= ada_search_struct_field (name
, arg
, 0, t
);
6227 int bit_offset
, bit_size
, byte_offset
;
6228 struct type
*field_type
;
6231 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6232 address
= value_as_address (arg
);
6234 address
= unpack_pointer (t
, value_contents (arg
));
6236 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
, 1);
6237 if (find_struct_field (name
, t1
, 0,
6238 &field_type
, &byte_offset
, &bit_offset
,
6243 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6244 arg
= ada_coerce_ref (arg
);
6246 arg
= ada_value_ind (arg
);
6247 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
6248 bit_offset
, bit_size
,
6252 v
= value_at_lazy (field_type
, address
+ byte_offset
);
6256 if (v
!= NULL
|| no_err
)
6259 error (_("There is no member named %s."), name
);
6265 error (_("Attempt to extract a component of a value that is not a record."));
6268 /* Given a type TYPE, look up the type of the component of type named NAME.
6269 If DISPP is non-null, add its byte displacement from the beginning of a
6270 structure (pointed to by a value) of type TYPE to *DISPP (does not
6271 work for packed fields).
6273 Matches any field whose name has NAME as a prefix, possibly
6276 TYPE can be either a struct or union. If REFOK, TYPE may also
6277 be a (pointer or reference)+ to a struct or union, and the
6278 ultimate target type will be searched.
6280 Looks recursively into variant clauses and parent types.
6282 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6283 TYPE is not a type of the right kind. */
6285 static struct type
*
6286 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
6287 int noerr
, int *dispp
)
6294 if (refok
&& type
!= NULL
)
6297 type
= ada_check_typedef (type
);
6298 if (TYPE_CODE (type
) != TYPE_CODE_PTR
6299 && TYPE_CODE (type
) != TYPE_CODE_REF
)
6301 type
= TYPE_TARGET_TYPE (type
);
6305 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
6306 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
6312 target_terminal_ours ();
6313 gdb_flush (gdb_stdout
);
6315 error (_("Type (null) is not a structure or union type"));
6318 /* XXX: type_sprint */
6319 fprintf_unfiltered (gdb_stderr
, _("Type "));
6320 type_print (type
, "", gdb_stderr
, -1);
6321 error (_(" is not a structure or union type"));
6326 type
= to_static_fixed_type (type
);
6328 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6330 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6334 if (t_field_name
== NULL
)
6337 else if (field_name_match (t_field_name
, name
))
6340 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
6341 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6344 else if (ada_is_wrapper_field (type
, i
))
6347 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
6352 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6357 else if (ada_is_variant_part (type
, i
))
6360 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6362 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
6364 /* FIXME pnh 2008/01/26: We check for a field that is
6365 NOT wrapped in a struct, since the compiler sometimes
6366 generates these for unchecked variant types. Revisit
6367 if the compiler changes this practice. */
6368 char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
6370 if (v_field_name
!= NULL
6371 && field_name_match (v_field_name
, name
))
6372 t
= ada_check_typedef (TYPE_FIELD_TYPE (field_type
, j
));
6374 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
6380 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6391 target_terminal_ours ();
6392 gdb_flush (gdb_stdout
);
6395 /* XXX: type_sprint */
6396 fprintf_unfiltered (gdb_stderr
, _("Type "));
6397 type_print (type
, "", gdb_stderr
, -1);
6398 error (_(" has no component named <null>"));
6402 /* XXX: type_sprint */
6403 fprintf_unfiltered (gdb_stderr
, _("Type "));
6404 type_print (type
, "", gdb_stderr
, -1);
6405 error (_(" has no component named %s"), name
);
6412 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6413 within a value of type OUTER_TYPE, return true iff VAR_TYPE
6414 represents an unchecked union (that is, the variant part of a
6415 record that is named in an Unchecked_Union pragma). */
6418 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
6420 char *discrim_name
= ada_variant_discrim_name (var_type
);
6421 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1, NULL
)
6426 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6427 within a value of type OUTER_TYPE that is stored in GDB at
6428 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6429 numbering from 0) is applicable. Returns -1 if none are. */
6432 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
6433 const gdb_byte
*outer_valaddr
)
6437 char *discrim_name
= ada_variant_discrim_name (var_type
);
6438 struct value
*outer
;
6439 struct value
*discrim
;
6440 LONGEST discrim_val
;
6442 outer
= value_from_contents_and_address (outer_type
, outer_valaddr
, 0);
6443 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
6444 if (discrim
== NULL
)
6446 discrim_val
= value_as_long (discrim
);
6449 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
6451 if (ada_is_others_clause (var_type
, i
))
6453 else if (ada_in_variant (discrim_val
, var_type
, i
))
6457 return others_clause
;
6462 /* Dynamic-Sized Records */
6464 /* Strategy: The type ostensibly attached to a value with dynamic size
6465 (i.e., a size that is not statically recorded in the debugging
6466 data) does not accurately reflect the size or layout of the value.
6467 Our strategy is to convert these values to values with accurate,
6468 conventional types that are constructed on the fly. */
6470 /* There is a subtle and tricky problem here. In general, we cannot
6471 determine the size of dynamic records without its data. However,
6472 the 'struct value' data structure, which GDB uses to represent
6473 quantities in the inferior process (the target), requires the size
6474 of the type at the time of its allocation in order to reserve space
6475 for GDB's internal copy of the data. That's why the
6476 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6477 rather than struct value*s.
6479 However, GDB's internal history variables ($1, $2, etc.) are
6480 struct value*s containing internal copies of the data that are not, in
6481 general, the same as the data at their corresponding addresses in
6482 the target. Fortunately, the types we give to these values are all
6483 conventional, fixed-size types (as per the strategy described
6484 above), so that we don't usually have to perform the
6485 'to_fixed_xxx_type' conversions to look at their values.
6486 Unfortunately, there is one exception: if one of the internal
6487 history variables is an array whose elements are unconstrained
6488 records, then we will need to create distinct fixed types for each
6489 element selected. */
6491 /* The upshot of all of this is that many routines take a (type, host
6492 address, target address) triple as arguments to represent a value.
6493 The host address, if non-null, is supposed to contain an internal
6494 copy of the relevant data; otherwise, the program is to consult the
6495 target at the target address. */
6497 /* Assuming that VAL0 represents a pointer value, the result of
6498 dereferencing it. Differs from value_ind in its treatment of
6499 dynamic-sized types. */
6502 ada_value_ind (struct value
*val0
)
6504 struct value
*val
= unwrap_value (value_ind (val0
));
6505 return ada_to_fixed_value (val
);
6508 /* The value resulting from dereferencing any "reference to"
6509 qualifiers on VAL0. */
6511 static struct value
*
6512 ada_coerce_ref (struct value
*val0
)
6514 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
6516 struct value
*val
= val0
;
6517 val
= coerce_ref (val
);
6518 val
= unwrap_value (val
);
6519 return ada_to_fixed_value (val
);
6525 /* Return OFF rounded upward if necessary to a multiple of
6526 ALIGNMENT (a power of 2). */
6529 align_value (unsigned int off
, unsigned int alignment
)
6531 return (off
+ alignment
- 1) & ~(alignment
- 1);
6534 /* Return the bit alignment required for field #F of template type TYPE. */
6537 field_alignment (struct type
*type
, int f
)
6539 const char *name
= TYPE_FIELD_NAME (type
, f
);
6543 /* The field name should never be null, unless the debugging information
6544 is somehow malformed. In this case, we assume the field does not
6545 require any alignment. */
6549 len
= strlen (name
);
6551 if (!isdigit (name
[len
- 1]))
6554 if (isdigit (name
[len
- 2]))
6555 align_offset
= len
- 2;
6557 align_offset
= len
- 1;
6559 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
6560 return TARGET_CHAR_BIT
;
6562 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
6565 /* Find a symbol named NAME. Ignores ambiguity. */
6568 ada_find_any_symbol (const char *name
)
6572 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
6573 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
6576 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
6580 /* Find a type named NAME. Ignores ambiguity. */
6583 ada_find_any_type (const char *name
)
6585 struct symbol
*sym
= ada_find_any_symbol (name
);
6588 return SYMBOL_TYPE (sym
);
6593 /* Given NAME and an associated BLOCK, search all symbols for
6594 NAME suffixed with "___XR", which is the ``renaming'' symbol
6595 associated to NAME. Return this symbol if found, return
6599 ada_find_renaming_symbol (const char *name
, struct block
*block
)
6603 sym
= find_old_style_renaming_symbol (name
, block
);
6608 /* Not right yet. FIXME pnh 7/20/2007. */
6609 sym
= ada_find_any_symbol (name
);
6610 if (sym
!= NULL
&& strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR") != NULL
)
6616 static struct symbol
*
6617 find_old_style_renaming_symbol (const char *name
, struct block
*block
)
6619 const struct symbol
*function_sym
= block_linkage_function (block
);
6622 if (function_sym
!= NULL
)
6624 /* If the symbol is defined inside a function, NAME is not fully
6625 qualified. This means we need to prepend the function name
6626 as well as adding the ``___XR'' suffix to build the name of
6627 the associated renaming symbol. */
6628 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
6629 /* Function names sometimes contain suffixes used
6630 for instance to qualify nested subprograms. When building
6631 the XR type name, we need to make sure that this suffix is
6632 not included. So do not include any suffix in the function
6633 name length below. */
6634 const int function_name_len
= ada_name_prefix_len (function_name
);
6635 const int rename_len
= function_name_len
+ 2 /* "__" */
6636 + strlen (name
) + 6 /* "___XR\0" */ ;
6638 /* Strip the suffix if necessary. */
6639 function_name
[function_name_len
] = '\0';
6641 /* Library-level functions are a special case, as GNAT adds
6642 a ``_ada_'' prefix to the function name to avoid namespace
6643 pollution. However, the renaming symbols themselves do not
6644 have this prefix, so we need to skip this prefix if present. */
6645 if (function_name_len
> 5 /* "_ada_" */
6646 && strstr (function_name
, "_ada_") == function_name
)
6647 function_name
= function_name
+ 5;
6649 rename
= (char *) alloca (rename_len
* sizeof (char));
6650 sprintf (rename
, "%s__%s___XR", function_name
, name
);
6654 const int rename_len
= strlen (name
) + 6;
6655 rename
= (char *) alloca (rename_len
* sizeof (char));
6656 sprintf (rename
, "%s___XR", name
);
6659 return ada_find_any_symbol (rename
);
6662 /* Because of GNAT encoding conventions, several GDB symbols may match a
6663 given type name. If the type denoted by TYPE0 is to be preferred to
6664 that of TYPE1 for purposes of type printing, return non-zero;
6665 otherwise return 0. */
6668 ada_prefer_type (struct type
*type0
, struct type
*type1
)
6672 else if (type0
== NULL
)
6674 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
6676 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
6678 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
6680 else if (ada_is_packed_array_type (type0
))
6682 else if (ada_is_array_descriptor_type (type0
)
6683 && !ada_is_array_descriptor_type (type1
))
6687 const char *type0_name
= type_name_no_tag (type0
);
6688 const char *type1_name
= type_name_no_tag (type1
);
6690 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
6691 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
6697 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6698 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6701 ada_type_name (struct type
*type
)
6705 else if (TYPE_NAME (type
) != NULL
)
6706 return TYPE_NAME (type
);
6708 return TYPE_TAG_NAME (type
);
6711 /* Find a parallel type to TYPE whose name is formed by appending
6712 SUFFIX to the name of TYPE. */
6715 ada_find_parallel_type (struct type
*type
, const char *suffix
)
6718 static size_t name_len
= 0;
6720 char *typename
= ada_type_name (type
);
6722 if (typename
== NULL
)
6725 len
= strlen (typename
);
6727 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
6729 strcpy (name
, typename
);
6730 strcpy (name
+ len
, suffix
);
6732 return ada_find_any_type (name
);
6736 /* If TYPE is a variable-size record type, return the corresponding template
6737 type describing its fields. Otherwise, return NULL. */
6739 static struct type
*
6740 dynamic_template_type (struct type
*type
)
6742 type
= ada_check_typedef (type
);
6744 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
6745 || ada_type_name (type
) == NULL
)
6749 int len
= strlen (ada_type_name (type
));
6750 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
6753 return ada_find_parallel_type (type
, "___XVE");
6757 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6758 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6761 is_dynamic_field (struct type
*templ_type
, int field_num
)
6763 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
6765 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
6766 && strstr (name
, "___XVL") != NULL
;
6769 /* The index of the variant field of TYPE, or -1 if TYPE does not
6770 represent a variant record type. */
6773 variant_field_index (struct type
*type
)
6777 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6780 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6782 if (ada_is_variant_part (type
, f
))
6788 /* A record type with no fields. */
6790 static struct type
*
6791 empty_record (struct objfile
*objfile
)
6793 struct type
*type
= alloc_type (objfile
);
6794 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6795 TYPE_NFIELDS (type
) = 0;
6796 TYPE_FIELDS (type
) = NULL
;
6797 INIT_CPLUS_SPECIFIC (type
);
6798 TYPE_NAME (type
) = "<empty>";
6799 TYPE_TAG_NAME (type
) = NULL
;
6800 TYPE_LENGTH (type
) = 0;
6804 /* An ordinary record type (with fixed-length fields) that describes
6805 the value of type TYPE at VALADDR or ADDRESS (see comments at
6806 the beginning of this section) VAL according to GNAT conventions.
6807 DVAL0 should describe the (portion of a) record that contains any
6808 necessary discriminants. It should be NULL if value_type (VAL) is
6809 an outer-level type (i.e., as opposed to a branch of a variant.) A
6810 variant field (unless unchecked) is replaced by a particular branch
6813 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6814 length are not statically known are discarded. As a consequence,
6815 VALADDR, ADDRESS and DVAL0 are ignored.
6817 NOTE: Limitations: For now, we assume that dynamic fields and
6818 variants occupy whole numbers of bytes. However, they need not be
6822 ada_template_to_fixed_record_type_1 (struct type
*type
,
6823 const gdb_byte
*valaddr
,
6824 CORE_ADDR address
, struct value
*dval0
,
6825 int keep_dynamic_fields
)
6827 struct value
*mark
= value_mark ();
6830 int nfields
, bit_len
;
6833 int fld_bit_len
, bit_incr
;
6836 /* Compute the number of fields in this record type that are going
6837 to be processed: unless keep_dynamic_fields, this includes only
6838 fields whose position and length are static will be processed. */
6839 if (keep_dynamic_fields
)
6840 nfields
= TYPE_NFIELDS (type
);
6844 while (nfields
< TYPE_NFIELDS (type
)
6845 && !ada_is_variant_part (type
, nfields
)
6846 && !is_dynamic_field (type
, nfields
))
6850 rtype
= alloc_type (TYPE_OBJFILE (type
));
6851 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6852 INIT_CPLUS_SPECIFIC (rtype
);
6853 TYPE_NFIELDS (rtype
) = nfields
;
6854 TYPE_FIELDS (rtype
) = (struct field
*)
6855 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6856 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6857 TYPE_NAME (rtype
) = ada_type_name (type
);
6858 TYPE_TAG_NAME (rtype
) = NULL
;
6859 TYPE_FIXED_INSTANCE (rtype
) = 1;
6865 for (f
= 0; f
< nfields
; f
+= 1)
6867 off
= align_value (off
, field_alignment (type
, f
))
6868 + TYPE_FIELD_BITPOS (type
, f
);
6869 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6870 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6872 if (ada_is_variant_part (type
, f
))
6875 fld_bit_len
= bit_incr
= 0;
6877 else if (is_dynamic_field (type
, f
))
6881 /* rtype's length is computed based on the run-time
6882 value of discriminants. If the discriminants are not
6883 initialized, the type size may be completely bogus and
6884 GDB may fail to allocate a value for it. So check the
6885 size first before creating the value. */
6887 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6892 /* Get the fixed type of the field. Note that, in this case, we
6893 do not want to get the real type out of the tag: if the current
6894 field is the parent part of a tagged record, we will get the
6895 tag of the object. Clearly wrong: the real type of the parent
6896 is not the real type of the child. We would end up in an infinite
6898 TYPE_FIELD_TYPE (rtype
, f
) =
6901 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6902 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6903 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
, 0);
6904 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6905 bit_incr
= fld_bit_len
=
6906 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6910 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6911 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6912 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6913 bit_incr
= fld_bit_len
=
6914 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6916 bit_incr
= fld_bit_len
=
6917 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6919 if (off
+ fld_bit_len
> bit_len
)
6920 bit_len
= off
+ fld_bit_len
;
6922 TYPE_LENGTH (rtype
) =
6923 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6926 /* We handle the variant part, if any, at the end because of certain
6927 odd cases in which it is re-ordered so as NOT to be the last field of
6928 the record. This can happen in the presence of representation
6930 if (variant_field
>= 0)
6932 struct type
*branch_type
;
6934 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6937 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6942 to_fixed_variant_branch_type
6943 (TYPE_FIELD_TYPE (type
, variant_field
),
6944 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6945 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6946 if (branch_type
== NULL
)
6948 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6949 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6950 TYPE_NFIELDS (rtype
) -= 1;
6954 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6955 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6957 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6959 if (off
+ fld_bit_len
> bit_len
)
6960 bit_len
= off
+ fld_bit_len
;
6961 TYPE_LENGTH (rtype
) =
6962 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6966 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6967 should contain the alignment of that record, which should be a strictly
6968 positive value. If null or negative, then something is wrong, most
6969 probably in the debug info. In that case, we don't round up the size
6970 of the resulting type. If this record is not part of another structure,
6971 the current RTYPE length might be good enough for our purposes. */
6972 if (TYPE_LENGTH (type
) <= 0)
6974 if (TYPE_NAME (rtype
))
6975 warning (_("Invalid type size for `%s' detected: %d."),
6976 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
6978 warning (_("Invalid type size for <unnamed> detected: %d."),
6979 TYPE_LENGTH (type
));
6983 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
6984 TYPE_LENGTH (type
));
6987 value_free_to_mark (mark
);
6988 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6989 error (_("record type with dynamic size is larger than varsize-limit"));
6993 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6996 static struct type
*
6997 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
6998 CORE_ADDR address
, struct value
*dval0
)
7000 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
7004 /* An ordinary record type in which ___XVL-convention fields and
7005 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7006 static approximations, containing all possible fields. Uses
7007 no runtime values. Useless for use in values, but that's OK,
7008 since the results are used only for type determinations. Works on both
7009 structs and unions. Representation note: to save space, we memorize
7010 the result of this function in the TYPE_TARGET_TYPE of the
7013 static struct type
*
7014 template_to_static_fixed_type (struct type
*type0
)
7020 if (TYPE_TARGET_TYPE (type0
) != NULL
)
7021 return TYPE_TARGET_TYPE (type0
);
7023 nfields
= TYPE_NFIELDS (type0
);
7026 for (f
= 0; f
< nfields
; f
+= 1)
7028 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
7029 struct type
*new_type
;
7031 if (is_dynamic_field (type0
, f
))
7032 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
7034 new_type
= static_unwrap_type (field_type
);
7035 if (type
== type0
&& new_type
!= field_type
)
7037 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
7038 TYPE_CODE (type
) = TYPE_CODE (type0
);
7039 INIT_CPLUS_SPECIFIC (type
);
7040 TYPE_NFIELDS (type
) = nfields
;
7041 TYPE_FIELDS (type
) = (struct field
*)
7042 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
7043 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
7044 sizeof (struct field
) * nfields
);
7045 TYPE_NAME (type
) = ada_type_name (type0
);
7046 TYPE_TAG_NAME (type
) = NULL
;
7047 TYPE_FIXED_INSTANCE (type
) = 1;
7048 TYPE_LENGTH (type
) = 0;
7050 TYPE_FIELD_TYPE (type
, f
) = new_type
;
7051 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
7056 /* Given an object of type TYPE whose contents are at VALADDR and
7057 whose address in memory is ADDRESS, returns a revision of TYPE,
7058 which should be a non-dynamic-sized record, in which the variant
7059 part, if any, is replaced with the appropriate branch. Looks
7060 for discriminant values in DVAL0, which can be NULL if the record
7061 contains the necessary discriminant values. */
7063 static struct type
*
7064 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
7065 CORE_ADDR address
, struct value
*dval0
)
7067 struct value
*mark
= value_mark ();
7070 struct type
*branch_type
;
7071 int nfields
= TYPE_NFIELDS (type
);
7072 int variant_field
= variant_field_index (type
);
7074 if (variant_field
== -1)
7078 dval
= value_from_contents_and_address (type
, valaddr
, address
);
7082 rtype
= alloc_type (TYPE_OBJFILE (type
));
7083 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7084 INIT_CPLUS_SPECIFIC (rtype
);
7085 TYPE_NFIELDS (rtype
) = nfields
;
7086 TYPE_FIELDS (rtype
) =
7087 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7088 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
7089 sizeof (struct field
) * nfields
);
7090 TYPE_NAME (rtype
) = ada_type_name (type
);
7091 TYPE_TAG_NAME (rtype
) = NULL
;
7092 TYPE_FIXED_INSTANCE (rtype
) = 1;
7093 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
7095 branch_type
= to_fixed_variant_branch_type
7096 (TYPE_FIELD_TYPE (type
, variant_field
),
7097 cond_offset_host (valaddr
,
7098 TYPE_FIELD_BITPOS (type
, variant_field
)
7100 cond_offset_target (address
,
7101 TYPE_FIELD_BITPOS (type
, variant_field
)
7102 / TARGET_CHAR_BIT
), dval
);
7103 if (branch_type
== NULL
)
7106 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
7107 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7108 TYPE_NFIELDS (rtype
) -= 1;
7112 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7113 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7114 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
7115 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
7117 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
7119 value_free_to_mark (mark
);
7123 /* An ordinary record type (with fixed-length fields) that describes
7124 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7125 beginning of this section]. Any necessary discriminants' values
7126 should be in DVAL, a record value; it may be NULL if the object
7127 at ADDR itself contains any necessary discriminant values.
7128 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7129 values from the record are needed. Except in the case that DVAL,
7130 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7131 unchecked) is replaced by a particular branch of the variant.
7133 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7134 is questionable and may be removed. It can arise during the
7135 processing of an unconstrained-array-of-record type where all the
7136 variant branches have exactly the same size. This is because in
7137 such cases, the compiler does not bother to use the XVS convention
7138 when encoding the record. I am currently dubious of this
7139 shortcut and suspect the compiler should be altered. FIXME. */
7141 static struct type
*
7142 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
7143 CORE_ADDR address
, struct value
*dval
)
7145 struct type
*templ_type
;
7147 if (TYPE_FIXED_INSTANCE (type0
))
7150 templ_type
= dynamic_template_type (type0
);
7152 if (templ_type
!= NULL
)
7153 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
7154 else if (variant_field_index (type0
) >= 0)
7156 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
7158 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
7163 TYPE_FIXED_INSTANCE (type0
) = 1;
7169 /* An ordinary record type (with fixed-length fields) that describes
7170 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7171 union type. Any necessary discriminants' values should be in DVAL,
7172 a record value. That is, this routine selects the appropriate
7173 branch of the union at ADDR according to the discriminant value
7174 indicated in the union's type name. Returns VAR_TYPE0 itself if
7175 it represents a variant subject to a pragma Unchecked_Union. */
7177 static struct type
*
7178 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
7179 CORE_ADDR address
, struct value
*dval
)
7182 struct type
*templ_type
;
7183 struct type
*var_type
;
7185 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
7186 var_type
= TYPE_TARGET_TYPE (var_type0
);
7188 var_type
= var_type0
;
7190 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
7192 if (templ_type
!= NULL
)
7193 var_type
= templ_type
;
7195 if (is_unchecked_variant (var_type
, value_type (dval
)))
7198 ada_which_variant_applies (var_type
,
7199 value_type (dval
), value_contents (dval
));
7202 return empty_record (TYPE_OBJFILE (var_type
));
7203 else if (is_dynamic_field (var_type
, which
))
7204 return to_fixed_record_type
7205 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
7206 valaddr
, address
, dval
);
7207 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
7209 to_fixed_record_type
7210 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
7212 return TYPE_FIELD_TYPE (var_type
, which
);
7215 /* Assuming that TYPE0 is an array type describing the type of a value
7216 at ADDR, and that DVAL describes a record containing any
7217 discriminants used in TYPE0, returns a type for the value that
7218 contains no dynamic components (that is, no components whose sizes
7219 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7220 true, gives an error message if the resulting type's size is over
7223 static struct type
*
7224 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
7227 struct type
*index_type_desc
;
7228 struct type
*result
;
7230 if (ada_is_packed_array_type (type0
) /* revisit? */
7231 || TYPE_FIXED_INSTANCE (type0
))
7234 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
7235 if (index_type_desc
== NULL
)
7237 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
7238 /* NOTE: elt_type---the fixed version of elt_type0---should never
7239 depend on the contents of the array in properly constructed
7241 /* Create a fixed version of the array element type.
7242 We're not providing the address of an element here,
7243 and thus the actual object value cannot be inspected to do
7244 the conversion. This should not be a problem, since arrays of
7245 unconstrained objects are not allowed. In particular, all
7246 the elements of an array of a tagged type should all be of
7247 the same type specified in the debugging info. No need to
7248 consult the object tag. */
7249 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
7251 if (elt_type0
== elt_type
)
7254 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7255 elt_type
, TYPE_INDEX_TYPE (type0
));
7260 struct type
*elt_type0
;
7263 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
7264 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
7266 /* NOTE: result---the fixed version of elt_type0---should never
7267 depend on the contents of the array in properly constructed
7269 /* Create a fixed version of the array element type.
7270 We're not providing the address of an element here,
7271 and thus the actual object value cannot be inspected to do
7272 the conversion. This should not be a problem, since arrays of
7273 unconstrained objects are not allowed. In particular, all
7274 the elements of an array of a tagged type should all be of
7275 the same type specified in the debugging info. No need to
7276 consult the object tag. */
7278 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
7279 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
7281 struct type
*range_type
=
7282 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
7283 dval
, TYPE_OBJFILE (type0
));
7284 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7285 result
, range_type
);
7287 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
7288 error (_("array type with dynamic size is larger than varsize-limit"));
7291 TYPE_FIXED_INSTANCE (result
) = 1;
7296 /* A standard type (containing no dynamically sized components)
7297 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7298 DVAL describes a record containing any discriminants used in TYPE0,
7299 and may be NULL if there are none, or if the object of type TYPE at
7300 ADDRESS or in VALADDR contains these discriminants.
7302 If CHECK_TAG is not null, in the case of tagged types, this function
7303 attempts to locate the object's tag and use it to compute the actual
7304 type. However, when ADDRESS is null, we cannot use it to determine the
7305 location of the tag, and therefore compute the tagged type's actual type.
7306 So we return the tagged type without consulting the tag. */
7308 static struct type
*
7309 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
7310 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7312 type
= ada_check_typedef (type
);
7313 switch (TYPE_CODE (type
))
7317 case TYPE_CODE_STRUCT
:
7319 struct type
*static_type
= to_static_fixed_type (type
);
7320 struct type
*fixed_record_type
=
7321 to_fixed_record_type (type
, valaddr
, address
, NULL
);
7322 /* If STATIC_TYPE is a tagged type and we know the object's address,
7323 then we can determine its tag, and compute the object's actual
7324 type from there. Note that we have to use the fixed record
7325 type (the parent part of the record may have dynamic fields
7326 and the way the location of _tag is expressed may depend on
7329 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
7331 struct type
*real_type
=
7332 type_from_tag (value_tag_from_contents_and_address
7336 if (real_type
!= NULL
)
7337 return to_fixed_record_type (real_type
, valaddr
, address
, NULL
);
7340 /* Check to see if there is a parallel ___XVZ variable.
7341 If there is, then it provides the actual size of our type. */
7342 else if (ada_type_name (fixed_record_type
) != NULL
)
7344 char *name
= ada_type_name (fixed_record_type
);
7345 char *xvz_name
= alloca (strlen (name
) + 7 /* "___XVZ\0" */);
7349 sprintf (xvz_name
, "%s___XVZ", name
);
7350 size
= get_int_var_value (xvz_name
, &xvz_found
);
7351 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
7353 fixed_record_type
= copy_type (fixed_record_type
);
7354 TYPE_LENGTH (fixed_record_type
) = size
;
7356 /* The FIXED_RECORD_TYPE may have be a stub. We have
7357 observed this when the debugging info is STABS, and
7358 apparently it is something that is hard to fix.
7360 In practice, we don't need the actual type definition
7361 at all, because the presence of the XVZ variable allows us
7362 to assume that there must be a XVS type as well, which we
7363 should be able to use later, when we need the actual type
7366 In the meantime, pretend that the "fixed" type we are
7367 returning is NOT a stub, because this can cause trouble
7368 when using this type to create new types targeting it.
7369 Indeed, the associated creation routines often check
7370 whether the target type is a stub and will try to replace
7371 it, thus using a type with the wrong size. This, in turn,
7372 might cause the new type to have the wrong size too.
7373 Consider the case of an array, for instance, where the size
7374 of the array is computed from the number of elements in
7375 our array multiplied by the size of its element. */
7376 TYPE_STUB (fixed_record_type
) = 0;
7379 return fixed_record_type
;
7381 case TYPE_CODE_ARRAY
:
7382 return to_fixed_array_type (type
, dval
, 1);
7383 case TYPE_CODE_UNION
:
7387 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
7391 /* The same as ada_to_fixed_type_1, except that it preserves the type
7392 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7393 ada_to_fixed_type_1 would return the type referenced by TYPE. */
7396 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
7397 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7400 struct type
*fixed_type
=
7401 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
7403 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
7404 && TYPE_TARGET_TYPE (type
) == fixed_type
)
7410 /* A standard (static-sized) type corresponding as well as possible to
7411 TYPE0, but based on no runtime data. */
7413 static struct type
*
7414 to_static_fixed_type (struct type
*type0
)
7421 if (TYPE_FIXED_INSTANCE (type0
))
7424 type0
= ada_check_typedef (type0
);
7426 switch (TYPE_CODE (type0
))
7430 case TYPE_CODE_STRUCT
:
7431 type
= dynamic_template_type (type0
);
7433 return template_to_static_fixed_type (type
);
7435 return template_to_static_fixed_type (type0
);
7436 case TYPE_CODE_UNION
:
7437 type
= ada_find_parallel_type (type0
, "___XVU");
7439 return template_to_static_fixed_type (type
);
7441 return template_to_static_fixed_type (type0
);
7445 /* A static approximation of TYPE with all type wrappers removed. */
7447 static struct type
*
7448 static_unwrap_type (struct type
*type
)
7450 if (ada_is_aligner_type (type
))
7452 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
7453 if (ada_type_name (type1
) == NULL
)
7454 TYPE_NAME (type1
) = ada_type_name (type
);
7456 return static_unwrap_type (type1
);
7460 struct type
*raw_real_type
= ada_get_base_type (type
);
7461 if (raw_real_type
== type
)
7464 return to_static_fixed_type (raw_real_type
);
7468 /* In some cases, incomplete and private types require
7469 cross-references that are not resolved as records (for example,
7471 type FooP is access Foo;
7473 type Foo is array ...;
7474 ). In these cases, since there is no mechanism for producing
7475 cross-references to such types, we instead substitute for FooP a
7476 stub enumeration type that is nowhere resolved, and whose tag is
7477 the name of the actual type. Call these types "non-record stubs". */
7479 /* A type equivalent to TYPE that is not a non-record stub, if one
7480 exists, otherwise TYPE. */
7483 ada_check_typedef (struct type
*type
)
7488 CHECK_TYPEDEF (type
);
7489 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
7490 || !TYPE_STUB (type
)
7491 || TYPE_TAG_NAME (type
) == NULL
)
7495 char *name
= TYPE_TAG_NAME (type
);
7496 struct type
*type1
= ada_find_any_type (name
);
7497 return (type1
== NULL
) ? type
: type1
;
7501 /* A value representing the data at VALADDR/ADDRESS as described by
7502 type TYPE0, but with a standard (static-sized) type that correctly
7503 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7504 type, then return VAL0 [this feature is simply to avoid redundant
7505 creation of struct values]. */
7507 static struct value
*
7508 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
7511 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
7512 if (type
== type0
&& val0
!= NULL
)
7515 return value_from_contents_and_address (type
, 0, address
);
7518 /* A value representing VAL, but with a standard (static-sized) type
7519 that correctly describes it. Does not necessarily create a new
7522 static struct value
*
7523 ada_to_fixed_value (struct value
*val
)
7525 return ada_to_fixed_value_create (value_type (val
),
7526 VALUE_ADDRESS (val
) + value_offset (val
),
7530 /* A value representing VAL, but with a standard (static-sized) type
7531 chosen to approximate the real type of VAL as well as possible, but
7532 without consulting any runtime values. For Ada dynamic-sized
7533 types, therefore, the type of the result is likely to be inaccurate. */
7536 ada_to_static_fixed_value (struct value
*val
)
7539 to_static_fixed_type (static_unwrap_type (value_type (val
)));
7540 if (type
== value_type (val
))
7543 return coerce_unspec_val_to_type (val
, type
);
7549 /* Table mapping attribute numbers to names.
7550 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7552 static const char *attribute_names
[] = {
7570 ada_attribute_name (enum exp_opcode n
)
7572 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
7573 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
7575 return attribute_names
[0];
7578 /* Evaluate the 'POS attribute applied to ARG. */
7581 pos_atr (struct value
*arg
)
7583 struct value
*val
= coerce_ref (arg
);
7584 struct type
*type
= value_type (val
);
7586 if (!discrete_type_p (type
))
7587 error (_("'POS only defined on discrete types"));
7589 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7592 LONGEST v
= value_as_long (val
);
7594 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7596 if (v
== TYPE_FIELD_BITPOS (type
, i
))
7599 error (_("enumeration value is invalid: can't find 'POS"));
7602 return value_as_long (val
);
7605 static struct value
*
7606 value_pos_atr (struct type
*type
, struct value
*arg
)
7608 return value_from_longest (type
, pos_atr (arg
));
7611 /* Evaluate the TYPE'VAL attribute applied to ARG. */
7613 static struct value
*
7614 value_val_atr (struct type
*type
, struct value
*arg
)
7616 if (!discrete_type_p (type
))
7617 error (_("'VAL only defined on discrete types"));
7618 if (!integer_type_p (value_type (arg
)))
7619 error (_("'VAL requires integral argument"));
7621 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7623 long pos
= value_as_long (arg
);
7624 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
7625 error (_("argument to 'VAL out of range"));
7626 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
7629 return value_from_longest (type
, value_as_long (arg
));
7635 /* True if TYPE appears to be an Ada character type.
7636 [At the moment, this is true only for Character and Wide_Character;
7637 It is a heuristic test that could stand improvement]. */
7640 ada_is_character_type (struct type
*type
)
7644 /* If the type code says it's a character, then assume it really is,
7645 and don't check any further. */
7646 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
7649 /* Otherwise, assume it's a character type iff it is a discrete type
7650 with a known character type name. */
7651 name
= ada_type_name (type
);
7652 return (name
!= NULL
7653 && (TYPE_CODE (type
) == TYPE_CODE_INT
7654 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7655 && (strcmp (name
, "character") == 0
7656 || strcmp (name
, "wide_character") == 0
7657 || strcmp (name
, "wide_wide_character") == 0
7658 || strcmp (name
, "unsigned char") == 0));
7661 /* True if TYPE appears to be an Ada string type. */
7664 ada_is_string_type (struct type
*type
)
7666 type
= ada_check_typedef (type
);
7668 && TYPE_CODE (type
) != TYPE_CODE_PTR
7669 && (ada_is_simple_array_type (type
)
7670 || ada_is_array_descriptor_type (type
))
7671 && ada_array_arity (type
) == 1)
7673 struct type
*elttype
= ada_array_element_type (type
, 1);
7675 return ada_is_character_type (elttype
);
7682 /* True if TYPE is a struct type introduced by the compiler to force the
7683 alignment of a value. Such types have a single field with a
7684 distinctive name. */
7687 ada_is_aligner_type (struct type
*type
)
7689 type
= ada_check_typedef (type
);
7691 /* If we can find a parallel XVS type, then the XVS type should
7692 be used instead of this type. And hence, this is not an aligner
7694 if (ada_find_parallel_type (type
, "___XVS") != NULL
)
7697 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
7698 && TYPE_NFIELDS (type
) == 1
7699 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
7702 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7703 the parallel type. */
7706 ada_get_base_type (struct type
*raw_type
)
7708 struct type
*real_type_namer
;
7709 struct type
*raw_real_type
;
7711 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
7714 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
7715 if (real_type_namer
== NULL
7716 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
7717 || TYPE_NFIELDS (real_type_namer
) != 1)
7720 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
7721 if (raw_real_type
== NULL
)
7724 return raw_real_type
;
7727 /* The type of value designated by TYPE, with all aligners removed. */
7730 ada_aligned_type (struct type
*type
)
7732 if (ada_is_aligner_type (type
))
7733 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
7735 return ada_get_base_type (type
);
7739 /* The address of the aligned value in an object at address VALADDR
7740 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7743 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
7745 if (ada_is_aligner_type (type
))
7746 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
7748 TYPE_FIELD_BITPOS (type
,
7749 0) / TARGET_CHAR_BIT
);
7756 /* The printed representation of an enumeration literal with encoded
7757 name NAME. The value is good to the next call of ada_enum_name. */
7759 ada_enum_name (const char *name
)
7761 static char *result
;
7762 static size_t result_len
= 0;
7765 /* First, unqualify the enumeration name:
7766 1. Search for the last '.' character. If we find one, then skip
7767 all the preceeding characters, the unqualified name starts
7768 right after that dot.
7769 2. Otherwise, we may be debugging on a target where the compiler
7770 translates dots into "__". Search forward for double underscores,
7771 but stop searching when we hit an overloading suffix, which is
7772 of the form "__" followed by digits. */
7774 tmp
= strrchr (name
, '.');
7779 while ((tmp
= strstr (name
, "__")) != NULL
)
7781 if (isdigit (tmp
[2]))
7791 if (name
[1] == 'U' || name
[1] == 'W')
7793 if (sscanf (name
+ 2, "%x", &v
) != 1)
7799 GROW_VECT (result
, result_len
, 16);
7800 if (isascii (v
) && isprint (v
))
7801 sprintf (result
, "'%c'", v
);
7802 else if (name
[1] == 'U')
7803 sprintf (result
, "[\"%02x\"]", v
);
7805 sprintf (result
, "[\"%04x\"]", v
);
7811 tmp
= strstr (name
, "__");
7813 tmp
= strstr (name
, "$");
7816 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
7817 strncpy (result
, name
, tmp
- name
);
7818 result
[tmp
- name
] = '\0';
7826 static struct value
*
7827 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
7830 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7831 (expect_type
, exp
, pos
, noside
);
7834 /* Evaluate the subexpression of EXP starting at *POS as for
7835 evaluate_type, updating *POS to point just past the evaluated
7838 static struct value
*
7839 evaluate_subexp_type (struct expression
*exp
, int *pos
)
7841 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7842 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
7845 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7848 static struct value
*
7849 unwrap_value (struct value
*val
)
7851 struct type
*type
= ada_check_typedef (value_type (val
));
7852 if (ada_is_aligner_type (type
))
7854 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
7855 struct type
*val_type
= ada_check_typedef (value_type (v
));
7856 if (ada_type_name (val_type
) == NULL
)
7857 TYPE_NAME (val_type
) = ada_type_name (type
);
7859 return unwrap_value (v
);
7863 struct type
*raw_real_type
=
7864 ada_check_typedef (ada_get_base_type (type
));
7866 if (type
== raw_real_type
)
7870 coerce_unspec_val_to_type
7871 (val
, ada_to_fixed_type (raw_real_type
, 0,
7872 VALUE_ADDRESS (val
) + value_offset (val
),
7877 static struct value
*
7878 cast_to_fixed (struct type
*type
, struct value
*arg
)
7882 if (type
== value_type (arg
))
7884 else if (ada_is_fixed_point_type (value_type (arg
)))
7885 val
= ada_float_to_fixed (type
,
7886 ada_fixed_to_float (value_type (arg
),
7887 value_as_long (arg
)));
7890 DOUBLEST argd
= value_as_double (arg
);
7891 val
= ada_float_to_fixed (type
, argd
);
7894 return value_from_longest (type
, val
);
7897 static struct value
*
7898 cast_from_fixed (struct type
*type
, struct value
*arg
)
7900 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
7901 value_as_long (arg
));
7902 return value_from_double (type
, val
);
7905 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7906 return the converted value. */
7908 static struct value
*
7909 coerce_for_assign (struct type
*type
, struct value
*val
)
7911 struct type
*type2
= value_type (val
);
7915 type2
= ada_check_typedef (type2
);
7916 type
= ada_check_typedef (type
);
7918 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
7919 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7921 val
= ada_value_ind (val
);
7922 type2
= value_type (val
);
7925 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
7926 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7928 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
7929 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
7930 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
7931 error (_("Incompatible types in assignment"));
7932 deprecated_set_value_type (val
, type
);
7937 static struct value
*
7938 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
7941 struct type
*type1
, *type2
;
7944 arg1
= coerce_ref (arg1
);
7945 arg2
= coerce_ref (arg2
);
7946 type1
= base_type (ada_check_typedef (value_type (arg1
)));
7947 type2
= base_type (ada_check_typedef (value_type (arg2
)));
7949 if (TYPE_CODE (type1
) != TYPE_CODE_INT
7950 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
7951 return value_binop (arg1
, arg2
, op
);
7960 return value_binop (arg1
, arg2
, op
);
7963 v2
= value_as_long (arg2
);
7965 error (_("second operand of %s must not be zero."), op_string (op
));
7967 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7968 return value_binop (arg1
, arg2
, op
);
7970 v1
= value_as_long (arg1
);
7975 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7976 v
+= v
> 0 ? -1 : 1;
7984 /* Should not reach this point. */
7988 val
= allocate_value (type1
);
7989 store_unsigned_integer (value_contents_raw (val
),
7990 TYPE_LENGTH (value_type (val
)), v
);
7995 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7997 if (ada_is_direct_array_type (value_type (arg1
))
7998 || ada_is_direct_array_type (value_type (arg2
)))
8000 /* Automatically dereference any array reference before
8001 we attempt to perform the comparison. */
8002 arg1
= ada_coerce_ref (arg1
);
8003 arg2
= ada_coerce_ref (arg2
);
8005 arg1
= ada_coerce_to_simple_array (arg1
);
8006 arg2
= ada_coerce_to_simple_array (arg2
);
8007 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
8008 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
8009 error (_("Attempt to compare array with non-array"));
8010 /* FIXME: The following works only for types whose
8011 representations use all bits (no padding or undefined bits)
8012 and do not have user-defined equality. */
8014 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
8015 && memcmp (value_contents (arg1
), value_contents (arg2
),
8016 TYPE_LENGTH (value_type (arg1
))) == 0;
8018 return value_equal (arg1
, arg2
);
8021 /* Total number of component associations in the aggregate starting at
8022 index PC in EXP. Assumes that index PC is the start of an
8026 num_component_specs (struct expression
*exp
, int pc
)
8029 m
= exp
->elts
[pc
+ 1].longconst
;
8032 for (i
= 0; i
< m
; i
+= 1)
8034 switch (exp
->elts
[pc
].opcode
)
8040 n
+= exp
->elts
[pc
+ 1].longconst
;
8043 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
8048 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
8049 component of LHS (a simple array or a record), updating *POS past
8050 the expression, assuming that LHS is contained in CONTAINER. Does
8051 not modify the inferior's memory, nor does it modify LHS (unless
8052 LHS == CONTAINER). */
8055 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
8056 struct expression
*exp
, int *pos
)
8058 struct value
*mark
= value_mark ();
8060 if (TYPE_CODE (value_type (lhs
)) == TYPE_CODE_ARRAY
)
8062 struct value
*index_val
= value_from_longest (builtin_type_int32
, index
);
8063 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
8067 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
8068 elt
= ada_to_fixed_value (unwrap_value (elt
));
8071 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8072 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
8074 value_assign_to_component (container
, elt
,
8075 ada_evaluate_subexp (NULL
, exp
, pos
,
8078 value_free_to_mark (mark
);
8081 /* Assuming that LHS represents an lvalue having a record or array
8082 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8083 of that aggregate's value to LHS, advancing *POS past the
8084 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8085 lvalue containing LHS (possibly LHS itself). Does not modify
8086 the inferior's memory, nor does it modify the contents of
8087 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
8089 static struct value
*
8090 assign_aggregate (struct value
*container
,
8091 struct value
*lhs
, struct expression
*exp
,
8092 int *pos
, enum noside noside
)
8094 struct type
*lhs_type
;
8095 int n
= exp
->elts
[*pos
+1].longconst
;
8096 LONGEST low_index
, high_index
;
8099 int max_indices
, num_indices
;
8100 int is_array_aggregate
;
8102 struct value
*mark
= value_mark ();
8105 if (noside
!= EVAL_NORMAL
)
8108 for (i
= 0; i
< n
; i
+= 1)
8109 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
8113 container
= ada_coerce_ref (container
);
8114 if (ada_is_direct_array_type (value_type (container
)))
8115 container
= ada_coerce_to_simple_array (container
);
8116 lhs
= ada_coerce_ref (lhs
);
8117 if (!deprecated_value_modifiable (lhs
))
8118 error (_("Left operand of assignment is not a modifiable lvalue."));
8120 lhs_type
= value_type (lhs
);
8121 if (ada_is_direct_array_type (lhs_type
))
8123 lhs
= ada_coerce_to_simple_array (lhs
);
8124 lhs_type
= value_type (lhs
);
8125 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
8126 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
8127 is_array_aggregate
= 1;
8129 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
8132 high_index
= num_visible_fields (lhs_type
) - 1;
8133 is_array_aggregate
= 0;
8136 error (_("Left-hand side must be array or record."));
8138 num_specs
= num_component_specs (exp
, *pos
- 3);
8139 max_indices
= 4 * num_specs
+ 4;
8140 indices
= alloca (max_indices
* sizeof (indices
[0]));
8141 indices
[0] = indices
[1] = low_index
- 1;
8142 indices
[2] = indices
[3] = high_index
+ 1;
8145 for (i
= 0; i
< n
; i
+= 1)
8147 switch (exp
->elts
[*pos
].opcode
)
8150 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
8151 &num_indices
, max_indices
,
8152 low_index
, high_index
);
8155 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
8156 &num_indices
, max_indices
,
8157 low_index
, high_index
);
8161 error (_("Misplaced 'others' clause"));
8162 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
8163 num_indices
, low_index
, high_index
);
8166 error (_("Internal error: bad aggregate clause"));
8173 /* Assign into the component of LHS indexed by the OP_POSITIONAL
8174 construct at *POS, updating *POS past the construct, given that
8175 the positions are relative to lower bound LOW, where HIGH is the
8176 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8177 updating *NUM_INDICES as needed. CONTAINER is as for
8178 assign_aggregate. */
8180 aggregate_assign_positional (struct value
*container
,
8181 struct value
*lhs
, struct expression
*exp
,
8182 int *pos
, LONGEST
*indices
, int *num_indices
,
8183 int max_indices
, LONGEST low
, LONGEST high
)
8185 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
8187 if (ind
- 1 == high
)
8188 warning (_("Extra components in aggregate ignored."));
8191 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
8193 assign_component (container
, lhs
, ind
, exp
, pos
);
8196 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8199 /* Assign into the components of LHS indexed by the OP_CHOICES
8200 construct at *POS, updating *POS past the construct, given that
8201 the allowable indices are LOW..HIGH. Record the indices assigned
8202 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8203 needed. CONTAINER is as for assign_aggregate. */
8205 aggregate_assign_from_choices (struct value
*container
,
8206 struct value
*lhs
, struct expression
*exp
,
8207 int *pos
, LONGEST
*indices
, int *num_indices
,
8208 int max_indices
, LONGEST low
, LONGEST high
)
8211 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
8212 int choice_pos
, expr_pc
;
8213 int is_array
= ada_is_direct_array_type (value_type (lhs
));
8215 choice_pos
= *pos
+= 3;
8217 for (j
= 0; j
< n_choices
; j
+= 1)
8218 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8220 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8222 for (j
= 0; j
< n_choices
; j
+= 1)
8224 LONGEST lower
, upper
;
8225 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
8226 if (op
== OP_DISCRETE_RANGE
)
8229 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8231 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8236 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
8247 name
= &exp
->elts
[choice_pos
+ 2].string
;
8250 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
8253 error (_("Invalid record component association."));
8255 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
8257 if (! find_struct_field (name
, value_type (lhs
), 0,
8258 NULL
, NULL
, NULL
, NULL
, &ind
))
8259 error (_("Unknown component name: %s."), name
);
8260 lower
= upper
= ind
;
8263 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
8264 error (_("Index in component association out of bounds."));
8266 add_component_interval (lower
, upper
, indices
, num_indices
,
8268 while (lower
<= upper
)
8272 assign_component (container
, lhs
, lower
, exp
, &pos1
);
8278 /* Assign the value of the expression in the OP_OTHERS construct in
8279 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8280 have not been previously assigned. The index intervals already assigned
8281 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8282 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
8284 aggregate_assign_others (struct value
*container
,
8285 struct value
*lhs
, struct expression
*exp
,
8286 int *pos
, LONGEST
*indices
, int num_indices
,
8287 LONGEST low
, LONGEST high
)
8290 int expr_pc
= *pos
+1;
8292 for (i
= 0; i
< num_indices
- 2; i
+= 2)
8295 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
8299 assign_component (container
, lhs
, ind
, exp
, &pos
);
8302 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8305 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
8306 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8307 modifying *SIZE as needed. It is an error if *SIZE exceeds
8308 MAX_SIZE. The resulting intervals do not overlap. */
8310 add_component_interval (LONGEST low
, LONGEST high
,
8311 LONGEST
* indices
, int *size
, int max_size
)
8314 for (i
= 0; i
< *size
; i
+= 2) {
8315 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
8318 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
8319 if (high
< indices
[kh
])
8321 if (low
< indices
[i
])
8323 indices
[i
+ 1] = indices
[kh
- 1];
8324 if (high
> indices
[i
+ 1])
8325 indices
[i
+ 1] = high
;
8326 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
8327 *size
-= kh
- i
- 2;
8330 else if (high
< indices
[i
])
8334 if (*size
== max_size
)
8335 error (_("Internal error: miscounted aggregate components."));
8337 for (j
= *size
-1; j
>= i
+2; j
-= 1)
8338 indices
[j
] = indices
[j
- 2];
8340 indices
[i
+ 1] = high
;
8343 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8346 static struct value
*
8347 ada_value_cast (struct type
*type
, struct value
*arg2
, enum noside noside
)
8349 if (type
== ada_check_typedef (value_type (arg2
)))
8352 if (ada_is_fixed_point_type (type
))
8353 return (cast_to_fixed (type
, arg2
));
8355 if (ada_is_fixed_point_type (value_type (arg2
)))
8356 return cast_from_fixed (type
, arg2
);
8358 return value_cast (type
, arg2
);
8361 static struct value
*
8362 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
8363 int *pos
, enum noside noside
)
8366 int tem
, tem2
, tem3
;
8368 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
8371 struct value
**argvec
;
8375 op
= exp
->elts
[pc
].opcode
;
8381 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8382 arg1
= unwrap_value (arg1
);
8384 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8385 then we need to perform the conversion manually, because
8386 evaluate_subexp_standard doesn't do it. This conversion is
8387 necessary in Ada because the different kinds of float/fixed
8388 types in Ada have different representations.
8390 Similarly, we need to perform the conversion from OP_LONG
8392 if ((op
== OP_DOUBLE
|| op
== OP_LONG
) && expect_type
!= NULL
)
8393 arg1
= ada_value_cast (expect_type
, arg1
, noside
);
8399 struct value
*result
;
8401 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8402 /* The result type will have code OP_STRING, bashed there from
8403 OP_ARRAY. Bash it back. */
8404 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
8405 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
8411 type
= exp
->elts
[pc
+ 1].type
;
8412 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
8413 if (noside
== EVAL_SKIP
)
8415 arg1
= ada_value_cast (type
, arg1
, noside
);
8420 type
= exp
->elts
[pc
+ 1].type
;
8421 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
8424 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8425 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8427 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
8428 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8430 return ada_value_assign (arg1
, arg1
);
8432 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8433 except if the lhs of our assignment is a convenience variable.
8434 In the case of assigning to a convenience variable, the lhs
8435 should be exactly the result of the evaluation of the rhs. */
8436 type
= value_type (arg1
);
8437 if (VALUE_LVAL (arg1
) == lval_internalvar
)
8439 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
8440 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8442 if (ada_is_fixed_point_type (value_type (arg1
)))
8443 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
8444 else if (ada_is_fixed_point_type (value_type (arg2
)))
8446 (_("Fixed-point values must be assigned to fixed-point variables"));
8448 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
8449 return ada_value_assign (arg1
, arg2
);
8452 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8453 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8454 if (noside
== EVAL_SKIP
)
8456 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8457 return (value_from_longest
8459 value_as_long (arg1
) + value_as_long (arg2
)));
8460 if ((ada_is_fixed_point_type (value_type (arg1
))
8461 || ada_is_fixed_point_type (value_type (arg2
)))
8462 && value_type (arg1
) != value_type (arg2
))
8463 error (_("Operands of fixed-point addition must have the same type"));
8464 /* Do the addition, and cast the result to the type of the first
8465 argument. We cannot cast the result to a reference type, so if
8466 ARG1 is a reference type, find its underlying type. */
8467 type
= value_type (arg1
);
8468 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8469 type
= TYPE_TARGET_TYPE (type
);
8470 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8471 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
8474 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8475 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8476 if (noside
== EVAL_SKIP
)
8478 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8479 return (value_from_longest
8481 value_as_long (arg1
) - value_as_long (arg2
)));
8482 if ((ada_is_fixed_point_type (value_type (arg1
))
8483 || ada_is_fixed_point_type (value_type (arg2
)))
8484 && value_type (arg1
) != value_type (arg2
))
8485 error (_("Operands of fixed-point subtraction must have the same type"));
8486 /* Do the substraction, and cast the result to the type of the first
8487 argument. We cannot cast the result to a reference type, so if
8488 ARG1 is a reference type, find its underlying type. */
8489 type
= value_type (arg1
);
8490 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8491 type
= TYPE_TARGET_TYPE (type
);
8492 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8493 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
8497 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8498 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8499 if (noside
== EVAL_SKIP
)
8501 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8502 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8503 return value_zero (value_type (arg1
), not_lval
);
8506 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
8507 if (ada_is_fixed_point_type (value_type (arg1
)))
8508 arg1
= cast_from_fixed (type
, arg1
);
8509 if (ada_is_fixed_point_type (value_type (arg2
)))
8510 arg2
= cast_from_fixed (type
, arg2
);
8511 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8512 return ada_value_binop (arg1
, arg2
, op
);
8517 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8518 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8519 if (noside
== EVAL_SKIP
)
8521 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8522 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8523 return value_zero (value_type (arg1
), not_lval
);
8526 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8527 return ada_value_binop (arg1
, arg2
, op
);
8531 case BINOP_NOTEQUAL
:
8532 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8533 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
8534 if (noside
== EVAL_SKIP
)
8536 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8540 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8541 tem
= ada_value_equal (arg1
, arg2
);
8543 if (op
== BINOP_NOTEQUAL
)
8545 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8546 return value_from_longest (type
, (LONGEST
) tem
);
8549 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8550 if (noside
== EVAL_SKIP
)
8552 else if (ada_is_fixed_point_type (value_type (arg1
)))
8553 return value_cast (value_type (arg1
), value_neg (arg1
));
8556 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
8557 return value_neg (arg1
);
8560 case BINOP_LOGICAL_AND
:
8561 case BINOP_LOGICAL_OR
:
8562 case UNOP_LOGICAL_NOT
:
8567 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8568 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8569 return value_cast (type
, val
);
8572 case BINOP_BITWISE_AND
:
8573 case BINOP_BITWISE_IOR
:
8574 case BINOP_BITWISE_XOR
:
8578 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8580 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8582 return value_cast (value_type (arg1
), val
);
8588 if (noside
== EVAL_SKIP
)
8593 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
8594 /* Only encountered when an unresolved symbol occurs in a
8595 context other than a function call, in which case, it is
8597 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8598 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
8599 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8601 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
8602 if (ada_is_tagged_type (type
, 0))
8604 /* Tagged types are a little special in the fact that the real
8605 type is dynamic and can only be determined by inspecting the
8606 object's tag. This means that we need to get the object's
8607 value first (EVAL_NORMAL) and then extract the actual object
8610 Note that we cannot skip the final step where we extract
8611 the object type from its tag, because the EVAL_NORMAL phase
8612 results in dynamic components being resolved into fixed ones.
8613 This can cause problems when trying to print the type
8614 description of tagged types whose parent has a dynamic size:
8615 We use the type name of the "_parent" component in order
8616 to print the name of the ancestor type in the type description.
8617 If that component had a dynamic size, the resolution into
8618 a fixed type would result in the loss of that type name,
8619 thus preventing us from printing the name of the ancestor
8620 type in the type description. */
8621 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
8622 return value_zero (type_from_tag (ada_value_tag (arg1
)), not_lval
);
8627 (to_static_fixed_type
8628 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
8634 unwrap_value (evaluate_subexp_standard
8635 (expect_type
, exp
, pos
, noside
));
8636 return ada_to_fixed_value (arg1
);
8642 /* Allocate arg vector, including space for the function to be
8643 called in argvec[0] and a terminating NULL. */
8644 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8646 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
8648 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
8649 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
8650 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8651 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
8654 for (tem
= 0; tem
<= nargs
; tem
+= 1)
8655 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8658 if (noside
== EVAL_SKIP
)
8662 if (ada_is_packed_array_type (desc_base_type (value_type (argvec
[0]))))
8663 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
8664 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
8665 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
8666 && VALUE_LVAL (argvec
[0]) == lval_memory
))
8667 argvec
[0] = value_addr (argvec
[0]);
8669 type
= ada_check_typedef (value_type (argvec
[0]));
8670 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
8672 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
8674 case TYPE_CODE_FUNC
:
8675 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8677 case TYPE_CODE_ARRAY
:
8679 case TYPE_CODE_STRUCT
:
8680 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
8681 argvec
[0] = ada_value_ind (argvec
[0]);
8682 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8685 error (_("cannot subscript or call something of type `%s'"),
8686 ada_type_name (value_type (argvec
[0])));
8691 switch (TYPE_CODE (type
))
8693 case TYPE_CODE_FUNC
:
8694 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8695 return allocate_value (TYPE_TARGET_TYPE (type
));
8696 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
8697 case TYPE_CODE_STRUCT
:
8701 arity
= ada_array_arity (type
);
8702 type
= ada_array_element_type (type
, nargs
);
8704 error (_("cannot subscript or call a record"));
8706 error (_("wrong number of subscripts; expecting %d"), arity
);
8707 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8708 return value_zero (ada_aligned_type (type
), lval_memory
);
8710 unwrap_value (ada_value_subscript
8711 (argvec
[0], nargs
, argvec
+ 1));
8713 case TYPE_CODE_ARRAY
:
8714 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8716 type
= ada_array_element_type (type
, nargs
);
8718 error (_("element type of array unknown"));
8720 return value_zero (ada_aligned_type (type
), lval_memory
);
8723 unwrap_value (ada_value_subscript
8724 (ada_coerce_to_simple_array (argvec
[0]),
8725 nargs
, argvec
+ 1));
8726 case TYPE_CODE_PTR
: /* Pointer to array */
8727 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
8728 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8730 type
= ada_array_element_type (type
, nargs
);
8732 error (_("element type of array unknown"));
8734 return value_zero (ada_aligned_type (type
), lval_memory
);
8737 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
8738 nargs
, argvec
+ 1));
8741 error (_("Attempt to index or call something other than an "
8742 "array or function"));
8747 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8748 struct value
*low_bound_val
=
8749 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8750 struct value
*high_bound_val
=
8751 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8754 low_bound_val
= coerce_ref (low_bound_val
);
8755 high_bound_val
= coerce_ref (high_bound_val
);
8756 low_bound
= pos_atr (low_bound_val
);
8757 high_bound
= pos_atr (high_bound_val
);
8759 if (noside
== EVAL_SKIP
)
8762 /* If this is a reference to an aligner type, then remove all
8764 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8765 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
8766 TYPE_TARGET_TYPE (value_type (array
)) =
8767 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
8769 if (ada_is_packed_array_type (value_type (array
)))
8770 error (_("cannot slice a packed array"));
8772 /* If this is a reference to an array or an array lvalue,
8773 convert to a pointer. */
8774 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8775 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
8776 && VALUE_LVAL (array
) == lval_memory
))
8777 array
= value_addr (array
);
8779 if (noside
== EVAL_AVOID_SIDE_EFFECTS
8780 && ada_is_array_descriptor_type (ada_check_typedef
8781 (value_type (array
))))
8782 return empty_array (ada_type_of_array (array
, 0), low_bound
);
8784 array
= ada_coerce_to_simple_array_ptr (array
);
8786 /* If we have more than one level of pointer indirection,
8787 dereference the value until we get only one level. */
8788 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
8789 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
8791 array
= value_ind (array
);
8793 /* Make sure we really do have an array type before going further,
8794 to avoid a SEGV when trying to get the index type or the target
8795 type later down the road if the debug info generated by
8796 the compiler is incorrect or incomplete. */
8797 if (!ada_is_simple_array_type (value_type (array
)))
8798 error (_("cannot take slice of non-array"));
8800 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
8802 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8803 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
8807 struct type
*arr_type0
=
8808 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
8810 return ada_value_slice_from_ptr (array
, arr_type0
,
8811 longest_to_int (low_bound
),
8812 longest_to_int (high_bound
));
8815 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8817 else if (high_bound
< low_bound
)
8818 return empty_array (value_type (array
), low_bound
);
8820 return ada_value_slice (array
, longest_to_int (low_bound
),
8821 longest_to_int (high_bound
));
8826 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8827 type
= exp
->elts
[pc
+ 1].type
;
8829 if (noside
== EVAL_SKIP
)
8832 switch (TYPE_CODE (type
))
8835 lim_warning (_("Membership test incompletely implemented; "
8836 "always returns true"));
8837 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8838 return value_from_longest (type
, (LONGEST
) 1);
8840 case TYPE_CODE_RANGE
:
8841 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
8842 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
8843 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8844 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8845 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8847 value_from_longest (type
,
8848 (value_less (arg1
, arg3
)
8849 || value_equal (arg1
, arg3
))
8850 && (value_less (arg2
, arg1
)
8851 || value_equal (arg2
, arg1
)));
8854 case BINOP_IN_BOUNDS
:
8856 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8857 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8859 if (noside
== EVAL_SKIP
)
8862 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8864 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8865 return value_zero (type
, not_lval
);
8868 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8870 if (tem
< 1 || tem
> ada_array_arity (value_type (arg2
)))
8871 error (_("invalid dimension number to 'range"));
8873 arg3
= ada_array_bound (arg2
, tem
, 1);
8874 arg2
= ada_array_bound (arg2
, tem
, 0);
8876 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8877 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8878 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8880 value_from_longest (type
,
8881 (value_less (arg1
, arg3
)
8882 || value_equal (arg1
, arg3
))
8883 && (value_less (arg2
, arg1
)
8884 || value_equal (arg2
, arg1
)));
8886 case TERNOP_IN_RANGE
:
8887 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8888 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8889 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8891 if (noside
== EVAL_SKIP
)
8894 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8895 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8896 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8898 value_from_longest (type
,
8899 (value_less (arg1
, arg3
)
8900 || value_equal (arg1
, arg3
))
8901 && (value_less (arg2
, arg1
)
8902 || value_equal (arg2
, arg1
)));
8908 struct type
*type_arg
;
8909 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8911 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8913 type_arg
= exp
->elts
[pc
+ 2].type
;
8917 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8921 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
8922 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
8923 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
8926 if (noside
== EVAL_SKIP
)
8929 if (type_arg
== NULL
)
8931 arg1
= ada_coerce_ref (arg1
);
8933 if (ada_is_packed_array_type (value_type (arg1
)))
8934 arg1
= ada_coerce_to_simple_array (arg1
);
8936 if (tem
< 1 || tem
> ada_array_arity (value_type (arg1
)))
8937 error (_("invalid dimension number to '%s"),
8938 ada_attribute_name (op
));
8940 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8942 type
= ada_index_type (value_type (arg1
), tem
);
8945 (_("attempt to take bound of something that is not an array"));
8946 return allocate_value (type
);
8951 default: /* Should never happen. */
8952 error (_("unexpected attribute encountered"));
8954 return ada_array_bound (arg1
, tem
, 0);
8956 return ada_array_bound (arg1
, tem
, 1);
8958 return ada_array_length (arg1
, tem
);
8961 else if (discrete_type_p (type_arg
))
8963 struct type
*range_type
;
8964 char *name
= ada_type_name (type_arg
);
8966 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
8968 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
8969 if (range_type
== NULL
)
8970 range_type
= type_arg
;
8974 error (_("unexpected attribute encountered"));
8976 return value_from_longest
8977 (range_type
, discrete_type_low_bound (range_type
));
8979 return value_from_longest
8980 (range_type
, discrete_type_high_bound (range_type
));
8982 error (_("the 'length attribute applies only to array types"));
8985 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
8986 error (_("unimplemented type attribute"));
8991 if (ada_is_packed_array_type (type_arg
))
8992 type_arg
= decode_packed_array_type (type_arg
);
8994 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
8995 error (_("invalid dimension number to '%s"),
8996 ada_attribute_name (op
));
8998 type
= ada_index_type (type_arg
, tem
);
9001 (_("attempt to take bound of something that is not an array"));
9002 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9003 return allocate_value (type
);
9008 error (_("unexpected attribute encountered"));
9010 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9011 return value_from_longest (type
, low
);
9013 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
9014 return value_from_longest (type
, high
);
9016 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9017 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
9018 return value_from_longest (type
, high
- low
+ 1);
9024 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9025 if (noside
== EVAL_SKIP
)
9028 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9029 return value_zero (ada_tag_type (arg1
), not_lval
);
9031 return ada_value_tag (arg1
);
9035 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9036 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9037 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9038 if (noside
== EVAL_SKIP
)
9040 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9041 return value_zero (value_type (arg1
), not_lval
);
9044 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9045 return value_binop (arg1
, arg2
,
9046 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
9049 case OP_ATR_MODULUS
:
9051 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
9052 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9054 if (noside
== EVAL_SKIP
)
9057 if (!ada_is_modular_type (type_arg
))
9058 error (_("'modulus must be applied to modular type"));
9060 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
9061 ada_modulus (type_arg
));
9066 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9067 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9068 if (noside
== EVAL_SKIP
)
9070 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9071 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9072 return value_zero (type
, not_lval
);
9074 return value_pos_atr (type
, arg1
);
9077 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9078 type
= value_type (arg1
);
9080 /* If the argument is a reference, then dereference its type, since
9081 the user is really asking for the size of the actual object,
9082 not the size of the pointer. */
9083 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
9084 type
= TYPE_TARGET_TYPE (type
);
9086 if (noside
== EVAL_SKIP
)
9088 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9089 return value_zero (builtin_type_int32
, not_lval
);
9091 return value_from_longest (builtin_type_int32
,
9092 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
9095 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9096 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9097 type
= exp
->elts
[pc
+ 2].type
;
9098 if (noside
== EVAL_SKIP
)
9100 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9101 return value_zero (type
, not_lval
);
9103 return value_val_atr (type
, arg1
);
9106 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9107 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9108 if (noside
== EVAL_SKIP
)
9110 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9111 return value_zero (value_type (arg1
), not_lval
);
9114 /* For integer exponentiation operations,
9115 only promote the first argument. */
9116 if (is_integral_type (value_type (arg2
)))
9117 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9119 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9121 return value_binop (arg1
, arg2
, op
);
9125 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9126 if (noside
== EVAL_SKIP
)
9132 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9133 if (noside
== EVAL_SKIP
)
9135 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9136 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
9137 return value_neg (arg1
);
9142 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9143 if (noside
== EVAL_SKIP
)
9145 type
= ada_check_typedef (value_type (arg1
));
9146 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9148 if (ada_is_array_descriptor_type (type
))
9149 /* GDB allows dereferencing GNAT array descriptors. */
9151 struct type
*arrType
= ada_type_of_array (arg1
, 0);
9152 if (arrType
== NULL
)
9153 error (_("Attempt to dereference null array pointer."));
9154 return value_at_lazy (arrType
, 0);
9156 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
9157 || TYPE_CODE (type
) == TYPE_CODE_REF
9158 /* In C you can dereference an array to get the 1st elt. */
9159 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9161 type
= to_static_fixed_type
9163 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
9165 return value_zero (type
, lval_memory
);
9167 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9169 /* GDB allows dereferencing an int. */
9170 if (expect_type
== NULL
)
9171 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
9176 to_static_fixed_type (ada_aligned_type (expect_type
));
9177 return value_zero (expect_type
, lval_memory
);
9181 error (_("Attempt to take contents of a non-pointer value."));
9183 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
9184 type
= ada_check_typedef (value_type (arg1
));
9186 if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9187 /* GDB allows dereferencing an int. If we were given
9188 the expect_type, then use that as the target type.
9189 Otherwise, assume that the target type is an int. */
9191 if (expect_type
!= NULL
)
9192 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
9195 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
9196 (CORE_ADDR
) value_as_address (arg1
));
9199 if (ada_is_array_descriptor_type (type
))
9200 /* GDB allows dereferencing GNAT array descriptors. */
9201 return ada_coerce_to_simple_array (arg1
);
9203 return ada_value_ind (arg1
);
9205 case STRUCTOP_STRUCT
:
9206 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9207 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
9208 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9209 if (noside
== EVAL_SKIP
)
9211 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9213 struct type
*type1
= value_type (arg1
);
9214 if (ada_is_tagged_type (type1
, 1))
9216 type
= ada_lookup_struct_elt_type (type1
,
9217 &exp
->elts
[pc
+ 2].string
,
9220 /* In this case, we assume that the field COULD exist
9221 in some extension of the type. Return an object of
9222 "type" void, which will match any formal
9223 (see ada_type_match). */
9224 return value_zero (builtin_type_void
, lval_memory
);
9228 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
9231 return value_zero (ada_aligned_type (type
), lval_memory
);
9235 ada_to_fixed_value (unwrap_value
9236 (ada_value_struct_elt
9237 (arg1
, &exp
->elts
[pc
+ 2].string
, 0)));
9239 /* The value is not supposed to be used. This is here to make it
9240 easier to accommodate expressions that contain types. */
9242 if (noside
== EVAL_SKIP
)
9244 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9245 return allocate_value (exp
->elts
[pc
+ 1].type
);
9247 error (_("Attempt to use a type name as an expression"));
9252 case OP_DISCRETE_RANGE
:
9255 if (noside
== EVAL_NORMAL
)
9259 error (_("Undefined name, ambiguous name, or renaming used in "
9260 "component association: %s."), &exp
->elts
[pc
+2].string
);
9262 error (_("Aggregates only allowed on the right of an assignment"));
9264 internal_error (__FILE__
, __LINE__
, _("aggregate apparently mangled"));
9267 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
9269 for (tem
= 0; tem
< nargs
; tem
+= 1)
9270 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9275 return value_from_longest (builtin_type_int8
, (LONGEST
) 1);
9281 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9282 type name that encodes the 'small and 'delta information.
9283 Otherwise, return NULL. */
9286 fixed_type_info (struct type
*type
)
9288 const char *name
= ada_type_name (type
);
9289 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
9291 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
9293 const char *tail
= strstr (name
, "___XF_");
9299 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
9300 return fixed_type_info (TYPE_TARGET_TYPE (type
));
9305 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9308 ada_is_fixed_point_type (struct type
*type
)
9310 return fixed_type_info (type
) != NULL
;
9313 /* Return non-zero iff TYPE represents a System.Address type. */
9316 ada_is_system_address_type (struct type
*type
)
9318 return (TYPE_NAME (type
)
9319 && strcmp (TYPE_NAME (type
), "system__address") == 0);
9322 /* Assuming that TYPE is the representation of an Ada fixed-point
9323 type, return its delta, or -1 if the type is malformed and the
9324 delta cannot be determined. */
9327 ada_delta (struct type
*type
)
9329 const char *encoding
= fixed_type_info (type
);
9332 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
9335 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
9338 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9339 factor ('SMALL value) associated with the type. */
9342 scaling_factor (struct type
*type
)
9344 const char *encoding
= fixed_type_info (type
);
9345 unsigned long num0
, den0
, num1
, den1
;
9348 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
9353 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
9355 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
9359 /* Assuming that X is the representation of a value of fixed-point
9360 type TYPE, return its floating-point equivalent. */
9363 ada_fixed_to_float (struct type
*type
, LONGEST x
)
9365 return (DOUBLEST
) x
*scaling_factor (type
);
9368 /* The representation of a fixed-point value of type TYPE
9369 corresponding to the value X. */
9372 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
9374 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
9378 /* VAX floating formats */
9380 /* Non-zero iff TYPE represents one of the special VAX floating-point
9384 ada_is_vax_floating_type (struct type
*type
)
9387 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
9390 && (TYPE_CODE (type
) == TYPE_CODE_INT
9391 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
9392 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
9395 /* The type of special VAX floating-point type this is, assuming
9396 ada_is_vax_floating_point. */
9399 ada_vax_float_type_suffix (struct type
*type
)
9401 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
9404 /* A value representing the special debugging function that outputs
9405 VAX floating-point values of the type represented by TYPE. Assumes
9406 ada_is_vax_floating_type (TYPE). */
9409 ada_vax_float_print_function (struct type
*type
)
9411 switch (ada_vax_float_type_suffix (type
))
9414 return get_var_value ("DEBUG_STRING_F", 0);
9416 return get_var_value ("DEBUG_STRING_D", 0);
9418 return get_var_value ("DEBUG_STRING_G", 0);
9420 error (_("invalid VAX floating-point type"));
9427 /* Scan STR beginning at position K for a discriminant name, and
9428 return the value of that discriminant field of DVAL in *PX. If
9429 PNEW_K is not null, put the position of the character beyond the
9430 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9431 not alter *PX and *PNEW_K if unsuccessful. */
9434 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
9437 static char *bound_buffer
= NULL
;
9438 static size_t bound_buffer_len
= 0;
9441 struct value
*bound_val
;
9443 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9446 pend
= strstr (str
+ k
, "__");
9450 k
+= strlen (bound
);
9454 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9455 bound
= bound_buffer
;
9456 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9457 bound
[pend
- (str
+ k
)] = '\0';
9461 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
9462 if (bound_val
== NULL
)
9465 *px
= value_as_long (bound_val
);
9471 /* Value of variable named NAME in the current environment. If
9472 no such variable found, then if ERR_MSG is null, returns 0, and
9473 otherwise causes an error with message ERR_MSG. */
9475 static struct value
*
9476 get_var_value (char *name
, char *err_msg
)
9478 struct ada_symbol_info
*syms
;
9481 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9486 if (err_msg
== NULL
)
9489 error (("%s"), err_msg
);
9492 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9495 /* Value of integer variable named NAME in the current environment. If
9496 no such variable found, returns 0, and sets *FLAG to 0. If
9497 successful, sets *FLAG to 1. */
9500 get_int_var_value (char *name
, int *flag
)
9502 struct value
*var_val
= get_var_value (name
, 0);
9514 return value_as_long (var_val
);
9519 /* Return a range type whose base type is that of the range type named
9520 NAME in the current environment, and whose bounds are calculated
9521 from NAME according to the GNAT range encoding conventions.
9522 Extract discriminant values, if needed, from DVAL. If a new type
9523 must be created, allocate in OBJFILE's space. The bounds
9524 information, in general, is encoded in NAME, the base type given in
9525 the named range type. */
9527 static struct type
*
9528 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
9530 struct type
*raw_type
= ada_find_any_type (name
);
9531 struct type
*base_type
;
9534 if (raw_type
== NULL
)
9535 base_type
= builtin_type_int32
;
9536 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9537 base_type
= TYPE_TARGET_TYPE (raw_type
);
9539 base_type
= raw_type
;
9541 subtype_info
= strstr (name
, "___XD");
9542 if (subtype_info
== NULL
)
9544 LONGEST L
= discrete_type_low_bound (raw_type
);
9545 LONGEST U
= discrete_type_high_bound (raw_type
);
9546 if (L
< INT_MIN
|| U
> INT_MAX
)
9549 return create_range_type (alloc_type (objfile
), raw_type
,
9550 discrete_type_low_bound (raw_type
),
9551 discrete_type_high_bound (raw_type
));
9555 static char *name_buf
= NULL
;
9556 static size_t name_len
= 0;
9557 int prefix_len
= subtype_info
- name
;
9563 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
9564 strncpy (name_buf
, name
, prefix_len
);
9565 name_buf
[prefix_len
] = '\0';
9568 bounds_str
= strchr (subtype_info
, '_');
9571 if (*subtype_info
== 'L')
9573 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
9574 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
9576 if (bounds_str
[n
] == '_')
9578 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
9585 strcpy (name_buf
+ prefix_len
, "___L");
9586 L
= get_int_var_value (name_buf
, &ok
);
9589 lim_warning (_("Unknown lower bound, using 1."));
9594 if (*subtype_info
== 'U')
9596 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
9597 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
9603 strcpy (name_buf
+ prefix_len
, "___U");
9604 U
= get_int_var_value (name_buf
, &ok
);
9607 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
9612 if (objfile
== NULL
)
9613 objfile
= TYPE_OBJFILE (base_type
);
9614 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
9615 TYPE_NAME (type
) = name
;
9620 /* True iff NAME is the name of a range type. */
9623 ada_is_range_type_name (const char *name
)
9625 return (name
!= NULL
&& strstr (name
, "___XD"));
9631 /* True iff TYPE is an Ada modular type. */
9634 ada_is_modular_type (struct type
*type
)
9636 struct type
*subranged_type
= base_type (type
);
9638 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
9639 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
9640 && TYPE_UNSIGNED (subranged_type
));
9643 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9646 ada_modulus (struct type
* type
)
9648 return (ULONGEST
) (unsigned int) TYPE_HIGH_BOUND (type
) + 1;
9652 /* Ada exception catchpoint support:
9653 ---------------------------------
9655 We support 3 kinds of exception catchpoints:
9656 . catchpoints on Ada exceptions
9657 . catchpoints on unhandled Ada exceptions
9658 . catchpoints on failed assertions
9660 Exceptions raised during failed assertions, or unhandled exceptions
9661 could perfectly be caught with the general catchpoint on Ada exceptions.
9662 However, we can easily differentiate these two special cases, and having
9663 the option to distinguish these two cases from the rest can be useful
9664 to zero-in on certain situations.
9666 Exception catchpoints are a specialized form of breakpoint,
9667 since they rely on inserting breakpoints inside known routines
9668 of the GNAT runtime. The implementation therefore uses a standard
9669 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9672 Support in the runtime for exception catchpoints have been changed
9673 a few times already, and these changes affect the implementation
9674 of these catchpoints. In order to be able to support several
9675 variants of the runtime, we use a sniffer that will determine
9676 the runtime variant used by the program being debugged.
9678 At this time, we do not support the use of conditions on Ada exception
9679 catchpoints. The COND and COND_STRING fields are therefore set
9680 to NULL (most of the time, see below).
9682 Conditions where EXP_STRING, COND, and COND_STRING are used:
9684 When a user specifies the name of a specific exception in the case
9685 of catchpoints on Ada exceptions, we store the name of that exception
9686 in the EXP_STRING. We then translate this request into an actual
9687 condition stored in COND_STRING, and then parse it into an expression
9690 /* The different types of catchpoints that we introduced for catching
9693 enum exception_catchpoint_kind
9696 ex_catch_exception_unhandled
,
9700 /* Ada's standard exceptions. */
9702 static char *standard_exc
[] = {
9709 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
9711 /* A structure that describes how to support exception catchpoints
9712 for a given executable. */
9714 struct exception_support_info
9716 /* The name of the symbol to break on in order to insert
9717 a catchpoint on exceptions. */
9718 const char *catch_exception_sym
;
9720 /* The name of the symbol to break on in order to insert
9721 a catchpoint on unhandled exceptions. */
9722 const char *catch_exception_unhandled_sym
;
9724 /* The name of the symbol to break on in order to insert
9725 a catchpoint on failed assertions. */
9726 const char *catch_assert_sym
;
9728 /* Assuming that the inferior just triggered an unhandled exception
9729 catchpoint, this function is responsible for returning the address
9730 in inferior memory where the name of that exception is stored.
9731 Return zero if the address could not be computed. */
9732 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
9735 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
9736 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
9738 /* The following exception support info structure describes how to
9739 implement exception catchpoints with the latest version of the
9740 Ada runtime (as of 2007-03-06). */
9742 static const struct exception_support_info default_exception_support_info
=
9744 "__gnat_debug_raise_exception", /* catch_exception_sym */
9745 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9746 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9747 ada_unhandled_exception_name_addr
9750 /* The following exception support info structure describes how to
9751 implement exception catchpoints with a slightly older version
9752 of the Ada runtime. */
9754 static const struct exception_support_info exception_support_info_fallback
=
9756 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9757 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9758 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9759 ada_unhandled_exception_name_addr_from_raise
9762 /* For each executable, we sniff which exception info structure to use
9763 and cache it in the following global variable. */
9765 static const struct exception_support_info
*exception_info
= NULL
;
9767 /* Inspect the Ada runtime and determine which exception info structure
9768 should be used to provide support for exception catchpoints.
9770 This function will always set exception_info, or raise an error. */
9773 ada_exception_support_info_sniffer (void)
9777 /* If the exception info is already known, then no need to recompute it. */
9778 if (exception_info
!= NULL
)
9781 /* Check the latest (default) exception support info. */
9782 sym
= standard_lookup (default_exception_support_info
.catch_exception_sym
,
9786 exception_info
= &default_exception_support_info
;
9790 /* Try our fallback exception suport info. */
9791 sym
= standard_lookup (exception_support_info_fallback
.catch_exception_sym
,
9795 exception_info
= &exception_support_info_fallback
;
9799 /* Sometimes, it is normal for us to not be able to find the routine
9800 we are looking for. This happens when the program is linked with
9801 the shared version of the GNAT runtime, and the program has not been
9802 started yet. Inform the user of these two possible causes if
9805 if (ada_update_initial_language (language_unknown
, NULL
) != language_ada
)
9806 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9808 /* If the symbol does not exist, then check that the program is
9809 already started, to make sure that shared libraries have been
9810 loaded. If it is not started, this may mean that the symbol is
9811 in a shared library. */
9813 if (ptid_get_pid (inferior_ptid
) == 0)
9814 error (_("Unable to insert catchpoint. Try to start the program first."));
9816 /* At this point, we know that we are debugging an Ada program and
9817 that the inferior has been started, but we still are not able to
9818 find the run-time symbols. That can mean that we are in
9819 configurable run time mode, or that a-except as been optimized
9820 out by the linker... In any case, at this point it is not worth
9821 supporting this feature. */
9823 error (_("Cannot insert catchpoints in this configuration."));
9826 /* An observer of "executable_changed" events.
9827 Its role is to clear certain cached values that need to be recomputed
9828 each time a new executable is loaded by GDB. */
9831 ada_executable_changed_observer (void)
9833 /* If the executable changed, then it is possible that the Ada runtime
9834 is different. So we need to invalidate the exception support info
9836 exception_info
= NULL
;
9839 /* Return the name of the function at PC, NULL if could not find it.
9840 This function only checks the debugging information, not the symbol
9844 function_name_from_pc (CORE_ADDR pc
)
9848 if (!find_pc_partial_function (pc
, &func_name
, NULL
, NULL
))
9854 /* True iff FRAME is very likely to be that of a function that is
9855 part of the runtime system. This is all very heuristic, but is
9856 intended to be used as advice as to what frames are uninteresting
9860 is_known_support_routine (struct frame_info
*frame
)
9862 struct symtab_and_line sal
;
9866 /* If this code does not have any debugging information (no symtab),
9867 This cannot be any user code. */
9869 find_frame_sal (frame
, &sal
);
9870 if (sal
.symtab
== NULL
)
9873 /* If there is a symtab, but the associated source file cannot be
9874 located, then assume this is not user code: Selecting a frame
9875 for which we cannot display the code would not be very helpful
9876 for the user. This should also take care of case such as VxWorks
9877 where the kernel has some debugging info provided for a few units. */
9879 if (symtab_to_fullname (sal
.symtab
) == NULL
)
9882 /* Check the unit filename againt the Ada runtime file naming.
9883 We also check the name of the objfile against the name of some
9884 known system libraries that sometimes come with debugging info
9887 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
9889 re_comp (known_runtime_file_name_patterns
[i
]);
9890 if (re_exec (sal
.symtab
->filename
))
9892 if (sal
.symtab
->objfile
!= NULL
9893 && re_exec (sal
.symtab
->objfile
->name
))
9897 /* Check whether the function is a GNAT-generated entity. */
9899 func_name
= function_name_from_pc (get_frame_address_in_block (frame
));
9900 if (func_name
== NULL
)
9903 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
9905 re_comp (known_auxiliary_function_name_patterns
[i
]);
9906 if (re_exec (func_name
))
9913 /* Find the first frame that contains debugging information and that is not
9914 part of the Ada run-time, starting from FI and moving upward. */
9917 ada_find_printable_frame (struct frame_info
*fi
)
9919 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
9921 if (!is_known_support_routine (fi
))
9930 /* Assuming that the inferior just triggered an unhandled exception
9931 catchpoint, return the address in inferior memory where the name
9932 of the exception is stored.
9934 Return zero if the address could not be computed. */
9937 ada_unhandled_exception_name_addr (void)
9939 return parse_and_eval_address ("e.full_name");
9942 /* Same as ada_unhandled_exception_name_addr, except that this function
9943 should be used when the inferior uses an older version of the runtime,
9944 where the exception name needs to be extracted from a specific frame
9945 several frames up in the callstack. */
9948 ada_unhandled_exception_name_addr_from_raise (void)
9951 struct frame_info
*fi
;
9953 /* To determine the name of this exception, we need to select
9954 the frame corresponding to RAISE_SYM_NAME. This frame is
9955 at least 3 levels up, so we simply skip the first 3 frames
9956 without checking the name of their associated function. */
9957 fi
= get_current_frame ();
9958 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
9960 fi
= get_prev_frame (fi
);
9964 const char *func_name
=
9965 function_name_from_pc (get_frame_address_in_block (fi
));
9966 if (func_name
!= NULL
9967 && strcmp (func_name
, exception_info
->catch_exception_sym
) == 0)
9968 break; /* We found the frame we were looking for... */
9969 fi
= get_prev_frame (fi
);
9976 return parse_and_eval_address ("id.full_name");
9979 /* Assuming the inferior just triggered an Ada exception catchpoint
9980 (of any type), return the address in inferior memory where the name
9981 of the exception is stored, if applicable.
9983 Return zero if the address could not be computed, or if not relevant. */
9986 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex
,
9987 struct breakpoint
*b
)
9991 case ex_catch_exception
:
9992 return (parse_and_eval_address ("e.full_name"));
9995 case ex_catch_exception_unhandled
:
9996 return exception_info
->unhandled_exception_name_addr ();
9999 case ex_catch_assert
:
10000 return 0; /* Exception name is not relevant in this case. */
10004 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10008 return 0; /* Should never be reached. */
10011 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
10012 any error that ada_exception_name_addr_1 might cause to be thrown.
10013 When an error is intercepted, a warning with the error message is printed,
10014 and zero is returned. */
10017 ada_exception_name_addr (enum exception_catchpoint_kind ex
,
10018 struct breakpoint
*b
)
10020 struct gdb_exception e
;
10021 CORE_ADDR result
= 0;
10023 TRY_CATCH (e
, RETURN_MASK_ERROR
)
10025 result
= ada_exception_name_addr_1 (ex
, b
);
10030 warning (_("failed to get exception name: %s"), e
.message
);
10037 /* Implement the PRINT_IT method in the breakpoint_ops structure
10038 for all exception catchpoint kinds. */
10040 static enum print_stop_action
10041 print_it_exception (enum exception_catchpoint_kind ex
, struct breakpoint
*b
)
10043 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
10044 char exception_name
[256];
10048 read_memory (addr
, exception_name
, sizeof (exception_name
) - 1);
10049 exception_name
[sizeof (exception_name
) - 1] = '\0';
10052 ada_find_printable_frame (get_current_frame ());
10054 annotate_catchpoint (b
->number
);
10057 case ex_catch_exception
:
10059 printf_filtered (_("\nCatchpoint %d, %s at "),
10060 b
->number
, exception_name
);
10062 printf_filtered (_("\nCatchpoint %d, exception at "), b
->number
);
10064 case ex_catch_exception_unhandled
:
10066 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10067 b
->number
, exception_name
);
10069 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10072 case ex_catch_assert
:
10073 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10078 return PRINT_SRC_AND_LOC
;
10081 /* Implement the PRINT_ONE method in the breakpoint_ops structure
10082 for all exception catchpoint kinds. */
10085 print_one_exception (enum exception_catchpoint_kind ex
,
10086 struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10088 struct value_print_options opts
;
10090 get_user_print_options (&opts
);
10091 if (opts
.addressprint
)
10093 annotate_field (4);
10094 ui_out_field_core_addr (uiout
, "addr", b
->loc
->address
);
10097 annotate_field (5);
10098 *last_addr
= b
->loc
->address
;
10101 case ex_catch_exception
:
10102 if (b
->exp_string
!= NULL
)
10104 char *msg
= xstrprintf (_("`%s' Ada exception"), b
->exp_string
);
10106 ui_out_field_string (uiout
, "what", msg
);
10110 ui_out_field_string (uiout
, "what", "all Ada exceptions");
10114 case ex_catch_exception_unhandled
:
10115 ui_out_field_string (uiout
, "what", "unhandled Ada exceptions");
10118 case ex_catch_assert
:
10119 ui_out_field_string (uiout
, "what", "failed Ada assertions");
10123 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10128 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
10129 for all exception catchpoint kinds. */
10132 print_mention_exception (enum exception_catchpoint_kind ex
,
10133 struct breakpoint
*b
)
10137 case ex_catch_exception
:
10138 if (b
->exp_string
!= NULL
)
10139 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10140 b
->number
, b
->exp_string
);
10142 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b
->number
);
10146 case ex_catch_exception_unhandled
:
10147 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10151 case ex_catch_assert
:
10152 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b
->number
);
10156 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10161 /* Virtual table for "catch exception" breakpoints. */
10163 static enum print_stop_action
10164 print_it_catch_exception (struct breakpoint
*b
)
10166 return print_it_exception (ex_catch_exception
, b
);
10170 print_one_catch_exception (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10172 print_one_exception (ex_catch_exception
, b
, last_addr
);
10176 print_mention_catch_exception (struct breakpoint
*b
)
10178 print_mention_exception (ex_catch_exception
, b
);
10181 static struct breakpoint_ops catch_exception_breakpoint_ops
=
10185 NULL
, /* breakpoint_hit */
10186 print_it_catch_exception
,
10187 print_one_catch_exception
,
10188 print_mention_catch_exception
10191 /* Virtual table for "catch exception unhandled" breakpoints. */
10193 static enum print_stop_action
10194 print_it_catch_exception_unhandled (struct breakpoint
*b
)
10196 return print_it_exception (ex_catch_exception_unhandled
, b
);
10200 print_one_catch_exception_unhandled (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10202 print_one_exception (ex_catch_exception_unhandled
, b
, last_addr
);
10206 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
10208 print_mention_exception (ex_catch_exception_unhandled
, b
);
10211 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
= {
10214 NULL
, /* breakpoint_hit */
10215 print_it_catch_exception_unhandled
,
10216 print_one_catch_exception_unhandled
,
10217 print_mention_catch_exception_unhandled
10220 /* Virtual table for "catch assert" breakpoints. */
10222 static enum print_stop_action
10223 print_it_catch_assert (struct breakpoint
*b
)
10225 return print_it_exception (ex_catch_assert
, b
);
10229 print_one_catch_assert (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10231 print_one_exception (ex_catch_assert
, b
, last_addr
);
10235 print_mention_catch_assert (struct breakpoint
*b
)
10237 print_mention_exception (ex_catch_assert
, b
);
10240 static struct breakpoint_ops catch_assert_breakpoint_ops
= {
10243 NULL
, /* breakpoint_hit */
10244 print_it_catch_assert
,
10245 print_one_catch_assert
,
10246 print_mention_catch_assert
10249 /* Return non-zero if B is an Ada exception catchpoint. */
10252 ada_exception_catchpoint_p (struct breakpoint
*b
)
10254 return (b
->ops
== &catch_exception_breakpoint_ops
10255 || b
->ops
== &catch_exception_unhandled_breakpoint_ops
10256 || b
->ops
== &catch_assert_breakpoint_ops
);
10259 /* Return a newly allocated copy of the first space-separated token
10260 in ARGSP, and then adjust ARGSP to point immediately after that
10263 Return NULL if ARGPS does not contain any more tokens. */
10266 ada_get_next_arg (char **argsp
)
10268 char *args
= *argsp
;
10272 /* Skip any leading white space. */
10274 while (isspace (*args
))
10277 if (args
[0] == '\0')
10278 return NULL
; /* No more arguments. */
10280 /* Find the end of the current argument. */
10283 while (*end
!= '\0' && !isspace (*end
))
10286 /* Adjust ARGSP to point to the start of the next argument. */
10290 /* Make a copy of the current argument and return it. */
10292 result
= xmalloc (end
- args
+ 1);
10293 strncpy (result
, args
, end
- args
);
10294 result
[end
- args
] = '\0';
10299 /* Split the arguments specified in a "catch exception" command.
10300 Set EX to the appropriate catchpoint type.
10301 Set EXP_STRING to the name of the specific exception if
10302 specified by the user. */
10305 catch_ada_exception_command_split (char *args
,
10306 enum exception_catchpoint_kind
*ex
,
10309 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
10310 char *exception_name
;
10312 exception_name
= ada_get_next_arg (&args
);
10313 make_cleanup (xfree
, exception_name
);
10315 /* Check that we do not have any more arguments. Anything else
10318 while (isspace (*args
))
10321 if (args
[0] != '\0')
10322 error (_("Junk at end of expression"));
10324 discard_cleanups (old_chain
);
10326 if (exception_name
== NULL
)
10328 /* Catch all exceptions. */
10329 *ex
= ex_catch_exception
;
10330 *exp_string
= NULL
;
10332 else if (strcmp (exception_name
, "unhandled") == 0)
10334 /* Catch unhandled exceptions. */
10335 *ex
= ex_catch_exception_unhandled
;
10336 *exp_string
= NULL
;
10340 /* Catch a specific exception. */
10341 *ex
= ex_catch_exception
;
10342 *exp_string
= exception_name
;
10346 /* Return the name of the symbol on which we should break in order to
10347 implement a catchpoint of the EX kind. */
10349 static const char *
10350 ada_exception_sym_name (enum exception_catchpoint_kind ex
)
10352 gdb_assert (exception_info
!= NULL
);
10356 case ex_catch_exception
:
10357 return (exception_info
->catch_exception_sym
);
10359 case ex_catch_exception_unhandled
:
10360 return (exception_info
->catch_exception_unhandled_sym
);
10362 case ex_catch_assert
:
10363 return (exception_info
->catch_assert_sym
);
10366 internal_error (__FILE__
, __LINE__
,
10367 _("unexpected catchpoint kind (%d)"), ex
);
10371 /* Return the breakpoint ops "virtual table" used for catchpoints
10374 static struct breakpoint_ops
*
10375 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex
)
10379 case ex_catch_exception
:
10380 return (&catch_exception_breakpoint_ops
);
10382 case ex_catch_exception_unhandled
:
10383 return (&catch_exception_unhandled_breakpoint_ops
);
10385 case ex_catch_assert
:
10386 return (&catch_assert_breakpoint_ops
);
10389 internal_error (__FILE__
, __LINE__
,
10390 _("unexpected catchpoint kind (%d)"), ex
);
10394 /* Return the condition that will be used to match the current exception
10395 being raised with the exception that the user wants to catch. This
10396 assumes that this condition is used when the inferior just triggered
10397 an exception catchpoint.
10399 The string returned is a newly allocated string that needs to be
10400 deallocated later. */
10403 ada_exception_catchpoint_cond_string (const char *exp_string
)
10407 /* The standard exceptions are a special case. They are defined in
10408 runtime units that have been compiled without debugging info; if
10409 EXP_STRING is the not-fully-qualified name of a standard
10410 exception (e.g. "constraint_error") then, during the evaluation
10411 of the condition expression, the symbol lookup on this name would
10412 *not* return this standard exception. The catchpoint condition
10413 may then be set only on user-defined exceptions which have the
10414 same not-fully-qualified name (e.g. my_package.constraint_error).
10416 To avoid this unexcepted behavior, these standard exceptions are
10417 systematically prefixed by "standard". This means that "catch
10418 exception constraint_error" is rewritten into "catch exception
10419 standard.constraint_error".
10421 If an exception named contraint_error is defined in another package of
10422 the inferior program, then the only way to specify this exception as a
10423 breakpoint condition is to use its fully-qualified named:
10424 e.g. my_package.constraint_error. */
10426 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
10428 if (strcmp (standard_exc
[i
], exp_string
) == 0)
10430 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
10434 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string
);
10437 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
10439 static struct expression
*
10440 ada_parse_catchpoint_condition (char *cond_string
,
10441 struct symtab_and_line sal
)
10443 return (parse_exp_1 (&cond_string
, block_for_pc (sal
.pc
), 0));
10446 /* Return the symtab_and_line that should be used to insert an exception
10447 catchpoint of the TYPE kind.
10449 EX_STRING should contain the name of a specific exception
10450 that the catchpoint should catch, or NULL otherwise.
10452 The idea behind all the remaining parameters is that their names match
10453 the name of certain fields in the breakpoint structure that are used to
10454 handle exception catchpoints. This function returns the value to which
10455 these fields should be set, depending on the type of catchpoint we need
10458 If COND and COND_STRING are both non-NULL, any value they might
10459 hold will be free'ed, and then replaced by newly allocated ones.
10460 These parameters are left untouched otherwise. */
10462 static struct symtab_and_line
10463 ada_exception_sal (enum exception_catchpoint_kind ex
, char *exp_string
,
10464 char **addr_string
, char **cond_string
,
10465 struct expression
**cond
, struct breakpoint_ops
**ops
)
10467 const char *sym_name
;
10468 struct symbol
*sym
;
10469 struct symtab_and_line sal
;
10471 /* First, find out which exception support info to use. */
10472 ada_exception_support_info_sniffer ();
10474 /* Then lookup the function on which we will break in order to catch
10475 the Ada exceptions requested by the user. */
10477 sym_name
= ada_exception_sym_name (ex
);
10478 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
10480 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10481 that should be compiled with debugging information. As a result, we
10482 expect to find that symbol in the symtabs. If we don't find it, then
10483 the target most likely does not support Ada exceptions, or we cannot
10484 insert exception breakpoints yet, because the GNAT runtime hasn't been
10487 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10488 in such a way that no debugging information is produced for the symbol
10489 we are looking for. In this case, we could search the minimal symbols
10490 as a fall-back mechanism. This would still be operating in degraded
10491 mode, however, as we would still be missing the debugging information
10492 that is needed in order to extract the name of the exception being
10493 raised (this name is printed in the catchpoint message, and is also
10494 used when trying to catch a specific exception). We do not handle
10495 this case for now. */
10498 error (_("Unable to break on '%s' in this configuration."), sym_name
);
10500 /* Make sure that the symbol we found corresponds to a function. */
10501 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
10502 error (_("Symbol \"%s\" is not a function (class = %d)"),
10503 sym_name
, SYMBOL_CLASS (sym
));
10505 sal
= find_function_start_sal (sym
, 1);
10507 /* Set ADDR_STRING. */
10509 *addr_string
= xstrdup (sym_name
);
10511 /* Set the COND and COND_STRING (if not NULL). */
10513 if (cond_string
!= NULL
&& cond
!= NULL
)
10515 if (*cond_string
!= NULL
)
10517 xfree (*cond_string
);
10518 *cond_string
= NULL
;
10525 if (exp_string
!= NULL
)
10527 *cond_string
= ada_exception_catchpoint_cond_string (exp_string
);
10528 *cond
= ada_parse_catchpoint_condition (*cond_string
, sal
);
10533 *ops
= ada_exception_breakpoint_ops (ex
);
10538 /* Parse the arguments (ARGS) of the "catch exception" command.
10540 Set TYPE to the appropriate exception catchpoint type.
10541 If the user asked the catchpoint to catch only a specific
10542 exception, then save the exception name in ADDR_STRING.
10544 See ada_exception_sal for a description of all the remaining
10545 function arguments of this function. */
10547 struct symtab_and_line
10548 ada_decode_exception_location (char *args
, char **addr_string
,
10549 char **exp_string
, char **cond_string
,
10550 struct expression
**cond
,
10551 struct breakpoint_ops
**ops
)
10553 enum exception_catchpoint_kind ex
;
10555 catch_ada_exception_command_split (args
, &ex
, exp_string
);
10556 return ada_exception_sal (ex
, *exp_string
, addr_string
, cond_string
,
10560 struct symtab_and_line
10561 ada_decode_assert_location (char *args
, char **addr_string
,
10562 struct breakpoint_ops
**ops
)
10564 /* Check that no argument where provided at the end of the command. */
10568 while (isspace (*args
))
10571 error (_("Junk at end of arguments."));
10574 return ada_exception_sal (ex_catch_assert
, NULL
, addr_string
, NULL
, NULL
,
10579 /* Information about operators given special treatment in functions
10581 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10583 #define ADA_OPERATORS \
10584 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10585 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10586 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10587 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10588 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10589 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10590 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10591 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10592 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10593 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10594 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10595 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10596 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10597 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10598 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
10599 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10600 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10601 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10602 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
10605 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
10607 switch (exp
->elts
[pc
- 1].opcode
)
10610 operator_length_standard (exp
, pc
, oplenp
, argsp
);
10613 #define OP_DEFN(op, len, args, binop) \
10614 case op: *oplenp = len; *argsp = args; break;
10620 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
10625 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
10631 ada_op_name (enum exp_opcode opcode
)
10636 return op_name_standard (opcode
);
10638 #define OP_DEFN(op, len, args, binop) case op: return #op;
10643 return "OP_AGGREGATE";
10645 return "OP_CHOICES";
10651 /* As for operator_length, but assumes PC is pointing at the first
10652 element of the operator, and gives meaningful results only for the
10653 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
10656 ada_forward_operator_length (struct expression
*exp
, int pc
,
10657 int *oplenp
, int *argsp
)
10659 switch (exp
->elts
[pc
].opcode
)
10662 *oplenp
= *argsp
= 0;
10665 #define OP_DEFN(op, len, args, binop) \
10666 case op: *oplenp = len; *argsp = args; break;
10672 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10677 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
10683 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10684 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
10692 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
10694 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
10699 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
10703 /* Ada attributes ('Foo). */
10706 case OP_ATR_LENGTH
:
10710 case OP_ATR_MODULUS
:
10717 case UNOP_IN_RANGE
:
10719 /* XXX: gdb_sprint_host_address, type_sprint */
10720 fprintf_filtered (stream
, _("Type @"));
10721 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
10722 fprintf_filtered (stream
, " (");
10723 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
10724 fprintf_filtered (stream
, ")");
10726 case BINOP_IN_BOUNDS
:
10727 fprintf_filtered (stream
, " (%d)",
10728 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
10730 case TERNOP_IN_RANGE
:
10735 case OP_DISCRETE_RANGE
:
10736 case OP_POSITIONAL
:
10743 char *name
= &exp
->elts
[elt
+ 2].string
;
10744 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
10745 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
10750 return dump_subexp_body_standard (exp
, stream
, elt
);
10754 for (i
= 0; i
< nargs
; i
+= 1)
10755 elt
= dump_subexp (exp
, stream
, elt
);
10760 /* The Ada extension of print_subexp (q.v.). */
10763 ada_print_subexp (struct expression
*exp
, int *pos
,
10764 struct ui_file
*stream
, enum precedence prec
)
10766 int oplen
, nargs
, i
;
10768 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
10770 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
10777 print_subexp_standard (exp
, pos
, stream
, prec
);
10781 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
10784 case BINOP_IN_BOUNDS
:
10785 /* XXX: sprint_subexp */
10786 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10787 fputs_filtered (" in ", stream
);
10788 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10789 fputs_filtered ("'range", stream
);
10790 if (exp
->elts
[pc
+ 1].longconst
> 1)
10791 fprintf_filtered (stream
, "(%ld)",
10792 (long) exp
->elts
[pc
+ 1].longconst
);
10795 case TERNOP_IN_RANGE
:
10796 if (prec
>= PREC_EQUAL
)
10797 fputs_filtered ("(", stream
);
10798 /* XXX: sprint_subexp */
10799 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10800 fputs_filtered (" in ", stream
);
10801 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10802 fputs_filtered (" .. ", stream
);
10803 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10804 if (prec
>= PREC_EQUAL
)
10805 fputs_filtered (")", stream
);
10810 case OP_ATR_LENGTH
:
10814 case OP_ATR_MODULUS
:
10819 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10821 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
10822 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
10826 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10827 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
10831 for (tem
= 1; tem
< nargs
; tem
+= 1)
10833 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
10834 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
10836 fputs_filtered (")", stream
);
10841 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
10842 fputs_filtered ("'(", stream
);
10843 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
10844 fputs_filtered (")", stream
);
10847 case UNOP_IN_RANGE
:
10848 /* XXX: sprint_subexp */
10849 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10850 fputs_filtered (" in ", stream
);
10851 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
10854 case OP_DISCRETE_RANGE
:
10855 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10856 fputs_filtered ("..", stream
);
10857 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10861 fputs_filtered ("others => ", stream
);
10862 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10866 for (i
= 0; i
< nargs
-1; i
+= 1)
10869 fputs_filtered ("|", stream
);
10870 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10872 fputs_filtered (" => ", stream
);
10873 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10876 case OP_POSITIONAL
:
10877 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10881 fputs_filtered ("(", stream
);
10882 for (i
= 0; i
< nargs
; i
+= 1)
10885 fputs_filtered (", ", stream
);
10886 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10888 fputs_filtered (")", stream
);
10893 /* Table mapping opcodes into strings for printing operators
10894 and precedences of the operators. */
10896 static const struct op_print ada_op_print_tab
[] = {
10897 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
10898 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
10899 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
10900 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
10901 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
10902 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
10903 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
10904 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
10905 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
10906 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
10907 {">", BINOP_GTR
, PREC_ORDER
, 0},
10908 {"<", BINOP_LESS
, PREC_ORDER
, 0},
10909 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
10910 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
10911 {"+", BINOP_ADD
, PREC_ADD
, 0},
10912 {"-", BINOP_SUB
, PREC_ADD
, 0},
10913 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
10914 {"*", BINOP_MUL
, PREC_MUL
, 0},
10915 {"/", BINOP_DIV
, PREC_MUL
, 0},
10916 {"rem", BINOP_REM
, PREC_MUL
, 0},
10917 {"mod", BINOP_MOD
, PREC_MUL
, 0},
10918 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
10919 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
10920 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
10921 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
10922 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
10923 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
10924 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
10925 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
10926 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
10927 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
10931 enum ada_primitive_types
{
10932 ada_primitive_type_int
,
10933 ada_primitive_type_long
,
10934 ada_primitive_type_short
,
10935 ada_primitive_type_char
,
10936 ada_primitive_type_float
,
10937 ada_primitive_type_double
,
10938 ada_primitive_type_void
,
10939 ada_primitive_type_long_long
,
10940 ada_primitive_type_long_double
,
10941 ada_primitive_type_natural
,
10942 ada_primitive_type_positive
,
10943 ada_primitive_type_system_address
,
10944 nr_ada_primitive_types
10948 ada_language_arch_info (struct gdbarch
*gdbarch
,
10949 struct language_arch_info
*lai
)
10951 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
10952 lai
->primitive_type_vector
10953 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
10955 lai
->primitive_type_vector
[ada_primitive_type_int
] =
10956 init_type (TYPE_CODE_INT
,
10957 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10958 0, "integer", (struct objfile
*) NULL
);
10959 lai
->primitive_type_vector
[ada_primitive_type_long
] =
10960 init_type (TYPE_CODE_INT
,
10961 gdbarch_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10962 0, "long_integer", (struct objfile
*) NULL
);
10963 lai
->primitive_type_vector
[ada_primitive_type_short
] =
10964 init_type (TYPE_CODE_INT
,
10965 gdbarch_short_bit (gdbarch
) / TARGET_CHAR_BIT
,
10966 0, "short_integer", (struct objfile
*) NULL
);
10967 lai
->string_char_type
=
10968 lai
->primitive_type_vector
[ada_primitive_type_char
] =
10969 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10970 0, "character", (struct objfile
*) NULL
);
10971 lai
->primitive_type_vector
[ada_primitive_type_float
] =
10972 init_type (TYPE_CODE_FLT
,
10973 gdbarch_float_bit (gdbarch
)/ TARGET_CHAR_BIT
,
10974 0, "float", (struct objfile
*) NULL
);
10975 lai
->primitive_type_vector
[ada_primitive_type_double
] =
10976 init_type (TYPE_CODE_FLT
,
10977 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10978 0, "long_float", (struct objfile
*) NULL
);
10979 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
10980 init_type (TYPE_CODE_INT
,
10981 gdbarch_long_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10982 0, "long_long_integer", (struct objfile
*) NULL
);
10983 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
10984 init_type (TYPE_CODE_FLT
,
10985 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10986 0, "long_long_float", (struct objfile
*) NULL
);
10987 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
10988 init_type (TYPE_CODE_INT
,
10989 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10990 0, "natural", (struct objfile
*) NULL
);
10991 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
10992 init_type (TYPE_CODE_INT
,
10993 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10994 0, "positive", (struct objfile
*) NULL
);
10995 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
10997 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
10998 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
10999 (struct objfile
*) NULL
));
11000 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
11001 = "system__address";
11003 lai
->bool_type_symbol
= "boolean";
11004 lai
->bool_type_default
= builtin
->builtin_bool
;
11007 /* Language vector */
11009 /* Not really used, but needed in the ada_language_defn. */
11012 emit_char (int c
, struct ui_file
*stream
, int quoter
)
11014 ada_emit_char (c
, stream
, quoter
, 1);
11020 warnings_issued
= 0;
11021 return ada_parse ();
11024 static const struct exp_descriptor ada_exp_descriptor
= {
11026 ada_operator_length
,
11028 ada_dump_subexp_body
,
11029 ada_evaluate_subexp
11032 const struct language_defn ada_language_defn
= {
11033 "ada", /* Language name */
11037 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
11038 that's not quite what this means. */
11040 macro_expansion_no
,
11041 &ada_exp_descriptor
,
11045 ada_printchar
, /* Print a character constant */
11046 ada_printstr
, /* Function to print string constant */
11047 emit_char
, /* Function to print single char (not used) */
11048 ada_print_type
, /* Print a type using appropriate syntax */
11049 default_print_typedef
, /* Print a typedef using appropriate syntax */
11050 ada_val_print
, /* Print a value using appropriate syntax */
11051 ada_value_print
, /* Print a top-level value */
11052 NULL
, /* Language specific skip_trampoline */
11053 NULL
, /* name_of_this */
11054 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
11055 basic_lookup_transparent_type
, /* lookup_transparent_type */
11056 ada_la_decode
, /* Language specific symbol demangler */
11057 NULL
, /* Language specific class_name_from_physname */
11058 ada_op_print_tab
, /* expression operators for printing */
11059 0, /* c-style arrays */
11060 1, /* String lower bound */
11061 ada_get_gdb_completer_word_break_characters
,
11062 ada_make_symbol_completion_list
,
11063 ada_language_arch_info
,
11064 ada_print_array_index
,
11065 default_pass_by_reference
,
11071 _initialize_ada_language (void)
11073 add_language (&ada_language_defn
);
11075 varsize_limit
= 65536;
11077 obstack_init (&symbol_list_obstack
);
11079 decoded_names_store
= htab_create_alloc
11080 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
11081 NULL
, xcalloc
, xfree
);
11083 observer_attach_executable_changed (ada_executable_changed_observer
);