1 /* Ada language support routines for GDB, the GNU debugger. Copyright (C)
3 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005, 2007
4 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 VALUE_LVAL (result
) = VALUE_LVAL (val
);
487 set_value_bitsize (result
, value_bitsize (val
));
488 set_value_bitpos (result
, value_bitpos (val
));
489 VALUE_ADDRESS (result
) = VALUE_ADDRESS (val
) + 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 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
2022 if (VALUE_LVAL (obj
) == lval_internalvar
)
2023 VALUE_LVAL (v
) = lval_internalvar_component
;
2024 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
;
2025 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2026 set_value_bitsize (v
, bit_size
);
2027 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2029 VALUE_ADDRESS (v
) += 1;
2030 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2034 set_value_bitsize (v
, bit_size
);
2035 unpacked
= (unsigned char *) value_contents (v
);
2037 srcBitsLeft
= bit_size
;
2039 ntarg
= TYPE_LENGTH (type
);
2043 memset (unpacked
, 0, TYPE_LENGTH (type
));
2046 else if (gdbarch_bits_big_endian (current_gdbarch
))
2049 if (has_negatives (type
)
2050 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2054 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2057 switch (TYPE_CODE (type
))
2059 case TYPE_CODE_ARRAY
:
2060 case TYPE_CODE_UNION
:
2061 case TYPE_CODE_STRUCT
:
2062 /* Non-scalar values must be aligned at a byte boundary... */
2064 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2065 /* ... And are placed at the beginning (most-significant) bytes
2067 targ
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2071 targ
= TYPE_LENGTH (type
) - 1;
2077 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2080 unusedLS
= bit_offset
;
2083 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
2090 /* Mask for removing bits of the next source byte that are not
2091 part of the value. */
2092 unsigned int unusedMSMask
=
2093 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2095 /* Sign-extend bits for this byte. */
2096 unsigned int signMask
= sign
& ~unusedMSMask
;
2098 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2099 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2100 if (accumSize
>= HOST_CHAR_BIT
)
2102 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2103 accumSize
-= HOST_CHAR_BIT
;
2104 accum
>>= HOST_CHAR_BIT
;
2108 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2115 accum
|= sign
<< accumSize
;
2116 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2117 accumSize
-= HOST_CHAR_BIT
;
2118 accum
>>= HOST_CHAR_BIT
;
2126 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2127 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2130 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
2131 int src_offset
, int n
)
2133 unsigned int accum
, mask
;
2134 int accum_bits
, chunk_size
;
2136 target
+= targ_offset
/ HOST_CHAR_BIT
;
2137 targ_offset
%= HOST_CHAR_BIT
;
2138 source
+= src_offset
/ HOST_CHAR_BIT
;
2139 src_offset
%= HOST_CHAR_BIT
;
2140 if (gdbarch_bits_big_endian (current_gdbarch
))
2142 accum
= (unsigned char) *source
;
2144 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2149 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2150 accum_bits
+= HOST_CHAR_BIT
;
2152 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2155 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2156 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2159 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2161 accum_bits
-= chunk_size
;
2168 accum
= (unsigned char) *source
>> src_offset
;
2170 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2174 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2175 accum_bits
+= HOST_CHAR_BIT
;
2177 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2180 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2181 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2183 accum_bits
-= chunk_size
;
2184 accum
>>= chunk_size
;
2191 /* Store the contents of FROMVAL into the location of TOVAL.
2192 Return a new value with the location of TOVAL and contents of
2193 FROMVAL. Handles assignment into packed fields that have
2194 floating-point or non-scalar types. */
2196 static struct value
*
2197 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2199 struct type
*type
= value_type (toval
);
2200 int bits
= value_bitsize (toval
);
2202 toval
= ada_coerce_ref (toval
);
2203 fromval
= ada_coerce_ref (fromval
);
2205 if (ada_is_direct_array_type (value_type (toval
)))
2206 toval
= ada_coerce_to_simple_array (toval
);
2207 if (ada_is_direct_array_type (value_type (fromval
)))
2208 fromval
= ada_coerce_to_simple_array (fromval
);
2210 if (!deprecated_value_modifiable (toval
))
2211 error (_("Left operand of assignment is not a modifiable lvalue."));
2213 if (VALUE_LVAL (toval
) == lval_memory
2215 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2216 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2218 int len
= (value_bitpos (toval
)
2219 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2221 char *buffer
= (char *) alloca (len
);
2223 CORE_ADDR to_addr
= VALUE_ADDRESS (toval
) + value_offset (toval
);
2225 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2226 fromval
= value_cast (type
, fromval
);
2228 read_memory (to_addr
, buffer
, len
);
2229 from_size
= value_bitsize (fromval
);
2231 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2232 if (gdbarch_bits_big_endian (current_gdbarch
))
2233 move_bits (buffer
, value_bitpos (toval
),
2234 value_contents (fromval
), from_size
- bits
, bits
);
2236 move_bits (buffer
, value_bitpos (toval
), value_contents (fromval
),
2238 write_memory (to_addr
, buffer
, len
);
2239 if (deprecated_memory_changed_hook
)
2240 deprecated_memory_changed_hook (to_addr
, len
);
2242 val
= value_copy (toval
);
2243 memcpy (value_contents_raw (val
), value_contents (fromval
),
2244 TYPE_LENGTH (type
));
2245 deprecated_set_value_type (val
, type
);
2250 return value_assign (toval
, fromval
);
2254 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2255 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2256 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2257 * COMPONENT, and not the inferior's memory. The current contents
2258 * of COMPONENT are ignored. */
2260 value_assign_to_component (struct value
*container
, struct value
*component
,
2263 LONGEST offset_in_container
=
2264 (LONGEST
) (VALUE_ADDRESS (component
) + value_offset (component
)
2265 - VALUE_ADDRESS (container
) - value_offset (container
));
2266 int bit_offset_in_container
=
2267 value_bitpos (component
) - value_bitpos (container
);
2270 val
= value_cast (value_type (component
), val
);
2272 if (value_bitsize (component
) == 0)
2273 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2275 bits
= value_bitsize (component
);
2277 if (gdbarch_bits_big_endian (current_gdbarch
))
2278 move_bits (value_contents_writeable (container
) + offset_in_container
,
2279 value_bitpos (container
) + bit_offset_in_container
,
2280 value_contents (val
),
2281 TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
,
2284 move_bits (value_contents_writeable (container
) + offset_in_container
,
2285 value_bitpos (container
) + bit_offset_in_container
,
2286 value_contents (val
), 0, bits
);
2289 /* The value of the element of array ARR at the ARITY indices given in IND.
2290 ARR may be either a simple array, GNAT array descriptor, or pointer
2294 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2298 struct type
*elt_type
;
2300 elt
= ada_coerce_to_simple_array (arr
);
2302 elt_type
= ada_check_typedef (value_type (elt
));
2303 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2304 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2305 return value_subscript_packed (elt
, arity
, ind
);
2307 for (k
= 0; k
< arity
; k
+= 1)
2309 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2310 error (_("too many subscripts (%d expected)"), k
);
2311 elt
= value_subscript (elt
, value_pos_atr (builtin_type_int32
, ind
[k
]));
2316 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2317 value of the element of *ARR at the ARITY indices given in
2318 IND. Does not read the entire array into memory. */
2321 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2326 for (k
= 0; k
< arity
; k
+= 1)
2331 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2332 error (_("too many subscripts (%d expected)"), k
);
2333 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2335 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2336 idx
= value_pos_atr (builtin_type_int32
, ind
[k
]);
2338 idx
= value_binop (idx
, value_from_longest (value_type (idx
), lwb
),
2341 arr
= value_ptradd (arr
, idx
);
2342 type
= TYPE_TARGET_TYPE (type
);
2345 return value_ind (arr
);
2348 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2349 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2350 elements starting at index LOW. The lower bound of this array is LOW, as
2352 static struct value
*
2353 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2356 CORE_ADDR base
= value_as_address (array_ptr
)
2357 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2358 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2359 struct type
*index_type
=
2360 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2362 struct type
*slice_type
=
2363 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2364 return value_at_lazy (slice_type
, base
);
2368 static struct value
*
2369 ada_value_slice (struct value
*array
, int low
, int high
)
2371 struct type
*type
= value_type (array
);
2372 struct type
*index_type
=
2373 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2374 struct type
*slice_type
=
2375 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2376 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2379 /* If type is a record type in the form of a standard GNAT array
2380 descriptor, returns the number of dimensions for type. If arr is a
2381 simple array, returns the number of "array of"s that prefix its
2382 type designation. Otherwise, returns 0. */
2385 ada_array_arity (struct type
*type
)
2392 type
= desc_base_type (type
);
2395 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2396 return desc_arity (desc_bounds_type (type
));
2398 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2401 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2407 /* If TYPE is a record type in the form of a standard GNAT array
2408 descriptor or a simple array type, returns the element type for
2409 TYPE after indexing by NINDICES indices, or by all indices if
2410 NINDICES is -1. Otherwise, returns NULL. */
2413 ada_array_element_type (struct type
*type
, int nindices
)
2415 type
= desc_base_type (type
);
2417 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2420 struct type
*p_array_type
;
2422 p_array_type
= desc_data_type (type
);
2424 k
= ada_array_arity (type
);
2428 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2429 if (nindices
>= 0 && k
> nindices
)
2431 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2432 while (k
> 0 && p_array_type
!= NULL
)
2434 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2437 return p_array_type
;
2439 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2441 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2443 type
= TYPE_TARGET_TYPE (type
);
2452 /* The type of nth index in arrays of given type (n numbering from 1).
2453 Does not examine memory. */
2456 ada_index_type (struct type
*type
, int n
)
2458 struct type
*result_type
;
2460 type
= desc_base_type (type
);
2462 if (n
> ada_array_arity (type
))
2465 if (ada_is_simple_array_type (type
))
2469 for (i
= 1; i
< n
; i
+= 1)
2470 type
= TYPE_TARGET_TYPE (type
);
2471 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2472 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2473 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2474 perhaps stabsread.c would make more sense. */
2475 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2476 result_type
= builtin_type_int32
;
2481 return desc_index_type (desc_bounds_type (type
), n
);
2484 /* Given that arr is an array type, returns the lower bound of the
2485 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2486 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2487 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2488 bounds type. It works for other arrays with bounds supplied by
2489 run-time quantities other than discriminants. */
2492 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2493 struct type
** typep
)
2495 struct type
*type
, *index_type_desc
, *index_type
;
2498 gdb_assert (which
== 0 || which
== 1);
2500 if (ada_is_packed_array_type (arr_type
))
2501 arr_type
= decode_packed_array_type (arr_type
);
2503 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2506 *typep
= builtin_type_int32
;
2507 return (LONGEST
) - which
;
2510 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2511 type
= TYPE_TARGET_TYPE (arr_type
);
2515 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2516 if (index_type_desc
!= NULL
)
2517 index_type
= to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2518 NULL
, TYPE_OBJFILE (arr_type
));
2523 type
= TYPE_TARGET_TYPE (type
);
2527 index_type
= TYPE_INDEX_TYPE (type
);
2530 switch (TYPE_CODE (index_type
))
2532 case TYPE_CODE_RANGE
:
2533 retval
= which
== 0 ? TYPE_LOW_BOUND (index_type
)
2534 : TYPE_HIGH_BOUND (index_type
);
2536 case TYPE_CODE_ENUM
:
2537 retval
= which
== 0 ? TYPE_FIELD_BITPOS (index_type
, 0)
2538 : TYPE_FIELD_BITPOS (index_type
,
2539 TYPE_NFIELDS (index_type
) - 1);
2542 internal_error (__FILE__
, __LINE__
, _("invalid type code of index type"));
2546 *typep
= index_type
;
2551 /* Given that arr is an array value, returns the lower bound of the
2552 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2553 WHICH is 1. This routine will also work for arrays with bounds
2554 supplied by run-time quantities other than discriminants. */
2557 ada_array_bound (struct value
*arr
, int n
, int which
)
2559 struct type
*arr_type
= value_type (arr
);
2561 if (ada_is_packed_array_type (arr_type
))
2562 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2563 else if (ada_is_simple_array_type (arr_type
))
2566 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2567 return value_from_longest (type
, v
);
2570 return desc_one_bound (desc_bounds (arr
), n
, which
);
2573 /* Given that arr is an array value, returns the length of the
2574 nth index. This routine will also work for arrays with bounds
2575 supplied by run-time quantities other than discriminants.
2576 Does not work for arrays indexed by enumeration types with representation
2577 clauses at the moment. */
2580 ada_array_length (struct value
*arr
, int n
)
2582 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2584 if (ada_is_packed_array_type (arr_type
))
2585 return ada_array_length (decode_packed_array (arr
), n
);
2587 if (ada_is_simple_array_type (arr_type
))
2591 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2592 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2593 return value_from_longest (type
, v
);
2597 value_from_longest (builtin_type_int32
,
2598 value_as_long (desc_one_bound (desc_bounds (arr
),
2600 - value_as_long (desc_one_bound (desc_bounds (arr
),
2604 /* An empty array whose type is that of ARR_TYPE (an array type),
2605 with bounds LOW to LOW-1. */
2607 static struct value
*
2608 empty_array (struct type
*arr_type
, int low
)
2610 struct type
*index_type
=
2611 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2613 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2614 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2618 /* Name resolution */
2620 /* The "decoded" name for the user-definable Ada operator corresponding
2624 ada_decoded_op_name (enum exp_opcode op
)
2628 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2630 if (ada_opname_table
[i
].op
== op
)
2631 return ada_opname_table
[i
].decoded
;
2633 error (_("Could not find operator name for opcode"));
2637 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2638 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2639 undefined namespace) and converts operators that are
2640 user-defined into appropriate function calls. If CONTEXT_TYPE is
2641 non-null, it provides a preferred result type [at the moment, only
2642 type void has any effect---causing procedures to be preferred over
2643 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2644 return type is preferred. May change (expand) *EXP. */
2647 resolve (struct expression
**expp
, int void_context_p
)
2651 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2654 /* Resolve the operator of the subexpression beginning at
2655 position *POS of *EXPP. "Resolving" consists of replacing
2656 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2657 with their resolutions, replacing built-in operators with
2658 function calls to user-defined operators, where appropriate, and,
2659 when DEPROCEDURE_P is non-zero, converting function-valued variables
2660 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2661 are as in ada_resolve, above. */
2663 static struct value
*
2664 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2665 struct type
*context_type
)
2669 struct expression
*exp
; /* Convenience: == *expp. */
2670 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2671 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2672 int nargs
; /* Number of operands. */
2679 /* Pass one: resolve operands, saving their types and updating *pos,
2684 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2685 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2690 resolve_subexp (expp
, pos
, 0, NULL
);
2692 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2697 resolve_subexp (expp
, pos
, 0, NULL
);
2702 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2705 case OP_ATR_MODULUS
:
2715 case TERNOP_IN_RANGE
:
2716 case BINOP_IN_BOUNDS
:
2722 case OP_DISCRETE_RANGE
:
2724 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
2733 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2735 resolve_subexp (expp
, pos
, 1, NULL
);
2737 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2754 case BINOP_LOGICAL_AND
:
2755 case BINOP_LOGICAL_OR
:
2756 case BINOP_BITWISE_AND
:
2757 case BINOP_BITWISE_IOR
:
2758 case BINOP_BITWISE_XOR
:
2761 case BINOP_NOTEQUAL
:
2768 case BINOP_SUBSCRIPT
:
2776 case UNOP_LOGICAL_NOT
:
2792 case OP_INTERNALVAR
:
2802 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2805 case STRUCTOP_STRUCT
:
2806 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2819 error (_("Unexpected operator during name resolution"));
2822 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2823 for (i
= 0; i
< nargs
; i
+= 1)
2824 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2828 /* Pass two: perform any resolution on principal operator. */
2835 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2837 struct ada_symbol_info
*candidates
;
2841 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2842 (exp
->elts
[pc
+ 2].symbol
),
2843 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2846 if (n_candidates
> 1)
2848 /* Types tend to get re-introduced locally, so if there
2849 are any local symbols that are not types, first filter
2852 for (j
= 0; j
< n_candidates
; j
+= 1)
2853 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2858 case LOC_REGPARM_ADDR
:
2866 if (j
< n_candidates
)
2869 while (j
< n_candidates
)
2871 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2873 candidates
[j
] = candidates
[n_candidates
- 1];
2882 if (n_candidates
== 0)
2883 error (_("No definition found for %s"),
2884 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2885 else if (n_candidates
== 1)
2887 else if (deprocedure_p
2888 && !is_nonfunction (candidates
, n_candidates
))
2890 i
= ada_resolve_function
2891 (candidates
, n_candidates
, NULL
, 0,
2892 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2895 error (_("Could not find a match for %s"),
2896 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2900 printf_filtered (_("Multiple matches for %s\n"),
2901 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2902 user_select_syms (candidates
, n_candidates
, 1);
2906 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2907 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2908 if (innermost_block
== NULL
2909 || contained_in (candidates
[i
].block
, innermost_block
))
2910 innermost_block
= candidates
[i
].block
;
2914 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2917 replace_operator_with_call (expp
, pc
, 0, 0,
2918 exp
->elts
[pc
+ 2].symbol
,
2919 exp
->elts
[pc
+ 1].block
);
2926 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2927 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2929 struct ada_symbol_info
*candidates
;
2933 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2934 (exp
->elts
[pc
+ 5].symbol
),
2935 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2937 if (n_candidates
== 1)
2941 i
= ada_resolve_function
2942 (candidates
, n_candidates
,
2944 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2947 error (_("Could not find a match for %s"),
2948 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2951 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2952 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2953 if (innermost_block
== NULL
2954 || contained_in (candidates
[i
].block
, innermost_block
))
2955 innermost_block
= candidates
[i
].block
;
2966 case BINOP_BITWISE_AND
:
2967 case BINOP_BITWISE_IOR
:
2968 case BINOP_BITWISE_XOR
:
2970 case BINOP_NOTEQUAL
:
2978 case UNOP_LOGICAL_NOT
:
2980 if (possible_user_operator_p (op
, argvec
))
2982 struct ada_symbol_info
*candidates
;
2986 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2987 (struct block
*) NULL
, VAR_DOMAIN
,
2989 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2990 ada_decoded_op_name (op
), NULL
);
2994 replace_operator_with_call (expp
, pc
, nargs
, 1,
2995 candidates
[i
].sym
, candidates
[i
].block
);
3006 return evaluate_subexp_type (exp
, pos
);
3009 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3010 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3011 a non-pointer. A type of 'void' (which is never a valid expression type)
3012 by convention matches anything. */
3013 /* The term "match" here is rather loose. The match is heuristic and
3014 liberal. FIXME: TOO liberal, in fact. */
3017 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3019 ftype
= ada_check_typedef (ftype
);
3020 atype
= ada_check_typedef (atype
);
3022 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3023 ftype
= TYPE_TARGET_TYPE (ftype
);
3024 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3025 atype
= TYPE_TARGET_TYPE (atype
);
3027 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
3028 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
3031 switch (TYPE_CODE (ftype
))
3036 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3037 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3038 TYPE_TARGET_TYPE (atype
), 0);
3041 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3043 case TYPE_CODE_ENUM
:
3044 case TYPE_CODE_RANGE
:
3045 switch (TYPE_CODE (atype
))
3048 case TYPE_CODE_ENUM
:
3049 case TYPE_CODE_RANGE
:
3055 case TYPE_CODE_ARRAY
:
3056 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3057 || ada_is_array_descriptor_type (atype
));
3059 case TYPE_CODE_STRUCT
:
3060 if (ada_is_array_descriptor_type (ftype
))
3061 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3062 || ada_is_array_descriptor_type (atype
));
3064 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3065 && !ada_is_array_descriptor_type (atype
));
3067 case TYPE_CODE_UNION
:
3069 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3073 /* Return non-zero if the formals of FUNC "sufficiently match" the
3074 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3075 may also be an enumeral, in which case it is treated as a 0-
3076 argument function. */
3079 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3082 struct type
*func_type
= SYMBOL_TYPE (func
);
3084 if (SYMBOL_CLASS (func
) == LOC_CONST
3085 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3086 return (n_actuals
== 0);
3087 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3090 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3093 for (i
= 0; i
< n_actuals
; i
+= 1)
3095 if (actuals
[i
] == NULL
)
3099 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
3100 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3102 if (!ada_type_match (ftype
, atype
, 1))
3109 /* False iff function type FUNC_TYPE definitely does not produce a value
3110 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3111 FUNC_TYPE is not a valid function type with a non-null return type
3112 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3115 return_match (struct type
*func_type
, struct type
*context_type
)
3117 struct type
*return_type
;
3119 if (func_type
== NULL
)
3122 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3123 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
3125 return_type
= base_type (func_type
);
3126 if (return_type
== NULL
)
3129 context_type
= base_type (context_type
);
3131 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3132 return context_type
== NULL
|| return_type
== context_type
;
3133 else if (context_type
== NULL
)
3134 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3136 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3140 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3141 function (if any) that matches the types of the NARGS arguments in
3142 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3143 that returns that type, then eliminate matches that don't. If
3144 CONTEXT_TYPE is void and there is at least one match that does not
3145 return void, eliminate all matches that do.
3147 Asks the user if there is more than one match remaining. Returns -1
3148 if there is no such symbol or none is selected. NAME is used
3149 solely for messages. May re-arrange and modify SYMS in
3150 the process; the index returned is for the modified vector. */
3153 ada_resolve_function (struct ada_symbol_info syms
[],
3154 int nsyms
, struct value
**args
, int nargs
,
3155 const char *name
, struct type
*context_type
)
3158 int m
; /* Number of hits */
3159 struct type
*fallback
;
3160 struct type
*return_type
;
3162 return_type
= context_type
;
3163 if (context_type
== NULL
)
3164 fallback
= builtin_type_void
;
3171 for (k
= 0; k
< nsyms
; k
+= 1)
3173 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3175 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3176 && return_match (type
, return_type
))
3182 if (m
> 0 || return_type
== fallback
)
3185 return_type
= fallback
;
3192 printf_filtered (_("Multiple matches for %s\n"), name
);
3193 user_select_syms (syms
, m
, 1);
3199 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3200 in a listing of choices during disambiguation (see sort_choices, below).
3201 The idea is that overloadings of a subprogram name from the
3202 same package should sort in their source order. We settle for ordering
3203 such symbols by their trailing number (__N or $N). */
3206 encoded_ordered_before (char *N0
, char *N1
)
3210 else if (N0
== NULL
)
3215 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3217 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3219 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3220 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3224 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3227 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3229 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3230 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3232 return (strcmp (N0
, N1
) < 0);
3236 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3240 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3243 for (i
= 1; i
< nsyms
; i
+= 1)
3245 struct ada_symbol_info sym
= syms
[i
];
3248 for (j
= i
- 1; j
>= 0; j
-= 1)
3250 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3251 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3253 syms
[j
+ 1] = syms
[j
];
3259 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3260 by asking the user (if necessary), returning the number selected,
3261 and setting the first elements of SYMS items. Error if no symbols
3264 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3265 to be re-integrated one of these days. */
3268 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3271 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3273 int first_choice
= (max_results
== 1) ? 1 : 2;
3274 const char *select_mode
= multiple_symbols_select_mode ();
3276 if (max_results
< 1)
3277 error (_("Request to select 0 symbols!"));
3281 if (select_mode
== multiple_symbols_cancel
)
3283 canceled because the command is ambiguous\n\
3284 See set/show multiple-symbol."));
3286 /* If select_mode is "all", then return all possible symbols.
3287 Only do that if more than one symbol can be selected, of course.
3288 Otherwise, display the menu as usual. */
3289 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3292 printf_unfiltered (_("[0] cancel\n"));
3293 if (max_results
> 1)
3294 printf_unfiltered (_("[1] all\n"));
3296 sort_choices (syms
, nsyms
);
3298 for (i
= 0; i
< nsyms
; i
+= 1)
3300 if (syms
[i
].sym
== NULL
)
3303 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3305 struct symtab_and_line sal
=
3306 find_function_start_sal (syms
[i
].sym
, 1);
3307 if (sal
.symtab
== NULL
)
3308 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3310 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3313 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3314 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3315 sal
.symtab
->filename
, sal
.line
);
3321 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3322 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3323 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3324 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3326 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3327 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3329 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3330 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3331 else if (is_enumeral
3332 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3334 printf_unfiltered (("[%d] "), i
+ first_choice
);
3335 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3337 printf_unfiltered (_("'(%s) (enumeral)\n"),
3338 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3340 else if (symtab
!= NULL
)
3341 printf_unfiltered (is_enumeral
3342 ? _("[%d] %s in %s (enumeral)\n")
3343 : _("[%d] %s at %s:?\n"),
3345 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3348 printf_unfiltered (is_enumeral
3349 ? _("[%d] %s (enumeral)\n")
3350 : _("[%d] %s at ?\n"),
3352 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3356 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3359 for (i
= 0; i
< n_chosen
; i
+= 1)
3360 syms
[i
] = syms
[chosen
[i
]];
3365 /* Read and validate a set of numeric choices from the user in the
3366 range 0 .. N_CHOICES-1. Place the results in increasing
3367 order in CHOICES[0 .. N-1], and return N.
3369 The user types choices as a sequence of numbers on one line
3370 separated by blanks, encoding them as follows:
3372 + A choice of 0 means to cancel the selection, throwing an error.
3373 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3374 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3376 The user is not allowed to choose more than MAX_RESULTS values.
3378 ANNOTATION_SUFFIX, if present, is used to annotate the input
3379 prompts (for use with the -f switch). */
3382 get_selections (int *choices
, int n_choices
, int max_results
,
3383 int is_all_choice
, char *annotation_suffix
)
3388 int first_choice
= is_all_choice
? 2 : 1;
3390 prompt
= getenv ("PS2");
3394 args
= command_line_input (prompt
, 0, annotation_suffix
);
3397 error_no_arg (_("one or more choice numbers"));
3401 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3402 order, as given in args. Choices are validated. */
3408 while (isspace (*args
))
3410 if (*args
== '\0' && n_chosen
== 0)
3411 error_no_arg (_("one or more choice numbers"));
3412 else if (*args
== '\0')
3415 choice
= strtol (args
, &args2
, 10);
3416 if (args
== args2
|| choice
< 0
3417 || choice
> n_choices
+ first_choice
- 1)
3418 error (_("Argument must be choice number"));
3422 error (_("cancelled"));
3424 if (choice
< first_choice
)
3426 n_chosen
= n_choices
;
3427 for (j
= 0; j
< n_choices
; j
+= 1)
3431 choice
-= first_choice
;
3433 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3437 if (j
< 0 || choice
!= choices
[j
])
3440 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3441 choices
[k
+ 1] = choices
[k
];
3442 choices
[j
+ 1] = choice
;
3447 if (n_chosen
> max_results
)
3448 error (_("Select no more than %d of the above"), max_results
);
3453 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3454 on the function identified by SYM and BLOCK, and taking NARGS
3455 arguments. Update *EXPP as needed to hold more space. */
3458 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3459 int oplen
, struct symbol
*sym
,
3460 struct block
*block
)
3462 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3463 symbol, -oplen for operator being replaced). */
3464 struct expression
*newexp
= (struct expression
*)
3465 xmalloc (sizeof (struct expression
)
3466 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3467 struct expression
*exp
= *expp
;
3469 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3470 newexp
->language_defn
= exp
->language_defn
;
3471 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3472 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3473 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3475 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3476 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3478 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3479 newexp
->elts
[pc
+ 4].block
= block
;
3480 newexp
->elts
[pc
+ 5].symbol
= sym
;
3486 /* Type-class predicates */
3488 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3492 numeric_type_p (struct type
*type
)
3498 switch (TYPE_CODE (type
))
3503 case TYPE_CODE_RANGE
:
3504 return (type
== TYPE_TARGET_TYPE (type
)
3505 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3512 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3515 integer_type_p (struct type
*type
)
3521 switch (TYPE_CODE (type
))
3525 case TYPE_CODE_RANGE
:
3526 return (type
== TYPE_TARGET_TYPE (type
)
3527 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3534 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3537 scalar_type_p (struct type
*type
)
3543 switch (TYPE_CODE (type
))
3546 case TYPE_CODE_RANGE
:
3547 case TYPE_CODE_ENUM
:
3556 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3559 discrete_type_p (struct type
*type
)
3565 switch (TYPE_CODE (type
))
3568 case TYPE_CODE_RANGE
:
3569 case TYPE_CODE_ENUM
:
3577 /* Returns non-zero if OP with operands in the vector ARGS could be
3578 a user-defined function. Errs on the side of pre-defined operators
3579 (i.e., result 0). */
3582 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3584 struct type
*type0
=
3585 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3586 struct type
*type1
=
3587 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3601 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3605 case BINOP_BITWISE_AND
:
3606 case BINOP_BITWISE_IOR
:
3607 case BINOP_BITWISE_XOR
:
3608 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3611 case BINOP_NOTEQUAL
:
3616 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3619 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
3622 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3626 case UNOP_LOGICAL_NOT
:
3628 return (!numeric_type_p (type0
));
3637 1. In the following, we assume that a renaming type's name may
3638 have an ___XD suffix. It would be nice if this went away at some
3640 2. We handle both the (old) purely type-based representation of
3641 renamings and the (new) variable-based encoding. At some point,
3642 it is devoutly to be hoped that the former goes away
3643 (FIXME: hilfinger-2007-07-09).
3644 3. Subprogram renamings are not implemented, although the XRS
3645 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3647 /* If SYM encodes a renaming,
3649 <renaming> renames <renamed entity>,
3651 sets *LEN to the length of the renamed entity's name,
3652 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3653 the string describing the subcomponent selected from the renamed
3654 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3655 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3656 are undefined). Otherwise, returns a value indicating the category
3657 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3658 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3659 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3660 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3661 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3662 may be NULL, in which case they are not assigned.
3664 [Currently, however, GCC does not generate subprogram renamings.] */
3666 enum ada_renaming_category
3667 ada_parse_renaming (struct symbol
*sym
,
3668 const char **renamed_entity
, int *len
,
3669 const char **renaming_expr
)
3671 enum ada_renaming_category kind
;
3676 return ADA_NOT_RENAMING
;
3677 switch (SYMBOL_CLASS (sym
))
3680 return ADA_NOT_RENAMING
;
3682 return parse_old_style_renaming (SYMBOL_TYPE (sym
),
3683 renamed_entity
, len
, renaming_expr
);
3687 case LOC_OPTIMIZED_OUT
:
3688 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
3690 return ADA_NOT_RENAMING
;
3694 kind
= ADA_OBJECT_RENAMING
;
3698 kind
= ADA_EXCEPTION_RENAMING
;
3702 kind
= ADA_PACKAGE_RENAMING
;
3706 kind
= ADA_SUBPROGRAM_RENAMING
;
3710 return ADA_NOT_RENAMING
;
3714 if (renamed_entity
!= NULL
)
3715 *renamed_entity
= info
;
3716 suffix
= strstr (info
, "___XE");
3717 if (suffix
== NULL
|| suffix
== info
)
3718 return ADA_NOT_RENAMING
;
3720 *len
= strlen (info
) - strlen (suffix
);
3722 if (renaming_expr
!= NULL
)
3723 *renaming_expr
= suffix
;
3727 /* Assuming TYPE encodes a renaming according to the old encoding in
3728 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3729 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3730 ADA_NOT_RENAMING otherwise. */
3731 static enum ada_renaming_category
3732 parse_old_style_renaming (struct type
*type
,
3733 const char **renamed_entity
, int *len
,
3734 const char **renaming_expr
)
3736 enum ada_renaming_category kind
;
3741 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
3742 || TYPE_NFIELDS (type
) != 1)
3743 return ADA_NOT_RENAMING
;
3745 name
= type_name_no_tag (type
);
3747 return ADA_NOT_RENAMING
;
3749 name
= strstr (name
, "___XR");
3751 return ADA_NOT_RENAMING
;
3756 kind
= ADA_OBJECT_RENAMING
;
3759 kind
= ADA_EXCEPTION_RENAMING
;
3762 kind
= ADA_PACKAGE_RENAMING
;
3765 kind
= ADA_SUBPROGRAM_RENAMING
;
3768 return ADA_NOT_RENAMING
;
3771 info
= TYPE_FIELD_NAME (type
, 0);
3773 return ADA_NOT_RENAMING
;
3774 if (renamed_entity
!= NULL
)
3775 *renamed_entity
= info
;
3776 suffix
= strstr (info
, "___XE");
3777 if (renaming_expr
!= NULL
)
3778 *renaming_expr
= suffix
+ 5;
3779 if (suffix
== NULL
|| suffix
== info
)
3780 return ADA_NOT_RENAMING
;
3782 *len
= suffix
- info
;
3788 /* Evaluation: Function Calls */
3790 /* Return an lvalue containing the value VAL. This is the identity on
3791 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3792 on the stack, using and updating *SP as the stack pointer, and
3793 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3795 static struct value
*
3796 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3798 if (! VALUE_LVAL (val
))
3800 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3802 /* The following is taken from the structure-return code in
3803 call_function_by_hand. FIXME: Therefore, some refactoring seems
3805 if (gdbarch_inner_than (current_gdbarch
, 1, 2))
3807 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3808 reserving sufficient space. */
3810 if (gdbarch_frame_align_p (current_gdbarch
))
3811 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3812 VALUE_ADDRESS (val
) = *sp
;
3816 /* Stack grows upward. Align the frame, allocate space, and
3817 then again, re-align the frame. */
3818 if (gdbarch_frame_align_p (current_gdbarch
))
3819 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3820 VALUE_ADDRESS (val
) = *sp
;
3822 if (gdbarch_frame_align_p (current_gdbarch
))
3823 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3825 VALUE_LVAL (val
) = lval_memory
;
3827 write_memory (VALUE_ADDRESS (val
), value_contents_raw (val
), len
);
3833 /* Return the value ACTUAL, converted to be an appropriate value for a
3834 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3835 allocating any necessary descriptors (fat pointers), or copies of
3836 values not residing in memory, updating it as needed. */
3839 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
,
3842 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3843 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3844 struct type
*formal_target
=
3845 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3846 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3847 struct type
*actual_target
=
3848 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3849 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3851 if (ada_is_array_descriptor_type (formal_target
)
3852 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3853 return make_array_descriptor (formal_type
, actual
, sp
);
3854 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3855 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
3857 struct value
*result
;
3858 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3859 && ada_is_array_descriptor_type (actual_target
))
3860 result
= desc_data (actual
);
3861 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3863 if (VALUE_LVAL (actual
) != lval_memory
)
3866 actual_type
= ada_check_typedef (value_type (actual
));
3867 val
= allocate_value (actual_type
);
3868 memcpy ((char *) value_contents_raw (val
),
3869 (char *) value_contents (actual
),
3870 TYPE_LENGTH (actual_type
));
3871 actual
= ensure_lval (val
, sp
);
3873 result
= value_addr (actual
);
3877 return value_cast_pointers (formal_type
, result
);
3879 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3880 return ada_value_ind (actual
);
3886 /* Push a descriptor of type TYPE for array value ARR on the stack at
3887 *SP, updating *SP to reflect the new descriptor. Return either
3888 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3889 to-descriptor type rather than a descriptor type), a struct value *
3890 representing a pointer to this descriptor. */
3892 static struct value
*
3893 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3895 struct type
*bounds_type
= desc_bounds_type (type
);
3896 struct type
*desc_type
= desc_base_type (type
);
3897 struct value
*descriptor
= allocate_value (desc_type
);
3898 struct value
*bounds
= allocate_value (bounds_type
);
3901 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
3903 modify_general_field (value_contents_writeable (bounds
),
3904 value_as_long (ada_array_bound (arr
, i
, 0)),
3905 desc_bound_bitpos (bounds_type
, i
, 0),
3906 desc_bound_bitsize (bounds_type
, i
, 0));
3907 modify_general_field (value_contents_writeable (bounds
),
3908 value_as_long (ada_array_bound (arr
, i
, 1)),
3909 desc_bound_bitpos (bounds_type
, i
, 1),
3910 desc_bound_bitsize (bounds_type
, i
, 1));
3913 bounds
= ensure_lval (bounds
, sp
);
3915 modify_general_field (value_contents_writeable (descriptor
),
3916 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3917 fat_pntr_data_bitpos (desc_type
),
3918 fat_pntr_data_bitsize (desc_type
));
3920 modify_general_field (value_contents_writeable (descriptor
),
3921 VALUE_ADDRESS (bounds
),
3922 fat_pntr_bounds_bitpos (desc_type
),
3923 fat_pntr_bounds_bitsize (desc_type
));
3925 descriptor
= ensure_lval (descriptor
, sp
);
3927 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3928 return value_addr (descriptor
);
3933 /* Dummy definitions for an experimental caching module that is not
3934 * used in the public sources. */
3937 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3938 struct symbol
**sym
, struct block
**block
)
3944 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3945 struct block
*block
)
3951 /* Return the result of a standard (literal, C-like) lookup of NAME in
3952 given DOMAIN, visible from lexical block BLOCK. */
3954 static struct symbol
*
3955 standard_lookup (const char *name
, const struct block
*block
,
3960 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
))
3962 sym
= lookup_symbol_in_language (name
, block
, domain
, language_c
, 0);
3963 cache_symbol (name
, domain
, sym
, block_found
);
3968 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3969 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3970 since they contend in overloading in the same way. */
3972 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3976 for (i
= 0; i
< n
; i
+= 1)
3977 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3978 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3979 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3985 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3986 struct types. Otherwise, they may not. */
3989 equiv_types (struct type
*type0
, struct type
*type1
)
3993 if (type0
== NULL
|| type1
== NULL
3994 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3996 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3997 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3998 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3999 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4005 /* True iff SYM0 represents the same entity as SYM1, or one that is
4006 no more defined than that of SYM1. */
4009 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4013 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4014 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4017 switch (SYMBOL_CLASS (sym0
))
4023 struct type
*type0
= SYMBOL_TYPE (sym0
);
4024 struct type
*type1
= SYMBOL_TYPE (sym1
);
4025 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4026 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4027 int len0
= strlen (name0
);
4029 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4030 && (equiv_types (type0
, type1
)
4031 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4032 && strncmp (name1
+ len0
, "___XV", 5) == 0));
4035 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4036 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4042 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4043 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4046 add_defn_to_vec (struct obstack
*obstackp
,
4048 struct block
*block
)
4052 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
4054 /* Do not try to complete stub types, as the debugger is probably
4055 already scanning all symbols matching a certain name at the
4056 time when this function is called. Trying to replace the stub
4057 type by its associated full type will cause us to restart a scan
4058 which may lead to an infinite recursion. Instead, the client
4059 collecting the matching symbols will end up collecting several
4060 matches, with at least one of them complete. It can then filter
4061 out the stub ones if needed. */
4063 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4065 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
4067 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
4069 prevDefns
[i
].sym
= sym
;
4070 prevDefns
[i
].block
= block
;
4076 struct ada_symbol_info info
;
4080 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
4084 /* Number of ada_symbol_info structures currently collected in
4085 current vector in *OBSTACKP. */
4088 num_defns_collected (struct obstack
*obstackp
)
4090 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
4093 /* Vector of ada_symbol_info structures currently collected in current
4094 vector in *OBSTACKP. If FINISH, close off the vector and return
4095 its final address. */
4097 static struct ada_symbol_info
*
4098 defns_collected (struct obstack
*obstackp
, int finish
)
4101 return obstack_finish (obstackp
);
4103 return (struct ada_symbol_info
*) obstack_base (obstackp
);
4106 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
4107 Check the global symbols if GLOBAL, the static symbols if not.
4108 Do wild-card match if WILD. */
4110 static struct partial_symbol
*
4111 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
4112 int global
, domain_enum
namespace, int wild
)
4114 struct partial_symbol
**start
;
4115 int name_len
= strlen (name
);
4116 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
4125 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
4126 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
4130 for (i
= 0; i
< length
; i
+= 1)
4132 struct partial_symbol
*psym
= start
[i
];
4134 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4135 SYMBOL_DOMAIN (psym
), namespace)
4136 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
4150 int M
= (U
+ i
) >> 1;
4151 struct partial_symbol
*psym
= start
[M
];
4152 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
4154 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
4156 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
4167 struct partial_symbol
*psym
= start
[i
];
4169 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4170 SYMBOL_DOMAIN (psym
), namespace))
4172 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
4180 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4194 int M
= (U
+ i
) >> 1;
4195 struct partial_symbol
*psym
= start
[M
];
4196 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
4198 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
4200 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
4211 struct partial_symbol
*psym
= start
[i
];
4213 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4214 SYMBOL_DOMAIN (psym
), namespace))
4218 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
4221 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
4223 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
4233 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4243 /* Find a symbol table containing symbol SYM or NULL if none. */
4245 static struct symtab
*
4246 symtab_for_sym (struct symbol
*sym
)
4249 struct objfile
*objfile
;
4251 struct symbol
*tmp_sym
;
4252 struct dict_iterator iter
;
4255 ALL_PRIMARY_SYMTABS (objfile
, s
)
4257 switch (SYMBOL_CLASS (sym
))
4265 case LOC_CONST_BYTES
:
4266 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
4267 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4269 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
4270 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4276 switch (SYMBOL_CLASS (sym
))
4281 case LOC_REGPARM_ADDR
:
4285 for (j
= FIRST_LOCAL_BLOCK
;
4286 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
4288 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
4289 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4300 /* Return a minimal symbol matching NAME according to Ada decoding
4301 rules. Returns NULL if there is no such minimal symbol. Names
4302 prefixed with "standard__" are handled specially: "standard__" is
4303 first stripped off, and only static and global symbols are searched. */
4305 struct minimal_symbol
*
4306 ada_lookup_simple_minsym (const char *name
)
4308 struct objfile
*objfile
;
4309 struct minimal_symbol
*msymbol
;
4312 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4314 name
+= sizeof ("standard__") - 1;
4318 wild_match
= (strstr (name
, "__") == NULL
);
4320 ALL_MSYMBOLS (objfile
, msymbol
)
4322 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4323 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4330 /* For all subprograms that statically enclose the subprogram of the
4331 selected frame, add symbols matching identifier NAME in DOMAIN
4332 and their blocks to the list of data in OBSTACKP, as for
4333 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4337 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4338 const char *name
, domain_enum
namespace,
4343 /* True if TYPE is definitely an artificial type supplied to a symbol
4344 for which no debugging information was given in the symbol file. */
4347 is_nondebugging_type (struct type
*type
)
4349 char *name
= ada_type_name (type
);
4350 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4353 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4354 duplicate other symbols in the list (The only case I know of where
4355 this happens is when object files containing stabs-in-ecoff are
4356 linked with files containing ordinary ecoff debugging symbols (or no
4357 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4358 Returns the number of items in the modified list. */
4361 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4370 /* If two symbols have the same name and one of them is a stub type,
4371 the get rid of the stub. */
4373 if (TYPE_STUB (SYMBOL_TYPE (syms
[i
].sym
))
4374 && SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
)
4376 for (j
= 0; j
< nsyms
; j
++)
4379 && !TYPE_STUB (SYMBOL_TYPE (syms
[j
].sym
))
4380 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4381 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4382 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0)
4387 /* Two symbols with the same name, same class and same address
4388 should be identical. */
4390 else if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4391 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4392 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4394 for (j
= 0; j
< nsyms
; j
+= 1)
4397 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4398 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4399 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4400 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4401 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4402 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4409 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4410 syms
[j
- 1] = syms
[j
];
4419 /* Given a type that corresponds to a renaming entity, use the type name
4420 to extract the scope (package name or function name, fully qualified,
4421 and following the GNAT encoding convention) where this renaming has been
4422 defined. The string returned needs to be deallocated after use. */
4425 xget_renaming_scope (struct type
*renaming_type
)
4427 /* The renaming types adhere to the following convention:
4428 <scope>__<rename>___<XR extension>.
4429 So, to extract the scope, we search for the "___XR" extension,
4430 and then backtrack until we find the first "__". */
4432 const char *name
= type_name_no_tag (renaming_type
);
4433 char *suffix
= strstr (name
, "___XR");
4438 /* Now, backtrack a bit until we find the first "__". Start looking
4439 at suffix - 3, as the <rename> part is at least one character long. */
4441 for (last
= suffix
- 3; last
> name
; last
--)
4442 if (last
[0] == '_' && last
[1] == '_')
4445 /* Make a copy of scope and return it. */
4447 scope_len
= last
- name
;
4448 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4450 strncpy (scope
, name
, scope_len
);
4451 scope
[scope_len
] = '\0';
4456 /* Return nonzero if NAME corresponds to a package name. */
4459 is_package_name (const char *name
)
4461 /* Here, We take advantage of the fact that no symbols are generated
4462 for packages, while symbols are generated for each function.
4463 So the condition for NAME represent a package becomes equivalent
4464 to NAME not existing in our list of symbols. There is only one
4465 small complication with library-level functions (see below). */
4469 /* If it is a function that has not been defined at library level,
4470 then we should be able to look it up in the symbols. */
4471 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4474 /* Library-level function names start with "_ada_". See if function
4475 "_ada_" followed by NAME can be found. */
4477 /* Do a quick check that NAME does not contain "__", since library-level
4478 functions names cannot contain "__" in them. */
4479 if (strstr (name
, "__") != NULL
)
4482 fun_name
= xstrprintf ("_ada_%s", name
);
4484 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4487 /* Return nonzero if SYM corresponds to a renaming entity that is
4488 not visible from FUNCTION_NAME. */
4491 old_renaming_is_invisible (const struct symbol
*sym
, char *function_name
)
4495 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
4498 scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4500 make_cleanup (xfree
, scope
);
4502 /* If the rename has been defined in a package, then it is visible. */
4503 if (is_package_name (scope
))
4506 /* Check that the rename is in the current function scope by checking
4507 that its name starts with SCOPE. */
4509 /* If the function name starts with "_ada_", it means that it is
4510 a library-level function. Strip this prefix before doing the
4511 comparison, as the encoding for the renaming does not contain
4513 if (strncmp (function_name
, "_ada_", 5) == 0)
4516 return (strncmp (function_name
, scope
, strlen (scope
)) != 0);
4519 /* Remove entries from SYMS that corresponds to a renaming entity that
4520 is not visible from the function associated with CURRENT_BLOCK or
4521 that is superfluous due to the presence of more specific renaming
4522 information. Places surviving symbols in the initial entries of
4523 SYMS and returns the number of surviving symbols.
4526 First, in cases where an object renaming is implemented as a
4527 reference variable, GNAT may produce both the actual reference
4528 variable and the renaming encoding. In this case, we discard the
4531 Second, GNAT emits a type following a specified encoding for each renaming
4532 entity. Unfortunately, STABS currently does not support the definition
4533 of types that are local to a given lexical block, so all renamings types
4534 are emitted at library level. As a consequence, if an application
4535 contains two renaming entities using the same name, and a user tries to
4536 print the value of one of these entities, the result of the ada symbol
4537 lookup will also contain the wrong renaming type.
4539 This function partially covers for this limitation by attempting to
4540 remove from the SYMS list renaming symbols that should be visible
4541 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4542 method with the current information available. The implementation
4543 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4545 - When the user tries to print a rename in a function while there
4546 is another rename entity defined in a package: Normally, the
4547 rename in the function has precedence over the rename in the
4548 package, so the latter should be removed from the list. This is
4549 currently not the case.
4551 - This function will incorrectly remove valid renames if
4552 the CURRENT_BLOCK corresponds to a function which symbol name
4553 has been changed by an "Export" pragma. As a consequence,
4554 the user will be unable to print such rename entities. */
4557 remove_irrelevant_renamings (struct ada_symbol_info
*syms
,
4558 int nsyms
, const struct block
*current_block
)
4560 struct symbol
*current_function
;
4561 char *current_function_name
;
4563 int is_new_style_renaming
;
4565 /* If there is both a renaming foo___XR... encoded as a variable and
4566 a simple variable foo in the same block, discard the latter.
4567 First, zero out such symbols, then compress. */
4568 is_new_style_renaming
= 0;
4569 for (i
= 0; i
< nsyms
; i
+= 1)
4571 struct symbol
*sym
= syms
[i
].sym
;
4572 struct block
*block
= syms
[i
].block
;
4576 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
4578 name
= SYMBOL_LINKAGE_NAME (sym
);
4579 suffix
= strstr (name
, "___XR");
4583 int name_len
= suffix
- name
;
4585 is_new_style_renaming
= 1;
4586 for (j
= 0; j
< nsyms
; j
+= 1)
4587 if (i
!= j
&& syms
[j
].sym
!= NULL
4588 && strncmp (name
, SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
4590 && block
== syms
[j
].block
)
4594 if (is_new_style_renaming
)
4598 for (j
= k
= 0; j
< nsyms
; j
+= 1)
4599 if (syms
[j
].sym
!= NULL
)
4607 /* Extract the function name associated to CURRENT_BLOCK.
4608 Abort if unable to do so. */
4610 if (current_block
== NULL
)
4613 current_function
= block_linkage_function (current_block
);
4614 if (current_function
== NULL
)
4617 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4618 if (current_function_name
== NULL
)
4621 /* Check each of the symbols, and remove it from the list if it is
4622 a type corresponding to a renaming that is out of the scope of
4623 the current block. */
4628 if (ada_parse_renaming (syms
[i
].sym
, NULL
, NULL
, NULL
)
4629 == ADA_OBJECT_RENAMING
4630 && old_renaming_is_invisible (syms
[i
].sym
, current_function_name
))
4633 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4634 syms
[j
- 1] = syms
[j
];
4644 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4645 whose name and domain match NAME and DOMAIN respectively.
4646 If no match was found, then extend the search to "enclosing"
4647 routines (in other words, if we're inside a nested function,
4648 search the symbols defined inside the enclosing functions).
4650 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4653 ada_add_local_symbols (struct obstack
*obstackp
, const char *name
,
4654 struct block
*block
, domain_enum domain
,
4657 int block_depth
= 0;
4659 while (block
!= NULL
)
4662 ada_add_block_symbols (obstackp
, block
, name
, domain
, NULL
, wild_match
);
4664 /* If we found a non-function match, assume that's the one. */
4665 if (is_nonfunction (defns_collected (obstackp
, 0),
4666 num_defns_collected (obstackp
)))
4669 block
= BLOCK_SUPERBLOCK (block
);
4672 /* If no luck so far, try to find NAME as a local symbol in some lexically
4673 enclosing subprogram. */
4674 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
4675 add_symbols_from_enclosing_procs (obstackp
, name
, domain
, wild_match
);
4678 /* Add to OBSTACKP all non-local symbols whose name and domain match
4679 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
4680 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
4683 ada_add_non_local_symbols (struct obstack
*obstackp
, const char *name
,
4684 domain_enum domain
, int global
,
4687 struct objfile
*objfile
;
4688 struct partial_symtab
*ps
;
4690 ALL_PSYMTABS (objfile
, ps
)
4694 || ada_lookup_partial_symbol (ps
, name
, global
, domain
, wild_match
))
4696 struct symtab
*s
= PSYMTAB_TO_SYMTAB (ps
);
4697 const int block_kind
= global
? GLOBAL_BLOCK
: STATIC_BLOCK
;
4699 if (s
== NULL
|| !s
->primary
)
4701 ada_add_block_symbols (obstackp
,
4702 BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), block_kind
),
4703 name
, domain
, objfile
, wild_match
);
4708 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4709 scope and in global scopes, returning the number of matches. Sets
4710 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4711 indicating the symbols found and the blocks and symbol tables (if
4712 any) in which they were found. This vector are transient---good only to
4713 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4714 symbol match within the nest of blocks whose innermost member is BLOCK0,
4715 is the one match returned (no other matches in that or
4716 enclosing blocks is returned). If there are any matches in or
4717 surrounding BLOCK0, then these alone are returned. Otherwise, the
4718 search extends to global and file-scope (static) symbol tables.
4719 Names prefixed with "standard__" are handled specially: "standard__"
4720 is first stripped off, and only static and global symbols are searched. */
4723 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4724 domain_enum
namespace,
4725 struct ada_symbol_info
**results
)
4728 struct block
*block
;
4734 obstack_free (&symbol_list_obstack
, NULL
);
4735 obstack_init (&symbol_list_obstack
);
4739 /* Search specified block and its superiors. */
4741 wild_match
= (strstr (name0
, "__") == NULL
);
4743 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4744 needed, but adding const will
4745 have a cascade effect. */
4747 /* Special case: If the user specifies a symbol name inside package
4748 Standard, do a non-wild matching of the symbol name without
4749 the "standard__" prefix. This was primarily introduced in order
4750 to allow the user to specifically access the standard exceptions
4751 using, for instance, Standard.Constraint_Error when Constraint_Error
4752 is ambiguous (due to the user defining its own Constraint_Error
4753 entity inside its program). */
4754 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4758 name
= name0
+ sizeof ("standard__") - 1;
4761 /* Check the non-global symbols. If we have ANY match, then we're done. */
4763 ada_add_local_symbols (&symbol_list_obstack
, name
, block
, namespace,
4765 if (num_defns_collected (&symbol_list_obstack
) > 0)
4768 /* No non-global symbols found. Check our cache to see if we have
4769 already performed this search before. If we have, then return
4773 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
))
4776 add_defn_to_vec (&symbol_list_obstack
, sym
, block
);
4780 /* Search symbols from all global blocks. */
4782 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 1,
4785 /* Now add symbols from all per-file blocks if we've gotten no hits
4786 (not strictly correct, but perhaps better than an error). */
4788 if (num_defns_collected (&symbol_list_obstack
) == 0)
4789 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 0,
4793 ndefns
= num_defns_collected (&symbol_list_obstack
);
4794 *results
= defns_collected (&symbol_list_obstack
, 1);
4796 ndefns
= remove_extra_symbols (*results
, ndefns
);
4799 cache_symbol (name0
, namespace, NULL
, NULL
);
4801 if (ndefns
== 1 && cacheIfUnique
)
4802 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
);
4804 ndefns
= remove_irrelevant_renamings (*results
, ndefns
, block0
);
4810 ada_lookup_encoded_symbol (const char *name
, const struct block
*block0
,
4811 domain_enum
namespace, struct block
**block_found
)
4813 struct ada_symbol_info
*candidates
;
4816 n_candidates
= ada_lookup_symbol_list (name
, block0
, namespace, &candidates
);
4818 if (n_candidates
== 0)
4821 if (block_found
!= NULL
)
4822 *block_found
= candidates
[0].block
;
4824 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4827 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4828 scope and in global scopes, or NULL if none. NAME is folded and
4829 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4830 choosing the first symbol if there are multiple choices.
4831 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4832 table in which the symbol was found (in both cases, these
4833 assignments occur only if the pointers are non-null). */
4835 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4836 domain_enum
namespace, int *is_a_field_of_this
)
4838 if (is_a_field_of_this
!= NULL
)
4839 *is_a_field_of_this
= 0;
4842 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name
)),
4843 block0
, namespace, NULL
);
4846 static struct symbol
*
4847 ada_lookup_symbol_nonlocal (const char *name
,
4848 const char *linkage_name
,
4849 const struct block
*block
,
4850 const domain_enum domain
)
4852 if (linkage_name
== NULL
)
4853 linkage_name
= name
;
4854 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4859 /* True iff STR is a possible encoded suffix of a normal Ada name
4860 that is to be ignored for matching purposes. Suffixes of parallel
4861 names (e.g., XVE) are not included here. Currently, the possible suffixes
4862 are given by any of the regular expressions:
4864 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
4865 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4866 _E[0-9]+[bs]$ [protected object entry suffixes]
4867 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4869 Also, any leading "__[0-9]+" sequence is skipped before the suffix
4870 match is performed. This sequence is used to differentiate homonyms,
4871 is an optional part of a valid name suffix. */
4874 is_name_suffix (const char *str
)
4877 const char *matching
;
4878 const int len
= strlen (str
);
4880 /* Skip optional leading __[0-9]+. */
4882 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4885 while (isdigit (str
[0]))
4891 if (str
[0] == '.' || str
[0] == '$')
4894 while (isdigit (matching
[0]))
4896 if (matching
[0] == '\0')
4902 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4905 while (isdigit (matching
[0]))
4907 if (matching
[0] == '\0')
4912 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4913 with a N at the end. Unfortunately, the compiler uses the same
4914 convention for other internal types it creates. So treating
4915 all entity names that end with an "N" as a name suffix causes
4916 some regressions. For instance, consider the case of an enumerated
4917 type. To support the 'Image attribute, it creates an array whose
4919 Having a single character like this as a suffix carrying some
4920 information is a bit risky. Perhaps we should change the encoding
4921 to be something like "_N" instead. In the meantime, do not do
4922 the following check. */
4923 /* Protected Object Subprograms */
4924 if (len
== 1 && str
[0] == 'N')
4929 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
4932 while (isdigit (matching
[0]))
4934 if ((matching
[0] == 'b' || matching
[0] == 's')
4935 && matching
[1] == '\0')
4939 /* ??? We should not modify STR directly, as we are doing below. This
4940 is fine in this case, but may become problematic later if we find
4941 that this alternative did not work, and want to try matching
4942 another one from the begining of STR. Since we modified it, we
4943 won't be able to find the begining of the string anymore! */
4947 while (str
[0] != '_' && str
[0] != '\0')
4949 if (str
[0] != 'n' && str
[0] != 'b')
4955 if (str
[0] == '\000')
4960 if (str
[1] != '_' || str
[2] == '\000')
4964 if (strcmp (str
+ 3, "JM") == 0)
4966 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4967 the LJM suffix in favor of the JM one. But we will
4968 still accept LJM as a valid suffix for a reasonable
4969 amount of time, just to allow ourselves to debug programs
4970 compiled using an older version of GNAT. */
4971 if (strcmp (str
+ 3, "LJM") == 0)
4975 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4976 || str
[4] == 'U' || str
[4] == 'P')
4978 if (str
[4] == 'R' && str
[5] != 'T')
4982 if (!isdigit (str
[2]))
4984 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4985 if (!isdigit (str
[k
]) && str
[k
] != '_')
4989 if (str
[0] == '$' && isdigit (str
[1]))
4991 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4992 if (!isdigit (str
[k
]) && str
[k
] != '_')
4999 /* Return non-zero if the string starting at NAME and ending before
5000 NAME_END contains no capital letters. */
5003 is_valid_name_for_wild_match (const char *name0
)
5005 const char *decoded_name
= ada_decode (name0
);
5008 /* If the decoded name starts with an angle bracket, it means that
5009 NAME0 does not follow the GNAT encoding format. It should then
5010 not be allowed as a possible wild match. */
5011 if (decoded_name
[0] == '<')
5014 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5015 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5021 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
5022 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
5023 informational suffixes of NAME (i.e., for which is_name_suffix is
5027 wild_match (const char *patn0
, int patn_len
, const char *name0
)
5034 match
= strstr (start
, patn0
);
5039 || (match
> name0
+ 1 && match
[-1] == '_' && match
[-2] == '_')
5040 || (match
== name0
+ 5 && strncmp ("_ada_", name0
, 5) == 0))
5041 && is_name_suffix (match
+ patn_len
))
5042 return (match
== name0
|| is_valid_name_for_wild_match (name0
));
5048 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5049 vector *defn_symbols, updating the list of symbols in OBSTACKP
5050 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5051 OBJFILE is the section containing BLOCK.
5052 SYMTAB is recorded with each symbol added. */
5055 ada_add_block_symbols (struct obstack
*obstackp
,
5056 struct block
*block
, const char *name
,
5057 domain_enum domain
, struct objfile
*objfile
,
5060 struct dict_iterator iter
;
5061 int name_len
= strlen (name
);
5062 /* A matching argument symbol, if any. */
5063 struct symbol
*arg_sym
;
5064 /* Set true when we find a matching non-argument symbol. */
5073 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5075 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5076 SYMBOL_DOMAIN (sym
), domain
)
5077 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
5079 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5081 else if (SYMBOL_IS_ARGUMENT (sym
))
5086 add_defn_to_vec (obstackp
,
5087 fixup_symbol_section (sym
, objfile
),
5095 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5097 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5098 SYMBOL_DOMAIN (sym
), domain
))
5100 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
5102 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5104 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5106 if (SYMBOL_IS_ARGUMENT (sym
))
5111 add_defn_to_vec (obstackp
,
5112 fixup_symbol_section (sym
, objfile
),
5121 if (!found_sym
&& arg_sym
!= NULL
)
5123 add_defn_to_vec (obstackp
,
5124 fixup_symbol_section (arg_sym
, objfile
),
5133 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5135 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5136 SYMBOL_DOMAIN (sym
), domain
))
5140 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5143 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5145 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5150 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5152 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5154 if (SYMBOL_IS_ARGUMENT (sym
))
5159 add_defn_to_vec (obstackp
,
5160 fixup_symbol_section (sym
, objfile
),
5168 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5169 They aren't parameters, right? */
5170 if (!found_sym
&& arg_sym
!= NULL
)
5172 add_defn_to_vec (obstackp
,
5173 fixup_symbol_section (arg_sym
, objfile
),
5180 /* Symbol Completion */
5182 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5183 name in a form that's appropriate for the completion. The result
5184 does not need to be deallocated, but is only good until the next call.
5186 TEXT_LEN is equal to the length of TEXT.
5187 Perform a wild match if WILD_MATCH is set.
5188 ENCODED should be set if TEXT represents the start of a symbol name
5189 in its encoded form. */
5192 symbol_completion_match (const char *sym_name
,
5193 const char *text
, int text_len
,
5194 int wild_match
, int encoded
)
5197 const int verbatim_match
= (text
[0] == '<');
5202 /* Strip the leading angle bracket. */
5207 /* First, test against the fully qualified name of the symbol. */
5209 if (strncmp (sym_name
, text
, text_len
) == 0)
5212 if (match
&& !encoded
)
5214 /* One needed check before declaring a positive match is to verify
5215 that iff we are doing a verbatim match, the decoded version
5216 of the symbol name starts with '<'. Otherwise, this symbol name
5217 is not a suitable completion. */
5218 const char *sym_name_copy
= sym_name
;
5219 int has_angle_bracket
;
5221 sym_name
= ada_decode (sym_name
);
5222 has_angle_bracket
= (sym_name
[0] == '<');
5223 match
= (has_angle_bracket
== verbatim_match
);
5224 sym_name
= sym_name_copy
;
5227 if (match
&& !verbatim_match
)
5229 /* When doing non-verbatim match, another check that needs to
5230 be done is to verify that the potentially matching symbol name
5231 does not include capital letters, because the ada-mode would
5232 not be able to understand these symbol names without the
5233 angle bracket notation. */
5236 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
5241 /* Second: Try wild matching... */
5243 if (!match
&& wild_match
)
5245 /* Since we are doing wild matching, this means that TEXT
5246 may represent an unqualified symbol name. We therefore must
5247 also compare TEXT against the unqualified name of the symbol. */
5248 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
5250 if (strncmp (sym_name
, text
, text_len
) == 0)
5254 /* Finally: If we found a mach, prepare the result to return. */
5260 sym_name
= add_angle_brackets (sym_name
);
5263 sym_name
= ada_decode (sym_name
);
5268 typedef char *char_ptr
;
5269 DEF_VEC_P (char_ptr
);
5271 /* A companion function to ada_make_symbol_completion_list().
5272 Check if SYM_NAME represents a symbol which name would be suitable
5273 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5274 it is appended at the end of the given string vector SV.
5276 ORIG_TEXT is the string original string from the user command
5277 that needs to be completed. WORD is the entire command on which
5278 completion should be performed. These two parameters are used to
5279 determine which part of the symbol name should be added to the
5281 if WILD_MATCH is set, then wild matching is performed.
5282 ENCODED should be set if TEXT represents a symbol name in its
5283 encoded formed (in which case the completion should also be
5287 symbol_completion_add (VEC(char_ptr
) **sv
,
5288 const char *sym_name
,
5289 const char *text
, int text_len
,
5290 const char *orig_text
, const char *word
,
5291 int wild_match
, int encoded
)
5293 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
5294 wild_match
, encoded
);
5300 /* We found a match, so add the appropriate completion to the given
5303 if (word
== orig_text
)
5305 completion
= xmalloc (strlen (match
) + 5);
5306 strcpy (completion
, match
);
5308 else if (word
> orig_text
)
5310 /* Return some portion of sym_name. */
5311 completion
= xmalloc (strlen (match
) + 5);
5312 strcpy (completion
, match
+ (word
- orig_text
));
5316 /* Return some of ORIG_TEXT plus sym_name. */
5317 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
5318 strncpy (completion
, word
, orig_text
- word
);
5319 completion
[orig_text
- word
] = '\0';
5320 strcat (completion
, match
);
5323 VEC_safe_push (char_ptr
, *sv
, completion
);
5326 /* Return a list of possible symbol names completing TEXT0. The list
5327 is NULL terminated. WORD is the entire command on which completion
5331 ada_make_symbol_completion_list (char *text0
, char *word
)
5337 VEC(char_ptr
) *completions
= VEC_alloc (char_ptr
, 128);
5340 struct partial_symtab
*ps
;
5341 struct minimal_symbol
*msymbol
;
5342 struct objfile
*objfile
;
5343 struct block
*b
, *surrounding_static_block
= 0;
5345 struct dict_iterator iter
;
5347 if (text0
[0] == '<')
5349 text
= xstrdup (text0
);
5350 make_cleanup (xfree
, text
);
5351 text_len
= strlen (text
);
5357 text
= xstrdup (ada_encode (text0
));
5358 make_cleanup (xfree
, text
);
5359 text_len
= strlen (text
);
5360 for (i
= 0; i
< text_len
; i
++)
5361 text
[i
] = tolower (text
[i
]);
5363 encoded
= (strstr (text0
, "__") != NULL
);
5364 /* If the name contains a ".", then the user is entering a fully
5365 qualified entity name, and the match must not be done in wild
5366 mode. Similarly, if the user wants to complete what looks like
5367 an encoded name, the match must not be done in wild mode. */
5368 wild_match
= (strchr (text0
, '.') == NULL
&& !encoded
);
5371 /* First, look at the partial symtab symbols. */
5372 ALL_PSYMTABS (objfile
, ps
)
5374 struct partial_symbol
**psym
;
5376 /* If the psymtab's been read in we'll get it when we search
5377 through the blockvector. */
5381 for (psym
= objfile
->global_psymbols
.list
+ ps
->globals_offset
;
5382 psym
< (objfile
->global_psymbols
.list
+ ps
->globals_offset
5383 + ps
->n_global_syms
); psym
++)
5386 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (*psym
),
5387 text
, text_len
, text0
, word
,
5388 wild_match
, encoded
);
5391 for (psym
= objfile
->static_psymbols
.list
+ ps
->statics_offset
;
5392 psym
< (objfile
->static_psymbols
.list
+ ps
->statics_offset
5393 + ps
->n_static_syms
); psym
++)
5396 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (*psym
),
5397 text
, text_len
, text0
, word
,
5398 wild_match
, encoded
);
5402 /* At this point scan through the misc symbol vectors and add each
5403 symbol you find to the list. Eventually we want to ignore
5404 anything that isn't a text symbol (everything else will be
5405 handled by the psymtab code above). */
5407 ALL_MSYMBOLS (objfile
, msymbol
)
5410 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (msymbol
),
5411 text
, text_len
, text0
, word
, wild_match
, encoded
);
5414 /* Search upwards from currently selected frame (so that we can
5415 complete on local vars. */
5417 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
5419 if (!BLOCK_SUPERBLOCK (b
))
5420 surrounding_static_block
= b
; /* For elmin of dups */
5422 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5424 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5425 text
, text_len
, text0
, word
,
5426 wild_match
, encoded
);
5430 /* Go through the symtabs and check the externs and statics for
5431 symbols which match. */
5433 ALL_SYMTABS (objfile
, s
)
5436 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
5437 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5439 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5440 text
, text_len
, text0
, word
,
5441 wild_match
, encoded
);
5445 ALL_SYMTABS (objfile
, s
)
5448 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
5449 /* Don't do this block twice. */
5450 if (b
== surrounding_static_block
)
5452 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5454 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5455 text
, text_len
, text0
, word
,
5456 wild_match
, encoded
);
5460 /* Append the closing NULL entry. */
5461 VEC_safe_push (char_ptr
, completions
, NULL
);
5463 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5464 return the copy. It's unfortunate that we have to make a copy
5465 of an array that we're about to destroy, but there is nothing much
5466 we can do about it. Fortunately, it's typically not a very large
5469 const size_t completions_size
=
5470 VEC_length (char_ptr
, completions
) * sizeof (char *);
5471 char **result
= malloc (completions_size
);
5473 memcpy (result
, VEC_address (char_ptr
, completions
), completions_size
);
5475 VEC_free (char_ptr
, completions
);
5482 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5483 for tagged types. */
5486 ada_is_dispatch_table_ptr_type (struct type
*type
)
5490 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
5493 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
5497 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
5500 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5501 to be invisible to users. */
5504 ada_is_ignored_field (struct type
*type
, int field_num
)
5506 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5509 /* Check the name of that field. */
5511 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5513 /* Anonymous field names should not be printed.
5514 brobecker/2007-02-20: I don't think this can actually happen
5515 but we don't want to print the value of annonymous fields anyway. */
5519 /* A field named "_parent" is internally generated by GNAT for
5520 tagged types, and should not be printed either. */
5521 if (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0)
5525 /* If this is the dispatch table of a tagged type, then ignore. */
5526 if (ada_is_tagged_type (type
, 1)
5527 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
)))
5530 /* Not a special field, so it should not be ignored. */
5534 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5535 pointer or reference type whose ultimate target has a tag field. */
5538 ada_is_tagged_type (struct type
*type
, int refok
)
5540 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
5543 /* True iff TYPE represents the type of X'Tag */
5546 ada_is_tag_type (struct type
*type
)
5548 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
5552 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
5553 return (name
!= NULL
5554 && strcmp (name
, "ada__tags__dispatch_table") == 0);
5558 /* The type of the tag on VAL. */
5561 ada_tag_type (struct value
*val
)
5563 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
5566 /* The value of the tag on VAL. */
5569 ada_value_tag (struct value
*val
)
5571 return ada_value_struct_elt (val
, "_tag", 0);
5574 /* The value of the tag on the object of type TYPE whose contents are
5575 saved at VALADDR, if it is non-null, or is at memory address
5578 static struct value
*
5579 value_tag_from_contents_and_address (struct type
*type
,
5580 const gdb_byte
*valaddr
,
5583 int tag_byte_offset
, dummy1
, dummy2
;
5584 struct type
*tag_type
;
5585 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5588 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
5590 : valaddr
+ tag_byte_offset
);
5591 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5593 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5598 static struct type
*
5599 type_from_tag (struct value
*tag
)
5601 const char *type_name
= ada_tag_name (tag
);
5602 if (type_name
!= NULL
)
5603 return ada_find_any_type (ada_encode (type_name
));
5614 static int ada_tag_name_1 (void *);
5615 static int ada_tag_name_2 (struct tag_args
*);
5617 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5618 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5619 The value stored in ARGS->name is valid until the next call to
5623 ada_tag_name_1 (void *args0
)
5625 struct tag_args
*args
= (struct tag_args
*) args0
;
5626 static char name
[1024];
5630 val
= ada_value_struct_elt (args
->tag
, "tsd", 1);
5632 return ada_tag_name_2 (args
);
5633 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5636 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5637 for (p
= name
; *p
!= '\0'; p
+= 1)
5644 /* Utility function for ada_tag_name_1 that tries the second
5645 representation for the dispatch table (in which there is no
5646 explicit 'tsd' field in the referent of the tag pointer, and instead
5647 the tsd pointer is stored just before the dispatch table. */
5650 ada_tag_name_2 (struct tag_args
*args
)
5652 struct type
*info_type
;
5653 static char name
[1024];
5655 struct value
*val
, *valp
;
5658 info_type
= ada_find_any_type ("ada__tags__type_specific_data");
5659 if (info_type
== NULL
)
5661 info_type
= lookup_pointer_type (lookup_pointer_type (info_type
));
5662 valp
= value_cast (info_type
, args
->tag
);
5665 val
= value_ind (value_ptradd (valp
,
5666 value_from_longest (builtin_type_int8
, -1)));
5669 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5672 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5673 for (p
= name
; *p
!= '\0'; p
+= 1)
5680 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5684 ada_tag_name (struct value
*tag
)
5686 struct tag_args args
;
5687 if (!ada_is_tag_type (value_type (tag
)))
5691 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5695 /* The parent type of TYPE, or NULL if none. */
5698 ada_parent_type (struct type
*type
)
5702 type
= ada_check_typedef (type
);
5704 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5707 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5708 if (ada_is_parent_field (type
, i
))
5710 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
5712 /* If the _parent field is a pointer, then dereference it. */
5713 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
5714 parent_type
= TYPE_TARGET_TYPE (parent_type
);
5715 /* If there is a parallel XVS type, get the actual base type. */
5716 parent_type
= ada_get_base_type (parent_type
);
5718 return ada_check_typedef (parent_type
);
5724 /* True iff field number FIELD_NUM of structure type TYPE contains the
5725 parent-type (inherited) fields of a derived type. Assumes TYPE is
5726 a structure type with at least FIELD_NUM+1 fields. */
5729 ada_is_parent_field (struct type
*type
, int field_num
)
5731 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5732 return (name
!= NULL
5733 && (strncmp (name
, "PARENT", 6) == 0
5734 || strncmp (name
, "_parent", 7) == 0));
5737 /* True iff field number FIELD_NUM of structure type TYPE is a
5738 transparent wrapper field (which should be silently traversed when doing
5739 field selection and flattened when printing). Assumes TYPE is a
5740 structure type with at least FIELD_NUM+1 fields. Such fields are always
5744 ada_is_wrapper_field (struct type
*type
, int field_num
)
5746 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5747 return (name
!= NULL
5748 && (strncmp (name
, "PARENT", 6) == 0
5749 || strcmp (name
, "REP") == 0
5750 || strncmp (name
, "_parent", 7) == 0
5751 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5754 /* True iff field number FIELD_NUM of structure or union type TYPE
5755 is a variant wrapper. Assumes TYPE is a structure type with at least
5756 FIELD_NUM+1 fields. */
5759 ada_is_variant_part (struct type
*type
, int field_num
)
5761 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5762 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5763 || (is_dynamic_field (type
, field_num
)
5764 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5765 == TYPE_CODE_UNION
)));
5768 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5769 whose discriminants are contained in the record type OUTER_TYPE,
5770 returns the type of the controlling discriminant for the variant. */
5773 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5775 char *name
= ada_variant_discrim_name (var_type
);
5777 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5779 return builtin_type_int32
;
5784 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5785 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5786 represents a 'when others' clause; otherwise 0. */
5789 ada_is_others_clause (struct type
*type
, int field_num
)
5791 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5792 return (name
!= NULL
&& name
[0] == 'O');
5795 /* Assuming that TYPE0 is the type of the variant part of a record,
5796 returns the name of the discriminant controlling the variant.
5797 The value is valid until the next call to ada_variant_discrim_name. */
5800 ada_variant_discrim_name (struct type
*type0
)
5802 static char *result
= NULL
;
5803 static size_t result_len
= 0;
5806 const char *discrim_end
;
5807 const char *discrim_start
;
5809 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5810 type
= TYPE_TARGET_TYPE (type0
);
5814 name
= ada_type_name (type
);
5816 if (name
== NULL
|| name
[0] == '\000')
5819 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5822 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5825 if (discrim_end
== name
)
5828 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5831 if (discrim_start
== name
+ 1)
5833 if ((discrim_start
> name
+ 3
5834 && strncmp (discrim_start
- 3, "___", 3) == 0)
5835 || discrim_start
[-1] == '.')
5839 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5840 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5841 result
[discrim_end
- discrim_start
] = '\0';
5845 /* Scan STR for a subtype-encoded number, beginning at position K.
5846 Put the position of the character just past the number scanned in
5847 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5848 Return 1 if there was a valid number at the given position, and 0
5849 otherwise. A "subtype-encoded" number consists of the absolute value
5850 in decimal, followed by the letter 'm' to indicate a negative number.
5851 Assumes 0m does not occur. */
5854 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5858 if (!isdigit (str
[k
]))
5861 /* Do it the hard way so as not to make any assumption about
5862 the relationship of unsigned long (%lu scan format code) and
5865 while (isdigit (str
[k
]))
5867 RU
= RU
* 10 + (str
[k
] - '0');
5874 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5880 /* NOTE on the above: Technically, C does not say what the results of
5881 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5882 number representable as a LONGEST (although either would probably work
5883 in most implementations). When RU>0, the locution in the then branch
5884 above is always equivalent to the negative of RU. */
5891 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5892 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5893 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5896 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5898 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5911 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5920 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5921 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5923 if (val
>= L
&& val
<= U
)
5935 /* FIXME: Lots of redundancy below. Try to consolidate. */
5937 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5938 ARG_TYPE, extract and return the value of one of its (non-static)
5939 fields. FIELDNO says which field. Differs from value_primitive_field
5940 only in that it can handle packed values of arbitrary type. */
5942 static struct value
*
5943 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5944 struct type
*arg_type
)
5948 arg_type
= ada_check_typedef (arg_type
);
5949 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5951 /* Handle packed fields. */
5953 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5955 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5956 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5958 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
5959 offset
+ bit_pos
/ 8,
5960 bit_pos
% 8, bit_size
, type
);
5963 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5966 /* Find field with name NAME in object of type TYPE. If found,
5967 set the following for each argument that is non-null:
5968 - *FIELD_TYPE_P to the field's type;
5969 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
5970 an object of that type;
5971 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
5972 - *BIT_SIZE_P to its size in bits if the field is packed, and
5974 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
5975 fields up to but not including the desired field, or by the total
5976 number of fields if not found. A NULL value of NAME never
5977 matches; the function just counts visible fields in this case.
5979 Returns 1 if found, 0 otherwise. */
5982 find_struct_field (char *name
, struct type
*type
, int offset
,
5983 struct type
**field_type_p
,
5984 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
5989 type
= ada_check_typedef (type
);
5991 if (field_type_p
!= NULL
)
5992 *field_type_p
= NULL
;
5993 if (byte_offset_p
!= NULL
)
5995 if (bit_offset_p
!= NULL
)
5997 if (bit_size_p
!= NULL
)
6000 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6002 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6003 int fld_offset
= offset
+ bit_pos
/ 8;
6004 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6006 if (t_field_name
== NULL
)
6009 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
6011 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6012 if (field_type_p
!= NULL
)
6013 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6014 if (byte_offset_p
!= NULL
)
6015 *byte_offset_p
= fld_offset
;
6016 if (bit_offset_p
!= NULL
)
6017 *bit_offset_p
= bit_pos
% 8;
6018 if (bit_size_p
!= NULL
)
6019 *bit_size_p
= bit_size
;
6022 else if (ada_is_wrapper_field (type
, i
))
6024 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6025 field_type_p
, byte_offset_p
, bit_offset_p
,
6026 bit_size_p
, index_p
))
6029 else if (ada_is_variant_part (type
, i
))
6031 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6034 struct type
*field_type
6035 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6037 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6039 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
6041 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6042 field_type_p
, byte_offset_p
,
6043 bit_offset_p
, bit_size_p
, index_p
))
6047 else if (index_p
!= NULL
)
6053 /* Number of user-visible fields in record type TYPE. */
6056 num_visible_fields (struct type
*type
)
6060 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
6064 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6065 and search in it assuming it has (class) type TYPE.
6066 If found, return value, else return NULL.
6068 Searches recursively through wrapper fields (e.g., '_parent'). */
6070 static struct value
*
6071 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
6075 type
= ada_check_typedef (type
);
6077 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6079 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6081 if (t_field_name
== NULL
)
6084 else if (field_name_match (t_field_name
, name
))
6085 return ada_value_primitive_field (arg
, offset
, i
, type
);
6087 else if (ada_is_wrapper_field (type
, i
))
6089 struct value
*v
= /* Do not let indent join lines here. */
6090 ada_search_struct_field (name
, arg
,
6091 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6092 TYPE_FIELD_TYPE (type
, i
));
6097 else if (ada_is_variant_part (type
, i
))
6099 /* PNH: Do we ever get here? See find_struct_field. */
6101 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6102 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6104 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6106 struct value
*v
= ada_search_struct_field
/* Force line break. */
6108 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6109 TYPE_FIELD_TYPE (field_type
, j
));
6118 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
6119 int, struct type
*);
6122 /* Return field #INDEX in ARG, where the index is that returned by
6123 * find_struct_field through its INDEX_P argument. Adjust the address
6124 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6125 * If found, return value, else return NULL. */
6127 static struct value
*
6128 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
6131 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
6135 /* Auxiliary function for ada_index_struct_field. Like
6136 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6139 static struct value
*
6140 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
6144 type
= ada_check_typedef (type
);
6146 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6148 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
6150 else if (ada_is_wrapper_field (type
, i
))
6152 struct value
*v
= /* Do not let indent join lines here. */
6153 ada_index_struct_field_1 (index_p
, arg
,
6154 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6155 TYPE_FIELD_TYPE (type
, i
));
6160 else if (ada_is_variant_part (type
, i
))
6162 /* PNH: Do we ever get here? See ada_search_struct_field,
6163 find_struct_field. */
6164 error (_("Cannot assign this kind of variant record"));
6166 else if (*index_p
== 0)
6167 return ada_value_primitive_field (arg
, offset
, i
, type
);
6174 /* Given ARG, a value of type (pointer or reference to a)*
6175 structure/union, extract the component named NAME from the ultimate
6176 target structure/union and return it as a value with its
6179 The routine searches for NAME among all members of the structure itself
6180 and (recursively) among all members of any wrapper members
6183 If NO_ERR, then simply return NULL in case of error, rather than
6187 ada_value_struct_elt (struct value
*arg
, char *name
, int no_err
)
6189 struct type
*t
, *t1
;
6193 t1
= t
= ada_check_typedef (value_type (arg
));
6194 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6196 t1
= TYPE_TARGET_TYPE (t
);
6199 t1
= ada_check_typedef (t1
);
6200 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6202 arg
= coerce_ref (arg
);
6207 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6209 t1
= TYPE_TARGET_TYPE (t
);
6212 t1
= ada_check_typedef (t1
);
6213 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6215 arg
= value_ind (arg
);
6222 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
6226 v
= ada_search_struct_field (name
, arg
, 0, t
);
6229 int bit_offset
, bit_size
, byte_offset
;
6230 struct type
*field_type
;
6233 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6234 address
= value_as_address (arg
);
6236 address
= unpack_pointer (t
, value_contents (arg
));
6238 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
, 1);
6239 if (find_struct_field (name
, t1
, 0,
6240 &field_type
, &byte_offset
, &bit_offset
,
6245 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6246 arg
= ada_coerce_ref (arg
);
6248 arg
= ada_value_ind (arg
);
6249 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
6250 bit_offset
, bit_size
,
6254 v
= value_at_lazy (field_type
, address
+ byte_offset
);
6258 if (v
!= NULL
|| no_err
)
6261 error (_("There is no member named %s."), name
);
6267 error (_("Attempt to extract a component of a value that is not a record."));
6270 /* Given a type TYPE, look up the type of the component of type named NAME.
6271 If DISPP is non-null, add its byte displacement from the beginning of a
6272 structure (pointed to by a value) of type TYPE to *DISPP (does not
6273 work for packed fields).
6275 Matches any field whose name has NAME as a prefix, possibly
6278 TYPE can be either a struct or union. If REFOK, TYPE may also
6279 be a (pointer or reference)+ to a struct or union, and the
6280 ultimate target type will be searched.
6282 Looks recursively into variant clauses and parent types.
6284 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6285 TYPE is not a type of the right kind. */
6287 static struct type
*
6288 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
6289 int noerr
, int *dispp
)
6296 if (refok
&& type
!= NULL
)
6299 type
= ada_check_typedef (type
);
6300 if (TYPE_CODE (type
) != TYPE_CODE_PTR
6301 && TYPE_CODE (type
) != TYPE_CODE_REF
)
6303 type
= TYPE_TARGET_TYPE (type
);
6307 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
6308 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
6314 target_terminal_ours ();
6315 gdb_flush (gdb_stdout
);
6317 error (_("Type (null) is not a structure or union type"));
6320 /* XXX: type_sprint */
6321 fprintf_unfiltered (gdb_stderr
, _("Type "));
6322 type_print (type
, "", gdb_stderr
, -1);
6323 error (_(" is not a structure or union type"));
6328 type
= to_static_fixed_type (type
);
6330 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6332 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6336 if (t_field_name
== NULL
)
6339 else if (field_name_match (t_field_name
, name
))
6342 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
6343 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6346 else if (ada_is_wrapper_field (type
, i
))
6349 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
6354 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6359 else if (ada_is_variant_part (type
, i
))
6362 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6364 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
6366 /* FIXME pnh 2008/01/26: We check for a field that is
6367 NOT wrapped in a struct, since the compiler sometimes
6368 generates these for unchecked variant types. Revisit
6369 if the compiler changes this practice. */
6370 char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
6372 if (v_field_name
!= NULL
6373 && field_name_match (v_field_name
, name
))
6374 t
= ada_check_typedef (TYPE_FIELD_TYPE (field_type
, j
));
6376 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
6382 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6393 target_terminal_ours ();
6394 gdb_flush (gdb_stdout
);
6397 /* XXX: type_sprint */
6398 fprintf_unfiltered (gdb_stderr
, _("Type "));
6399 type_print (type
, "", gdb_stderr
, -1);
6400 error (_(" has no component named <null>"));
6404 /* XXX: type_sprint */
6405 fprintf_unfiltered (gdb_stderr
, _("Type "));
6406 type_print (type
, "", gdb_stderr
, -1);
6407 error (_(" has no component named %s"), name
);
6414 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6415 within a value of type OUTER_TYPE, return true iff VAR_TYPE
6416 represents an unchecked union (that is, the variant part of a
6417 record that is named in an Unchecked_Union pragma). */
6420 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
6422 char *discrim_name
= ada_variant_discrim_name (var_type
);
6423 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1, NULL
)
6428 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6429 within a value of type OUTER_TYPE that is stored in GDB at
6430 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6431 numbering from 0) is applicable. Returns -1 if none are. */
6434 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
6435 const gdb_byte
*outer_valaddr
)
6439 char *discrim_name
= ada_variant_discrim_name (var_type
);
6440 struct value
*outer
;
6441 struct value
*discrim
;
6442 LONGEST discrim_val
;
6444 outer
= value_from_contents_and_address (outer_type
, outer_valaddr
, 0);
6445 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
6446 if (discrim
== NULL
)
6448 discrim_val
= value_as_long (discrim
);
6451 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
6453 if (ada_is_others_clause (var_type
, i
))
6455 else if (ada_in_variant (discrim_val
, var_type
, i
))
6459 return others_clause
;
6464 /* Dynamic-Sized Records */
6466 /* Strategy: The type ostensibly attached to a value with dynamic size
6467 (i.e., a size that is not statically recorded in the debugging
6468 data) does not accurately reflect the size or layout of the value.
6469 Our strategy is to convert these values to values with accurate,
6470 conventional types that are constructed on the fly. */
6472 /* There is a subtle and tricky problem here. In general, we cannot
6473 determine the size of dynamic records without its data. However,
6474 the 'struct value' data structure, which GDB uses to represent
6475 quantities in the inferior process (the target), requires the size
6476 of the type at the time of its allocation in order to reserve space
6477 for GDB's internal copy of the data. That's why the
6478 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6479 rather than struct value*s.
6481 However, GDB's internal history variables ($1, $2, etc.) are
6482 struct value*s containing internal copies of the data that are not, in
6483 general, the same as the data at their corresponding addresses in
6484 the target. Fortunately, the types we give to these values are all
6485 conventional, fixed-size types (as per the strategy described
6486 above), so that we don't usually have to perform the
6487 'to_fixed_xxx_type' conversions to look at their values.
6488 Unfortunately, there is one exception: if one of the internal
6489 history variables is an array whose elements are unconstrained
6490 records, then we will need to create distinct fixed types for each
6491 element selected. */
6493 /* The upshot of all of this is that many routines take a (type, host
6494 address, target address) triple as arguments to represent a value.
6495 The host address, if non-null, is supposed to contain an internal
6496 copy of the relevant data; otherwise, the program is to consult the
6497 target at the target address. */
6499 /* Assuming that VAL0 represents a pointer value, the result of
6500 dereferencing it. Differs from value_ind in its treatment of
6501 dynamic-sized types. */
6504 ada_value_ind (struct value
*val0
)
6506 struct value
*val
= unwrap_value (value_ind (val0
));
6507 return ada_to_fixed_value (val
);
6510 /* The value resulting from dereferencing any "reference to"
6511 qualifiers on VAL0. */
6513 static struct value
*
6514 ada_coerce_ref (struct value
*val0
)
6516 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
6518 struct value
*val
= val0
;
6519 val
= coerce_ref (val
);
6520 val
= unwrap_value (val
);
6521 return ada_to_fixed_value (val
);
6527 /* Return OFF rounded upward if necessary to a multiple of
6528 ALIGNMENT (a power of 2). */
6531 align_value (unsigned int off
, unsigned int alignment
)
6533 return (off
+ alignment
- 1) & ~(alignment
- 1);
6536 /* Return the bit alignment required for field #F of template type TYPE. */
6539 field_alignment (struct type
*type
, int f
)
6541 const char *name
= TYPE_FIELD_NAME (type
, f
);
6545 /* The field name should never be null, unless the debugging information
6546 is somehow malformed. In this case, we assume the field does not
6547 require any alignment. */
6551 len
= strlen (name
);
6553 if (!isdigit (name
[len
- 1]))
6556 if (isdigit (name
[len
- 2]))
6557 align_offset
= len
- 2;
6559 align_offset
= len
- 1;
6561 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
6562 return TARGET_CHAR_BIT
;
6564 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
6567 /* Find a symbol named NAME. Ignores ambiguity. */
6570 ada_find_any_symbol (const char *name
)
6574 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
6575 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
6578 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
6582 /* Find a type named NAME. Ignores ambiguity. */
6585 ada_find_any_type (const char *name
)
6587 struct symbol
*sym
= ada_find_any_symbol (name
);
6590 return SYMBOL_TYPE (sym
);
6595 /* Given NAME and an associated BLOCK, search all symbols for
6596 NAME suffixed with "___XR", which is the ``renaming'' symbol
6597 associated to NAME. Return this symbol if found, return
6601 ada_find_renaming_symbol (const char *name
, struct block
*block
)
6605 sym
= find_old_style_renaming_symbol (name
, block
);
6610 /* Not right yet. FIXME pnh 7/20/2007. */
6611 sym
= ada_find_any_symbol (name
);
6612 if (sym
!= NULL
&& strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR") != NULL
)
6618 static struct symbol
*
6619 find_old_style_renaming_symbol (const char *name
, struct block
*block
)
6621 const struct symbol
*function_sym
= block_linkage_function (block
);
6624 if (function_sym
!= NULL
)
6626 /* If the symbol is defined inside a function, NAME is not fully
6627 qualified. This means we need to prepend the function name
6628 as well as adding the ``___XR'' suffix to build the name of
6629 the associated renaming symbol. */
6630 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
6631 /* Function names sometimes contain suffixes used
6632 for instance to qualify nested subprograms. When building
6633 the XR type name, we need to make sure that this suffix is
6634 not included. So do not include any suffix in the function
6635 name length below. */
6636 const int function_name_len
= ada_name_prefix_len (function_name
);
6637 const int rename_len
= function_name_len
+ 2 /* "__" */
6638 + strlen (name
) + 6 /* "___XR\0" */ ;
6640 /* Strip the suffix if necessary. */
6641 function_name
[function_name_len
] = '\0';
6643 /* Library-level functions are a special case, as GNAT adds
6644 a ``_ada_'' prefix to the function name to avoid namespace
6645 pollution. However, the renaming symbols themselves do not
6646 have this prefix, so we need to skip this prefix if present. */
6647 if (function_name_len
> 5 /* "_ada_" */
6648 && strstr (function_name
, "_ada_") == function_name
)
6649 function_name
= function_name
+ 5;
6651 rename
= (char *) alloca (rename_len
* sizeof (char));
6652 sprintf (rename
, "%s__%s___XR", function_name
, name
);
6656 const int rename_len
= strlen (name
) + 6;
6657 rename
= (char *) alloca (rename_len
* sizeof (char));
6658 sprintf (rename
, "%s___XR", name
);
6661 return ada_find_any_symbol (rename
);
6664 /* Because of GNAT encoding conventions, several GDB symbols may match a
6665 given type name. If the type denoted by TYPE0 is to be preferred to
6666 that of TYPE1 for purposes of type printing, return non-zero;
6667 otherwise return 0. */
6670 ada_prefer_type (struct type
*type0
, struct type
*type1
)
6674 else if (type0
== NULL
)
6676 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
6678 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
6680 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
6682 else if (ada_is_packed_array_type (type0
))
6684 else if (ada_is_array_descriptor_type (type0
)
6685 && !ada_is_array_descriptor_type (type1
))
6689 const char *type0_name
= type_name_no_tag (type0
);
6690 const char *type1_name
= type_name_no_tag (type1
);
6692 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
6693 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
6699 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6700 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6703 ada_type_name (struct type
*type
)
6707 else if (TYPE_NAME (type
) != NULL
)
6708 return TYPE_NAME (type
);
6710 return TYPE_TAG_NAME (type
);
6713 /* Find a parallel type to TYPE whose name is formed by appending
6714 SUFFIX to the name of TYPE. */
6717 ada_find_parallel_type (struct type
*type
, const char *suffix
)
6720 static size_t name_len
= 0;
6722 char *typename
= ada_type_name (type
);
6724 if (typename
== NULL
)
6727 len
= strlen (typename
);
6729 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
6731 strcpy (name
, typename
);
6732 strcpy (name
+ len
, suffix
);
6734 return ada_find_any_type (name
);
6738 /* If TYPE is a variable-size record type, return the corresponding template
6739 type describing its fields. Otherwise, return NULL. */
6741 static struct type
*
6742 dynamic_template_type (struct type
*type
)
6744 type
= ada_check_typedef (type
);
6746 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
6747 || ada_type_name (type
) == NULL
)
6751 int len
= strlen (ada_type_name (type
));
6752 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
6755 return ada_find_parallel_type (type
, "___XVE");
6759 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6760 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6763 is_dynamic_field (struct type
*templ_type
, int field_num
)
6765 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
6767 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
6768 && strstr (name
, "___XVL") != NULL
;
6771 /* The index of the variant field of TYPE, or -1 if TYPE does not
6772 represent a variant record type. */
6775 variant_field_index (struct type
*type
)
6779 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6782 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6784 if (ada_is_variant_part (type
, f
))
6790 /* A record type with no fields. */
6792 static struct type
*
6793 empty_record (struct objfile
*objfile
)
6795 struct type
*type
= alloc_type (objfile
);
6796 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6797 TYPE_NFIELDS (type
) = 0;
6798 TYPE_FIELDS (type
) = NULL
;
6799 INIT_CPLUS_SPECIFIC (type
);
6800 TYPE_NAME (type
) = "<empty>";
6801 TYPE_TAG_NAME (type
) = NULL
;
6802 TYPE_LENGTH (type
) = 0;
6806 /* An ordinary record type (with fixed-length fields) that describes
6807 the value of type TYPE at VALADDR or ADDRESS (see comments at
6808 the beginning of this section) VAL according to GNAT conventions.
6809 DVAL0 should describe the (portion of a) record that contains any
6810 necessary discriminants. It should be NULL if value_type (VAL) is
6811 an outer-level type (i.e., as opposed to a branch of a variant.) A
6812 variant field (unless unchecked) is replaced by a particular branch
6815 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6816 length are not statically known are discarded. As a consequence,
6817 VALADDR, ADDRESS and DVAL0 are ignored.
6819 NOTE: Limitations: For now, we assume that dynamic fields and
6820 variants occupy whole numbers of bytes. However, they need not be
6824 ada_template_to_fixed_record_type_1 (struct type
*type
,
6825 const gdb_byte
*valaddr
,
6826 CORE_ADDR address
, struct value
*dval0
,
6827 int keep_dynamic_fields
)
6829 struct value
*mark
= value_mark ();
6832 int nfields
, bit_len
;
6835 int fld_bit_len
, bit_incr
;
6838 /* Compute the number of fields in this record type that are going
6839 to be processed: unless keep_dynamic_fields, this includes only
6840 fields whose position and length are static will be processed. */
6841 if (keep_dynamic_fields
)
6842 nfields
= TYPE_NFIELDS (type
);
6846 while (nfields
< TYPE_NFIELDS (type
)
6847 && !ada_is_variant_part (type
, nfields
)
6848 && !is_dynamic_field (type
, nfields
))
6852 rtype
= alloc_type (TYPE_OBJFILE (type
));
6853 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6854 INIT_CPLUS_SPECIFIC (rtype
);
6855 TYPE_NFIELDS (rtype
) = nfields
;
6856 TYPE_FIELDS (rtype
) = (struct field
*)
6857 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6858 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6859 TYPE_NAME (rtype
) = ada_type_name (type
);
6860 TYPE_TAG_NAME (rtype
) = NULL
;
6861 TYPE_FIXED_INSTANCE (rtype
) = 1;
6867 for (f
= 0; f
< nfields
; f
+= 1)
6869 off
= align_value (off
, field_alignment (type
, f
))
6870 + TYPE_FIELD_BITPOS (type
, f
);
6871 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6872 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6874 if (ada_is_variant_part (type
, f
))
6877 fld_bit_len
= bit_incr
= 0;
6879 else if (is_dynamic_field (type
, f
))
6882 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6886 /* Get the fixed type of the field. Note that, in this case, we
6887 do not want to get the real type out of the tag: if the current
6888 field is the parent part of a tagged record, we will get the
6889 tag of the object. Clearly wrong: the real type of the parent
6890 is not the real type of the child. We would end up in an infinite
6892 TYPE_FIELD_TYPE (rtype
, f
) =
6895 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6896 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6897 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
, 0);
6898 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6899 bit_incr
= fld_bit_len
=
6900 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6904 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6905 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6906 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6907 bit_incr
= fld_bit_len
=
6908 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6910 bit_incr
= fld_bit_len
=
6911 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6913 if (off
+ fld_bit_len
> bit_len
)
6914 bit_len
= off
+ fld_bit_len
;
6916 TYPE_LENGTH (rtype
) =
6917 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6920 /* We handle the variant part, if any, at the end because of certain
6921 odd cases in which it is re-ordered so as NOT to be the last field of
6922 the record. This can happen in the presence of representation
6924 if (variant_field
>= 0)
6926 struct type
*branch_type
;
6928 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6931 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6936 to_fixed_variant_branch_type
6937 (TYPE_FIELD_TYPE (type
, variant_field
),
6938 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6939 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6940 if (branch_type
== NULL
)
6942 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6943 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6944 TYPE_NFIELDS (rtype
) -= 1;
6948 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6949 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6951 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6953 if (off
+ fld_bit_len
> bit_len
)
6954 bit_len
= off
+ fld_bit_len
;
6955 TYPE_LENGTH (rtype
) =
6956 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6960 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6961 should contain the alignment of that record, which should be a strictly
6962 positive value. If null or negative, then something is wrong, most
6963 probably in the debug info. In that case, we don't round up the size
6964 of the resulting type. If this record is not part of another structure,
6965 the current RTYPE length might be good enough for our purposes. */
6966 if (TYPE_LENGTH (type
) <= 0)
6968 if (TYPE_NAME (rtype
))
6969 warning (_("Invalid type size for `%s' detected: %d."),
6970 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
6972 warning (_("Invalid type size for <unnamed> detected: %d."),
6973 TYPE_LENGTH (type
));
6977 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
6978 TYPE_LENGTH (type
));
6981 value_free_to_mark (mark
);
6982 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6983 error (_("record type with dynamic size is larger than varsize-limit"));
6987 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6990 static struct type
*
6991 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
6992 CORE_ADDR address
, struct value
*dval0
)
6994 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
6998 /* An ordinary record type in which ___XVL-convention fields and
6999 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7000 static approximations, containing all possible fields. Uses
7001 no runtime values. Useless for use in values, but that's OK,
7002 since the results are used only for type determinations. Works on both
7003 structs and unions. Representation note: to save space, we memorize
7004 the result of this function in the TYPE_TARGET_TYPE of the
7007 static struct type
*
7008 template_to_static_fixed_type (struct type
*type0
)
7014 if (TYPE_TARGET_TYPE (type0
) != NULL
)
7015 return TYPE_TARGET_TYPE (type0
);
7017 nfields
= TYPE_NFIELDS (type0
);
7020 for (f
= 0; f
< nfields
; f
+= 1)
7022 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
7023 struct type
*new_type
;
7025 if (is_dynamic_field (type0
, f
))
7026 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
7028 new_type
= static_unwrap_type (field_type
);
7029 if (type
== type0
&& new_type
!= field_type
)
7031 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
7032 TYPE_CODE (type
) = TYPE_CODE (type0
);
7033 INIT_CPLUS_SPECIFIC (type
);
7034 TYPE_NFIELDS (type
) = nfields
;
7035 TYPE_FIELDS (type
) = (struct field
*)
7036 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
7037 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
7038 sizeof (struct field
) * nfields
);
7039 TYPE_NAME (type
) = ada_type_name (type0
);
7040 TYPE_TAG_NAME (type
) = NULL
;
7041 TYPE_FIXED_INSTANCE (type
) = 1;
7042 TYPE_LENGTH (type
) = 0;
7044 TYPE_FIELD_TYPE (type
, f
) = new_type
;
7045 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
7050 /* Given an object of type TYPE whose contents are at VALADDR and
7051 whose address in memory is ADDRESS, returns a revision of TYPE,
7052 which should be a non-dynamic-sized record, in which the variant
7053 part, if any, is replaced with the appropriate branch. Looks
7054 for discriminant values in DVAL0, which can be NULL if the record
7055 contains the necessary discriminant values. */
7057 static struct type
*
7058 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
7059 CORE_ADDR address
, struct value
*dval0
)
7061 struct value
*mark
= value_mark ();
7064 struct type
*branch_type
;
7065 int nfields
= TYPE_NFIELDS (type
);
7066 int variant_field
= variant_field_index (type
);
7068 if (variant_field
== -1)
7072 dval
= value_from_contents_and_address (type
, valaddr
, address
);
7076 rtype
= alloc_type (TYPE_OBJFILE (type
));
7077 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7078 INIT_CPLUS_SPECIFIC (rtype
);
7079 TYPE_NFIELDS (rtype
) = nfields
;
7080 TYPE_FIELDS (rtype
) =
7081 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7082 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
7083 sizeof (struct field
) * nfields
);
7084 TYPE_NAME (rtype
) = ada_type_name (type
);
7085 TYPE_TAG_NAME (rtype
) = NULL
;
7086 TYPE_FIXED_INSTANCE (rtype
) = 1;
7087 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
7089 branch_type
= to_fixed_variant_branch_type
7090 (TYPE_FIELD_TYPE (type
, variant_field
),
7091 cond_offset_host (valaddr
,
7092 TYPE_FIELD_BITPOS (type
, variant_field
)
7094 cond_offset_target (address
,
7095 TYPE_FIELD_BITPOS (type
, variant_field
)
7096 / TARGET_CHAR_BIT
), dval
);
7097 if (branch_type
== NULL
)
7100 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
7101 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7102 TYPE_NFIELDS (rtype
) -= 1;
7106 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7107 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7108 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
7109 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
7111 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
7113 value_free_to_mark (mark
);
7117 /* An ordinary record type (with fixed-length fields) that describes
7118 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7119 beginning of this section]. Any necessary discriminants' values
7120 should be in DVAL, a record value; it may be NULL if the object
7121 at ADDR itself contains any necessary discriminant values.
7122 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7123 values from the record are needed. Except in the case that DVAL,
7124 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7125 unchecked) is replaced by a particular branch of the variant.
7127 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7128 is questionable and may be removed. It can arise during the
7129 processing of an unconstrained-array-of-record type where all the
7130 variant branches have exactly the same size. This is because in
7131 such cases, the compiler does not bother to use the XVS convention
7132 when encoding the record. I am currently dubious of this
7133 shortcut and suspect the compiler should be altered. FIXME. */
7135 static struct type
*
7136 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
7137 CORE_ADDR address
, struct value
*dval
)
7139 struct type
*templ_type
;
7141 if (TYPE_FIXED_INSTANCE (type0
))
7144 templ_type
= dynamic_template_type (type0
);
7146 if (templ_type
!= NULL
)
7147 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
7148 else if (variant_field_index (type0
) >= 0)
7150 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
7152 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
7157 TYPE_FIXED_INSTANCE (type0
) = 1;
7163 /* An ordinary record type (with fixed-length fields) that describes
7164 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7165 union type. Any necessary discriminants' values should be in DVAL,
7166 a record value. That is, this routine selects the appropriate
7167 branch of the union at ADDR according to the discriminant value
7168 indicated in the union's type name. Returns VAR_TYPE0 itself if
7169 it represents a variant subject to a pragma Unchecked_Union. */
7171 static struct type
*
7172 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
7173 CORE_ADDR address
, struct value
*dval
)
7176 struct type
*templ_type
;
7177 struct type
*var_type
;
7179 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
7180 var_type
= TYPE_TARGET_TYPE (var_type0
);
7182 var_type
= var_type0
;
7184 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
7186 if (templ_type
!= NULL
)
7187 var_type
= templ_type
;
7189 if (is_unchecked_variant (var_type
, value_type (dval
)))
7192 ada_which_variant_applies (var_type
,
7193 value_type (dval
), value_contents (dval
));
7196 return empty_record (TYPE_OBJFILE (var_type
));
7197 else if (is_dynamic_field (var_type
, which
))
7198 return to_fixed_record_type
7199 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
7200 valaddr
, address
, dval
);
7201 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
7203 to_fixed_record_type
7204 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
7206 return TYPE_FIELD_TYPE (var_type
, which
);
7209 /* Assuming that TYPE0 is an array type describing the type of a value
7210 at ADDR, and that DVAL describes a record containing any
7211 discriminants used in TYPE0, returns a type for the value that
7212 contains no dynamic components (that is, no components whose sizes
7213 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7214 true, gives an error message if the resulting type's size is over
7217 static struct type
*
7218 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
7221 struct type
*index_type_desc
;
7222 struct type
*result
;
7224 if (ada_is_packed_array_type (type0
) /* revisit? */
7225 || TYPE_FIXED_INSTANCE (type0
))
7228 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
7229 if (index_type_desc
== NULL
)
7231 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
7232 /* NOTE: elt_type---the fixed version of elt_type0---should never
7233 depend on the contents of the array in properly constructed
7235 /* Create a fixed version of the array element type.
7236 We're not providing the address of an element here,
7237 and thus the actual object value cannot be inspected to do
7238 the conversion. This should not be a problem, since arrays of
7239 unconstrained objects are not allowed. In particular, all
7240 the elements of an array of a tagged type should all be of
7241 the same type specified in the debugging info. No need to
7242 consult the object tag. */
7243 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
7245 if (elt_type0
== elt_type
)
7248 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7249 elt_type
, TYPE_INDEX_TYPE (type0
));
7254 struct type
*elt_type0
;
7257 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
7258 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
7260 /* NOTE: result---the fixed version of elt_type0---should never
7261 depend on the contents of the array in properly constructed
7263 /* Create a fixed version of the array element type.
7264 We're not providing the address of an element here,
7265 and thus the actual object value cannot be inspected to do
7266 the conversion. This should not be a problem, since arrays of
7267 unconstrained objects are not allowed. In particular, all
7268 the elements of an array of a tagged type should all be of
7269 the same type specified in the debugging info. No need to
7270 consult the object tag. */
7272 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
7273 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
7275 struct type
*range_type
=
7276 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
7277 dval
, TYPE_OBJFILE (type0
));
7278 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7279 result
, range_type
);
7281 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
7282 error (_("array type with dynamic size is larger than varsize-limit"));
7285 TYPE_FIXED_INSTANCE (result
) = 1;
7290 /* A standard type (containing no dynamically sized components)
7291 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7292 DVAL describes a record containing any discriminants used in TYPE0,
7293 and may be NULL if there are none, or if the object of type TYPE at
7294 ADDRESS or in VALADDR contains these discriminants.
7296 If CHECK_TAG is not null, in the case of tagged types, this function
7297 attempts to locate the object's tag and use it to compute the actual
7298 type. However, when ADDRESS is null, we cannot use it to determine the
7299 location of the tag, and therefore compute the tagged type's actual type.
7300 So we return the tagged type without consulting the tag. */
7302 static struct type
*
7303 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
7304 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7306 type
= ada_check_typedef (type
);
7307 switch (TYPE_CODE (type
))
7311 case TYPE_CODE_STRUCT
:
7313 struct type
*static_type
= to_static_fixed_type (type
);
7314 struct type
*fixed_record_type
=
7315 to_fixed_record_type (type
, valaddr
, address
, NULL
);
7316 /* If STATIC_TYPE is a tagged type and we know the object's address,
7317 then we can determine its tag, and compute the object's actual
7318 type from there. Note that we have to use the fixed record
7319 type (the parent part of the record may have dynamic fields
7320 and the way the location of _tag is expressed may depend on
7323 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
7325 struct type
*real_type
=
7326 type_from_tag (value_tag_from_contents_and_address
7330 if (real_type
!= NULL
)
7331 return to_fixed_record_type (real_type
, valaddr
, address
, NULL
);
7334 /* Check to see if there is a parallel ___XVZ variable.
7335 If there is, then it provides the actual size of our type. */
7336 else if (ada_type_name (fixed_record_type
) != NULL
)
7338 char *name
= ada_type_name (fixed_record_type
);
7339 char *xvz_name
= alloca (strlen (name
) + 7 /* "___XVZ\0" */);
7343 sprintf (xvz_name
, "%s___XVZ", name
);
7344 size
= get_int_var_value (xvz_name
, &xvz_found
);
7345 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
7347 fixed_record_type
= copy_type (fixed_record_type
);
7348 TYPE_LENGTH (fixed_record_type
) = size
;
7350 /* The FIXED_RECORD_TYPE may have be a stub. We have
7351 observed this when the debugging info is STABS, and
7352 apparently it is something that is hard to fix.
7354 In practice, we don't need the actual type definition
7355 at all, because the presence of the XVZ variable allows us
7356 to assume that there must be a XVS type as well, which we
7357 should be able to use later, when we need the actual type
7360 In the meantime, pretend that the "fixed" type we are
7361 returning is NOT a stub, because this can cause trouble
7362 when using this type to create new types targeting it.
7363 Indeed, the associated creation routines often check
7364 whether the target type is a stub and will try to replace
7365 it, thus using a type with the wrong size. This, in turn,
7366 might cause the new type to have the wrong size too.
7367 Consider the case of an array, for instance, where the size
7368 of the array is computed from the number of elements in
7369 our array multiplied by the size of its element. */
7370 TYPE_STUB (fixed_record_type
) = 0;
7373 return fixed_record_type
;
7375 case TYPE_CODE_ARRAY
:
7376 return to_fixed_array_type (type
, dval
, 1);
7377 case TYPE_CODE_UNION
:
7381 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
7385 /* The same as ada_to_fixed_type_1, except that it preserves the type
7386 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7387 ada_to_fixed_type_1 would return the type referenced by TYPE. */
7390 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
7391 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7394 struct type
*fixed_type
=
7395 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
7397 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
7398 && TYPE_TARGET_TYPE (type
) == fixed_type
)
7404 /* A standard (static-sized) type corresponding as well as possible to
7405 TYPE0, but based on no runtime data. */
7407 static struct type
*
7408 to_static_fixed_type (struct type
*type0
)
7415 if (TYPE_FIXED_INSTANCE (type0
))
7418 type0
= ada_check_typedef (type0
);
7420 switch (TYPE_CODE (type0
))
7424 case TYPE_CODE_STRUCT
:
7425 type
= dynamic_template_type (type0
);
7427 return template_to_static_fixed_type (type
);
7429 return template_to_static_fixed_type (type0
);
7430 case TYPE_CODE_UNION
:
7431 type
= ada_find_parallel_type (type0
, "___XVU");
7433 return template_to_static_fixed_type (type
);
7435 return template_to_static_fixed_type (type0
);
7439 /* A static approximation of TYPE with all type wrappers removed. */
7441 static struct type
*
7442 static_unwrap_type (struct type
*type
)
7444 if (ada_is_aligner_type (type
))
7446 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
7447 if (ada_type_name (type1
) == NULL
)
7448 TYPE_NAME (type1
) = ada_type_name (type
);
7450 return static_unwrap_type (type1
);
7454 struct type
*raw_real_type
= ada_get_base_type (type
);
7455 if (raw_real_type
== type
)
7458 return to_static_fixed_type (raw_real_type
);
7462 /* In some cases, incomplete and private types require
7463 cross-references that are not resolved as records (for example,
7465 type FooP is access Foo;
7467 type Foo is array ...;
7468 ). In these cases, since there is no mechanism for producing
7469 cross-references to such types, we instead substitute for FooP a
7470 stub enumeration type that is nowhere resolved, and whose tag is
7471 the name of the actual type. Call these types "non-record stubs". */
7473 /* A type equivalent to TYPE that is not a non-record stub, if one
7474 exists, otherwise TYPE. */
7477 ada_check_typedef (struct type
*type
)
7482 CHECK_TYPEDEF (type
);
7483 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
7484 || !TYPE_STUB (type
)
7485 || TYPE_TAG_NAME (type
) == NULL
)
7489 char *name
= TYPE_TAG_NAME (type
);
7490 struct type
*type1
= ada_find_any_type (name
);
7491 return (type1
== NULL
) ? type
: type1
;
7495 /* A value representing the data at VALADDR/ADDRESS as described by
7496 type TYPE0, but with a standard (static-sized) type that correctly
7497 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7498 type, then return VAL0 [this feature is simply to avoid redundant
7499 creation of struct values]. */
7501 static struct value
*
7502 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
7505 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
7506 if (type
== type0
&& val0
!= NULL
)
7509 return value_from_contents_and_address (type
, 0, address
);
7512 /* A value representing VAL, but with a standard (static-sized) type
7513 that correctly describes it. Does not necessarily create a new
7516 static struct value
*
7517 ada_to_fixed_value (struct value
*val
)
7519 return ada_to_fixed_value_create (value_type (val
),
7520 VALUE_ADDRESS (val
) + value_offset (val
),
7524 /* A value representing VAL, but with a standard (static-sized) type
7525 chosen to approximate the real type of VAL as well as possible, but
7526 without consulting any runtime values. For Ada dynamic-sized
7527 types, therefore, the type of the result is likely to be inaccurate. */
7530 ada_to_static_fixed_value (struct value
*val
)
7533 to_static_fixed_type (static_unwrap_type (value_type (val
)));
7534 if (type
== value_type (val
))
7537 return coerce_unspec_val_to_type (val
, type
);
7543 /* Table mapping attribute numbers to names.
7544 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7546 static const char *attribute_names
[] = {
7564 ada_attribute_name (enum exp_opcode n
)
7566 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
7567 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
7569 return attribute_names
[0];
7572 /* Evaluate the 'POS attribute applied to ARG. */
7575 pos_atr (struct value
*arg
)
7577 struct value
*val
= coerce_ref (arg
);
7578 struct type
*type
= value_type (val
);
7580 if (!discrete_type_p (type
))
7581 error (_("'POS only defined on discrete types"));
7583 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7586 LONGEST v
= value_as_long (val
);
7588 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7590 if (v
== TYPE_FIELD_BITPOS (type
, i
))
7593 error (_("enumeration value is invalid: can't find 'POS"));
7596 return value_as_long (val
);
7599 static struct value
*
7600 value_pos_atr (struct type
*type
, struct value
*arg
)
7602 return value_from_longest (type
, pos_atr (arg
));
7605 /* Evaluate the TYPE'VAL attribute applied to ARG. */
7607 static struct value
*
7608 value_val_atr (struct type
*type
, struct value
*arg
)
7610 if (!discrete_type_p (type
))
7611 error (_("'VAL only defined on discrete types"));
7612 if (!integer_type_p (value_type (arg
)))
7613 error (_("'VAL requires integral argument"));
7615 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7617 long pos
= value_as_long (arg
);
7618 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
7619 error (_("argument to 'VAL out of range"));
7620 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
7623 return value_from_longest (type
, value_as_long (arg
));
7629 /* True if TYPE appears to be an Ada character type.
7630 [At the moment, this is true only for Character and Wide_Character;
7631 It is a heuristic test that could stand improvement]. */
7634 ada_is_character_type (struct type
*type
)
7638 /* If the type code says it's a character, then assume it really is,
7639 and don't check any further. */
7640 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
7643 /* Otherwise, assume it's a character type iff it is a discrete type
7644 with a known character type name. */
7645 name
= ada_type_name (type
);
7646 return (name
!= NULL
7647 && (TYPE_CODE (type
) == TYPE_CODE_INT
7648 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7649 && (strcmp (name
, "character") == 0
7650 || strcmp (name
, "wide_character") == 0
7651 || strcmp (name
, "wide_wide_character") == 0
7652 || strcmp (name
, "unsigned char") == 0));
7655 /* True if TYPE appears to be an Ada string type. */
7658 ada_is_string_type (struct type
*type
)
7660 type
= ada_check_typedef (type
);
7662 && TYPE_CODE (type
) != TYPE_CODE_PTR
7663 && (ada_is_simple_array_type (type
)
7664 || ada_is_array_descriptor_type (type
))
7665 && ada_array_arity (type
) == 1)
7667 struct type
*elttype
= ada_array_element_type (type
, 1);
7669 return ada_is_character_type (elttype
);
7676 /* True if TYPE is a struct type introduced by the compiler to force the
7677 alignment of a value. Such types have a single field with a
7678 distinctive name. */
7681 ada_is_aligner_type (struct type
*type
)
7683 type
= ada_check_typedef (type
);
7685 /* If we can find a parallel XVS type, then the XVS type should
7686 be used instead of this type. And hence, this is not an aligner
7688 if (ada_find_parallel_type (type
, "___XVS") != NULL
)
7691 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
7692 && TYPE_NFIELDS (type
) == 1
7693 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
7696 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7697 the parallel type. */
7700 ada_get_base_type (struct type
*raw_type
)
7702 struct type
*real_type_namer
;
7703 struct type
*raw_real_type
;
7705 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
7708 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
7709 if (real_type_namer
== NULL
7710 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
7711 || TYPE_NFIELDS (real_type_namer
) != 1)
7714 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
7715 if (raw_real_type
== NULL
)
7718 return raw_real_type
;
7721 /* The type of value designated by TYPE, with all aligners removed. */
7724 ada_aligned_type (struct type
*type
)
7726 if (ada_is_aligner_type (type
))
7727 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
7729 return ada_get_base_type (type
);
7733 /* The address of the aligned value in an object at address VALADDR
7734 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7737 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
7739 if (ada_is_aligner_type (type
))
7740 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
7742 TYPE_FIELD_BITPOS (type
,
7743 0) / TARGET_CHAR_BIT
);
7750 /* The printed representation of an enumeration literal with encoded
7751 name NAME. The value is good to the next call of ada_enum_name. */
7753 ada_enum_name (const char *name
)
7755 static char *result
;
7756 static size_t result_len
= 0;
7759 /* First, unqualify the enumeration name:
7760 1. Search for the last '.' character. If we find one, then skip
7761 all the preceeding characters, the unqualified name starts
7762 right after that dot.
7763 2. Otherwise, we may be debugging on a target where the compiler
7764 translates dots into "__". Search forward for double underscores,
7765 but stop searching when we hit an overloading suffix, which is
7766 of the form "__" followed by digits. */
7768 tmp
= strrchr (name
, '.');
7773 while ((tmp
= strstr (name
, "__")) != NULL
)
7775 if (isdigit (tmp
[2]))
7785 if (name
[1] == 'U' || name
[1] == 'W')
7787 if (sscanf (name
+ 2, "%x", &v
) != 1)
7793 GROW_VECT (result
, result_len
, 16);
7794 if (isascii (v
) && isprint (v
))
7795 sprintf (result
, "'%c'", v
);
7796 else if (name
[1] == 'U')
7797 sprintf (result
, "[\"%02x\"]", v
);
7799 sprintf (result
, "[\"%04x\"]", v
);
7805 tmp
= strstr (name
, "__");
7807 tmp
= strstr (name
, "$");
7810 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
7811 strncpy (result
, name
, tmp
- name
);
7812 result
[tmp
- name
] = '\0';
7820 static struct value
*
7821 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
7824 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7825 (expect_type
, exp
, pos
, noside
);
7828 /* Evaluate the subexpression of EXP starting at *POS as for
7829 evaluate_type, updating *POS to point just past the evaluated
7832 static struct value
*
7833 evaluate_subexp_type (struct expression
*exp
, int *pos
)
7835 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7836 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
7839 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7842 static struct value
*
7843 unwrap_value (struct value
*val
)
7845 struct type
*type
= ada_check_typedef (value_type (val
));
7846 if (ada_is_aligner_type (type
))
7848 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
7849 struct type
*val_type
= ada_check_typedef (value_type (v
));
7850 if (ada_type_name (val_type
) == NULL
)
7851 TYPE_NAME (val_type
) = ada_type_name (type
);
7853 return unwrap_value (v
);
7857 struct type
*raw_real_type
=
7858 ada_check_typedef (ada_get_base_type (type
));
7860 if (type
== raw_real_type
)
7864 coerce_unspec_val_to_type
7865 (val
, ada_to_fixed_type (raw_real_type
, 0,
7866 VALUE_ADDRESS (val
) + value_offset (val
),
7871 static struct value
*
7872 cast_to_fixed (struct type
*type
, struct value
*arg
)
7876 if (type
== value_type (arg
))
7878 else if (ada_is_fixed_point_type (value_type (arg
)))
7879 val
= ada_float_to_fixed (type
,
7880 ada_fixed_to_float (value_type (arg
),
7881 value_as_long (arg
)));
7884 DOUBLEST argd
= value_as_double (arg
);
7885 val
= ada_float_to_fixed (type
, argd
);
7888 return value_from_longest (type
, val
);
7891 static struct value
*
7892 cast_from_fixed (struct type
*type
, struct value
*arg
)
7894 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
7895 value_as_long (arg
));
7896 return value_from_double (type
, val
);
7899 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7900 return the converted value. */
7902 static struct value
*
7903 coerce_for_assign (struct type
*type
, struct value
*val
)
7905 struct type
*type2
= value_type (val
);
7909 type2
= ada_check_typedef (type2
);
7910 type
= ada_check_typedef (type
);
7912 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
7913 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7915 val
= ada_value_ind (val
);
7916 type2
= value_type (val
);
7919 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
7920 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7922 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
7923 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
7924 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
7925 error (_("Incompatible types in assignment"));
7926 deprecated_set_value_type (val
, type
);
7931 static struct value
*
7932 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
7935 struct type
*type1
, *type2
;
7938 arg1
= coerce_ref (arg1
);
7939 arg2
= coerce_ref (arg2
);
7940 type1
= base_type (ada_check_typedef (value_type (arg1
)));
7941 type2
= base_type (ada_check_typedef (value_type (arg2
)));
7943 if (TYPE_CODE (type1
) != TYPE_CODE_INT
7944 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
7945 return value_binop (arg1
, arg2
, op
);
7954 return value_binop (arg1
, arg2
, op
);
7957 v2
= value_as_long (arg2
);
7959 error (_("second operand of %s must not be zero."), op_string (op
));
7961 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7962 return value_binop (arg1
, arg2
, op
);
7964 v1
= value_as_long (arg1
);
7969 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7970 v
+= v
> 0 ? -1 : 1;
7978 /* Should not reach this point. */
7982 val
= allocate_value (type1
);
7983 store_unsigned_integer (value_contents_raw (val
),
7984 TYPE_LENGTH (value_type (val
)), v
);
7989 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7991 if (ada_is_direct_array_type (value_type (arg1
))
7992 || ada_is_direct_array_type (value_type (arg2
)))
7994 /* Automatically dereference any array reference before
7995 we attempt to perform the comparison. */
7996 arg1
= ada_coerce_ref (arg1
);
7997 arg2
= ada_coerce_ref (arg2
);
7999 arg1
= ada_coerce_to_simple_array (arg1
);
8000 arg2
= ada_coerce_to_simple_array (arg2
);
8001 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
8002 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
8003 error (_("Attempt to compare array with non-array"));
8004 /* FIXME: The following works only for types whose
8005 representations use all bits (no padding or undefined bits)
8006 and do not have user-defined equality. */
8008 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
8009 && memcmp (value_contents (arg1
), value_contents (arg2
),
8010 TYPE_LENGTH (value_type (arg1
))) == 0;
8012 return value_equal (arg1
, arg2
);
8015 /* Total number of component associations in the aggregate starting at
8016 index PC in EXP. Assumes that index PC is the start of an
8020 num_component_specs (struct expression
*exp
, int pc
)
8023 m
= exp
->elts
[pc
+ 1].longconst
;
8026 for (i
= 0; i
< m
; i
+= 1)
8028 switch (exp
->elts
[pc
].opcode
)
8034 n
+= exp
->elts
[pc
+ 1].longconst
;
8037 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
8042 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
8043 component of LHS (a simple array or a record), updating *POS past
8044 the expression, assuming that LHS is contained in CONTAINER. Does
8045 not modify the inferior's memory, nor does it modify LHS (unless
8046 LHS == CONTAINER). */
8049 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
8050 struct expression
*exp
, int *pos
)
8052 struct value
*mark
= value_mark ();
8054 if (TYPE_CODE (value_type (lhs
)) == TYPE_CODE_ARRAY
)
8056 struct value
*index_val
= value_from_longest (builtin_type_int32
, index
);
8057 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
8061 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
8062 elt
= ada_to_fixed_value (unwrap_value (elt
));
8065 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8066 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
8068 value_assign_to_component (container
, elt
,
8069 ada_evaluate_subexp (NULL
, exp
, pos
,
8072 value_free_to_mark (mark
);
8075 /* Assuming that LHS represents an lvalue having a record or array
8076 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8077 of that aggregate's value to LHS, advancing *POS past the
8078 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8079 lvalue containing LHS (possibly LHS itself). Does not modify
8080 the inferior's memory, nor does it modify the contents of
8081 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
8083 static struct value
*
8084 assign_aggregate (struct value
*container
,
8085 struct value
*lhs
, struct expression
*exp
,
8086 int *pos
, enum noside noside
)
8088 struct type
*lhs_type
;
8089 int n
= exp
->elts
[*pos
+1].longconst
;
8090 LONGEST low_index
, high_index
;
8093 int max_indices
, num_indices
;
8094 int is_array_aggregate
;
8096 struct value
*mark
= value_mark ();
8099 if (noside
!= EVAL_NORMAL
)
8102 for (i
= 0; i
< n
; i
+= 1)
8103 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
8107 container
= ada_coerce_ref (container
);
8108 if (ada_is_direct_array_type (value_type (container
)))
8109 container
= ada_coerce_to_simple_array (container
);
8110 lhs
= ada_coerce_ref (lhs
);
8111 if (!deprecated_value_modifiable (lhs
))
8112 error (_("Left operand of assignment is not a modifiable lvalue."));
8114 lhs_type
= value_type (lhs
);
8115 if (ada_is_direct_array_type (lhs_type
))
8117 lhs
= ada_coerce_to_simple_array (lhs
);
8118 lhs_type
= value_type (lhs
);
8119 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
8120 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
8121 is_array_aggregate
= 1;
8123 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
8126 high_index
= num_visible_fields (lhs_type
) - 1;
8127 is_array_aggregate
= 0;
8130 error (_("Left-hand side must be array or record."));
8132 num_specs
= num_component_specs (exp
, *pos
- 3);
8133 max_indices
= 4 * num_specs
+ 4;
8134 indices
= alloca (max_indices
* sizeof (indices
[0]));
8135 indices
[0] = indices
[1] = low_index
- 1;
8136 indices
[2] = indices
[3] = high_index
+ 1;
8139 for (i
= 0; i
< n
; i
+= 1)
8141 switch (exp
->elts
[*pos
].opcode
)
8144 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
8145 &num_indices
, max_indices
,
8146 low_index
, high_index
);
8149 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
8150 &num_indices
, max_indices
,
8151 low_index
, high_index
);
8155 error (_("Misplaced 'others' clause"));
8156 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
8157 num_indices
, low_index
, high_index
);
8160 error (_("Internal error: bad aggregate clause"));
8167 /* Assign into the component of LHS indexed by the OP_POSITIONAL
8168 construct at *POS, updating *POS past the construct, given that
8169 the positions are relative to lower bound LOW, where HIGH is the
8170 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8171 updating *NUM_INDICES as needed. CONTAINER is as for
8172 assign_aggregate. */
8174 aggregate_assign_positional (struct value
*container
,
8175 struct value
*lhs
, struct expression
*exp
,
8176 int *pos
, LONGEST
*indices
, int *num_indices
,
8177 int max_indices
, LONGEST low
, LONGEST high
)
8179 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
8181 if (ind
- 1 == high
)
8182 warning (_("Extra components in aggregate ignored."));
8185 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
8187 assign_component (container
, lhs
, ind
, exp
, pos
);
8190 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8193 /* Assign into the components of LHS indexed by the OP_CHOICES
8194 construct at *POS, updating *POS past the construct, given that
8195 the allowable indices are LOW..HIGH. Record the indices assigned
8196 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8197 needed. CONTAINER is as for assign_aggregate. */
8199 aggregate_assign_from_choices (struct value
*container
,
8200 struct value
*lhs
, struct expression
*exp
,
8201 int *pos
, LONGEST
*indices
, int *num_indices
,
8202 int max_indices
, LONGEST low
, LONGEST high
)
8205 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
8206 int choice_pos
, expr_pc
;
8207 int is_array
= ada_is_direct_array_type (value_type (lhs
));
8209 choice_pos
= *pos
+= 3;
8211 for (j
= 0; j
< n_choices
; j
+= 1)
8212 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8214 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8216 for (j
= 0; j
< n_choices
; j
+= 1)
8218 LONGEST lower
, upper
;
8219 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
8220 if (op
== OP_DISCRETE_RANGE
)
8223 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8225 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8230 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
8241 name
= &exp
->elts
[choice_pos
+ 2].string
;
8244 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
8247 error (_("Invalid record component association."));
8249 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
8251 if (! find_struct_field (name
, value_type (lhs
), 0,
8252 NULL
, NULL
, NULL
, NULL
, &ind
))
8253 error (_("Unknown component name: %s."), name
);
8254 lower
= upper
= ind
;
8257 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
8258 error (_("Index in component association out of bounds."));
8260 add_component_interval (lower
, upper
, indices
, num_indices
,
8262 while (lower
<= upper
)
8266 assign_component (container
, lhs
, lower
, exp
, &pos1
);
8272 /* Assign the value of the expression in the OP_OTHERS construct in
8273 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8274 have not been previously assigned. The index intervals already assigned
8275 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8276 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
8278 aggregate_assign_others (struct value
*container
,
8279 struct value
*lhs
, struct expression
*exp
,
8280 int *pos
, LONGEST
*indices
, int num_indices
,
8281 LONGEST low
, LONGEST high
)
8284 int expr_pc
= *pos
+1;
8286 for (i
= 0; i
< num_indices
- 2; i
+= 2)
8289 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
8293 assign_component (container
, lhs
, ind
, exp
, &pos
);
8296 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8299 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
8300 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8301 modifying *SIZE as needed. It is an error if *SIZE exceeds
8302 MAX_SIZE. The resulting intervals do not overlap. */
8304 add_component_interval (LONGEST low
, LONGEST high
,
8305 LONGEST
* indices
, int *size
, int max_size
)
8308 for (i
= 0; i
< *size
; i
+= 2) {
8309 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
8312 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
8313 if (high
< indices
[kh
])
8315 if (low
< indices
[i
])
8317 indices
[i
+ 1] = indices
[kh
- 1];
8318 if (high
> indices
[i
+ 1])
8319 indices
[i
+ 1] = high
;
8320 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
8321 *size
-= kh
- i
- 2;
8324 else if (high
< indices
[i
])
8328 if (*size
== max_size
)
8329 error (_("Internal error: miscounted aggregate components."));
8331 for (j
= *size
-1; j
>= i
+2; j
-= 1)
8332 indices
[j
] = indices
[j
- 2];
8334 indices
[i
+ 1] = high
;
8337 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8340 static struct value
*
8341 ada_value_cast (struct type
*type
, struct value
*arg2
, enum noside noside
)
8343 if (type
== ada_check_typedef (value_type (arg2
)))
8346 if (ada_is_fixed_point_type (type
))
8347 return (cast_to_fixed (type
, arg2
));
8349 if (ada_is_fixed_point_type (value_type (arg2
)))
8350 return cast_from_fixed (type
, arg2
);
8352 return value_cast (type
, arg2
);
8355 static struct value
*
8356 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
8357 int *pos
, enum noside noside
)
8360 int tem
, tem2
, tem3
;
8362 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
8365 struct value
**argvec
;
8369 op
= exp
->elts
[pc
].opcode
;
8375 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8376 arg1
= unwrap_value (arg1
);
8378 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8379 then we need to perform the conversion manually, because
8380 evaluate_subexp_standard doesn't do it. This conversion is
8381 necessary in Ada because the different kinds of float/fixed
8382 types in Ada have different representations.
8384 Similarly, we need to perform the conversion from OP_LONG
8386 if ((op
== OP_DOUBLE
|| op
== OP_LONG
) && expect_type
!= NULL
)
8387 arg1
= ada_value_cast (expect_type
, arg1
, noside
);
8393 struct value
*result
;
8395 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8396 /* The result type will have code OP_STRING, bashed there from
8397 OP_ARRAY. Bash it back. */
8398 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
8399 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
8405 type
= exp
->elts
[pc
+ 1].type
;
8406 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
8407 if (noside
== EVAL_SKIP
)
8409 arg1
= ada_value_cast (type
, arg1
, noside
);
8414 type
= exp
->elts
[pc
+ 1].type
;
8415 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
8418 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8419 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8421 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
8422 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8424 return ada_value_assign (arg1
, arg1
);
8426 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8427 except if the lhs of our assignment is a convenience variable.
8428 In the case of assigning to a convenience variable, the lhs
8429 should be exactly the result of the evaluation of the rhs. */
8430 type
= value_type (arg1
);
8431 if (VALUE_LVAL (arg1
) == lval_internalvar
)
8433 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
8434 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8436 if (ada_is_fixed_point_type (value_type (arg1
)))
8437 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
8438 else if (ada_is_fixed_point_type (value_type (arg2
)))
8440 (_("Fixed-point values must be assigned to fixed-point variables"));
8442 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
8443 return ada_value_assign (arg1
, arg2
);
8446 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8447 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8448 if (noside
== EVAL_SKIP
)
8450 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8451 return (value_from_longest
8453 value_as_long (arg1
) + value_as_long (arg2
)));
8454 if ((ada_is_fixed_point_type (value_type (arg1
))
8455 || ada_is_fixed_point_type (value_type (arg2
)))
8456 && value_type (arg1
) != value_type (arg2
))
8457 error (_("Operands of fixed-point addition must have the same type"));
8458 /* Do the addition, and cast the result to the type of the first
8459 argument. We cannot cast the result to a reference type, so if
8460 ARG1 is a reference type, find its underlying type. */
8461 type
= value_type (arg1
);
8462 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8463 type
= TYPE_TARGET_TYPE (type
);
8464 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8465 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
8468 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8469 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8470 if (noside
== EVAL_SKIP
)
8472 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8473 return (value_from_longest
8475 value_as_long (arg1
) - value_as_long (arg2
)));
8476 if ((ada_is_fixed_point_type (value_type (arg1
))
8477 || ada_is_fixed_point_type (value_type (arg2
)))
8478 && value_type (arg1
) != value_type (arg2
))
8479 error (_("Operands of fixed-point subtraction must have the same type"));
8480 /* Do the substraction, and cast the result to the type of the first
8481 argument. We cannot cast the result to a reference type, so if
8482 ARG1 is a reference type, find its underlying type. */
8483 type
= value_type (arg1
);
8484 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8485 type
= TYPE_TARGET_TYPE (type
);
8486 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8487 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
8491 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8492 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8493 if (noside
== EVAL_SKIP
)
8495 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8496 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8497 return value_zero (value_type (arg1
), not_lval
);
8500 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
8501 if (ada_is_fixed_point_type (value_type (arg1
)))
8502 arg1
= cast_from_fixed (type
, arg1
);
8503 if (ada_is_fixed_point_type (value_type (arg2
)))
8504 arg2
= cast_from_fixed (type
, arg2
);
8505 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8506 return ada_value_binop (arg1
, arg2
, op
);
8511 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8512 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8513 if (noside
== EVAL_SKIP
)
8515 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8516 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8517 return value_zero (value_type (arg1
), not_lval
);
8520 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8521 return ada_value_binop (arg1
, arg2
, op
);
8525 case BINOP_NOTEQUAL
:
8526 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8527 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
8528 if (noside
== EVAL_SKIP
)
8530 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8534 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8535 tem
= ada_value_equal (arg1
, arg2
);
8537 if (op
== BINOP_NOTEQUAL
)
8539 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8540 return value_from_longest (type
, (LONGEST
) tem
);
8543 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8544 if (noside
== EVAL_SKIP
)
8546 else if (ada_is_fixed_point_type (value_type (arg1
)))
8547 return value_cast (value_type (arg1
), value_neg (arg1
));
8550 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
8551 return value_neg (arg1
);
8554 case BINOP_LOGICAL_AND
:
8555 case BINOP_LOGICAL_OR
:
8556 case UNOP_LOGICAL_NOT
:
8561 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8562 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8563 return value_cast (type
, val
);
8566 case BINOP_BITWISE_AND
:
8567 case BINOP_BITWISE_IOR
:
8568 case BINOP_BITWISE_XOR
:
8572 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8574 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8576 return value_cast (value_type (arg1
), val
);
8582 if (noside
== EVAL_SKIP
)
8587 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
8588 /* Only encountered when an unresolved symbol occurs in a
8589 context other than a function call, in which case, it is
8591 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8592 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
8593 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8595 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
8596 if (ada_is_tagged_type (type
, 0))
8598 /* Tagged types are a little special in the fact that the real
8599 type is dynamic and can only be determined by inspecting the
8600 object's tag. This means that we need to get the object's
8601 value first (EVAL_NORMAL) and then extract the actual object
8604 Note that we cannot skip the final step where we extract
8605 the object type from its tag, because the EVAL_NORMAL phase
8606 results in dynamic components being resolved into fixed ones.
8607 This can cause problems when trying to print the type
8608 description of tagged types whose parent has a dynamic size:
8609 We use the type name of the "_parent" component in order
8610 to print the name of the ancestor type in the type description.
8611 If that component had a dynamic size, the resolution into
8612 a fixed type would result in the loss of that type name,
8613 thus preventing us from printing the name of the ancestor
8614 type in the type description. */
8615 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
8616 return value_zero (type_from_tag (ada_value_tag (arg1
)), not_lval
);
8621 (to_static_fixed_type
8622 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
8628 unwrap_value (evaluate_subexp_standard
8629 (expect_type
, exp
, pos
, noside
));
8630 return ada_to_fixed_value (arg1
);
8636 /* Allocate arg vector, including space for the function to be
8637 called in argvec[0] and a terminating NULL. */
8638 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8640 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
8642 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
8643 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
8644 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8645 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
8648 for (tem
= 0; tem
<= nargs
; tem
+= 1)
8649 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8652 if (noside
== EVAL_SKIP
)
8656 if (ada_is_packed_array_type (desc_base_type (value_type (argvec
[0]))))
8657 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
8658 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
8659 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
8660 && VALUE_LVAL (argvec
[0]) == lval_memory
))
8661 argvec
[0] = value_addr (argvec
[0]);
8663 type
= ada_check_typedef (value_type (argvec
[0]));
8664 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
8666 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
8668 case TYPE_CODE_FUNC
:
8669 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8671 case TYPE_CODE_ARRAY
:
8673 case TYPE_CODE_STRUCT
:
8674 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
8675 argvec
[0] = ada_value_ind (argvec
[0]);
8676 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8679 error (_("cannot subscript or call something of type `%s'"),
8680 ada_type_name (value_type (argvec
[0])));
8685 switch (TYPE_CODE (type
))
8687 case TYPE_CODE_FUNC
:
8688 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8689 return allocate_value (TYPE_TARGET_TYPE (type
));
8690 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
8691 case TYPE_CODE_STRUCT
:
8695 arity
= ada_array_arity (type
);
8696 type
= ada_array_element_type (type
, nargs
);
8698 error (_("cannot subscript or call a record"));
8700 error (_("wrong number of subscripts; expecting %d"), arity
);
8701 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8702 return value_zero (ada_aligned_type (type
), lval_memory
);
8704 unwrap_value (ada_value_subscript
8705 (argvec
[0], nargs
, argvec
+ 1));
8707 case TYPE_CODE_ARRAY
:
8708 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8710 type
= ada_array_element_type (type
, nargs
);
8712 error (_("element type of array unknown"));
8714 return value_zero (ada_aligned_type (type
), lval_memory
);
8717 unwrap_value (ada_value_subscript
8718 (ada_coerce_to_simple_array (argvec
[0]),
8719 nargs
, argvec
+ 1));
8720 case TYPE_CODE_PTR
: /* Pointer to array */
8721 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
8722 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8724 type
= ada_array_element_type (type
, nargs
);
8726 error (_("element type of array unknown"));
8728 return value_zero (ada_aligned_type (type
), lval_memory
);
8731 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
8732 nargs
, argvec
+ 1));
8735 error (_("Attempt to index or call something other than an "
8736 "array or function"));
8741 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8742 struct value
*low_bound_val
=
8743 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8744 struct value
*high_bound_val
=
8745 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8748 low_bound_val
= coerce_ref (low_bound_val
);
8749 high_bound_val
= coerce_ref (high_bound_val
);
8750 low_bound
= pos_atr (low_bound_val
);
8751 high_bound
= pos_atr (high_bound_val
);
8753 if (noside
== EVAL_SKIP
)
8756 /* If this is a reference to an aligner type, then remove all
8758 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8759 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
8760 TYPE_TARGET_TYPE (value_type (array
)) =
8761 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
8763 if (ada_is_packed_array_type (value_type (array
)))
8764 error (_("cannot slice a packed array"));
8766 /* If this is a reference to an array or an array lvalue,
8767 convert to a pointer. */
8768 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8769 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
8770 && VALUE_LVAL (array
) == lval_memory
))
8771 array
= value_addr (array
);
8773 if (noside
== EVAL_AVOID_SIDE_EFFECTS
8774 && ada_is_array_descriptor_type (ada_check_typedef
8775 (value_type (array
))))
8776 return empty_array (ada_type_of_array (array
, 0), low_bound
);
8778 array
= ada_coerce_to_simple_array_ptr (array
);
8780 /* If we have more than one level of pointer indirection,
8781 dereference the value until we get only one level. */
8782 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
8783 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
8785 array
= value_ind (array
);
8787 /* Make sure we really do have an array type before going further,
8788 to avoid a SEGV when trying to get the index type or the target
8789 type later down the road if the debug info generated by
8790 the compiler is incorrect or incomplete. */
8791 if (!ada_is_simple_array_type (value_type (array
)))
8792 error (_("cannot take slice of non-array"));
8794 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
8796 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8797 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
8801 struct type
*arr_type0
=
8802 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
8804 return ada_value_slice_from_ptr (array
, arr_type0
,
8805 longest_to_int (low_bound
),
8806 longest_to_int (high_bound
));
8809 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8811 else if (high_bound
< low_bound
)
8812 return empty_array (value_type (array
), low_bound
);
8814 return ada_value_slice (array
, longest_to_int (low_bound
),
8815 longest_to_int (high_bound
));
8820 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8821 type
= exp
->elts
[pc
+ 1].type
;
8823 if (noside
== EVAL_SKIP
)
8826 switch (TYPE_CODE (type
))
8829 lim_warning (_("Membership test incompletely implemented; "
8830 "always returns true"));
8831 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8832 return value_from_longest (type
, (LONGEST
) 1);
8834 case TYPE_CODE_RANGE
:
8835 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
8836 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
8837 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8838 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8839 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8841 value_from_longest (type
,
8842 (value_less (arg1
, arg3
)
8843 || value_equal (arg1
, arg3
))
8844 && (value_less (arg2
, arg1
)
8845 || value_equal (arg2
, arg1
)));
8848 case BINOP_IN_BOUNDS
:
8850 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8851 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8853 if (noside
== EVAL_SKIP
)
8856 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8858 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8859 return value_zero (type
, not_lval
);
8862 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8864 if (tem
< 1 || tem
> ada_array_arity (value_type (arg2
)))
8865 error (_("invalid dimension number to 'range"));
8867 arg3
= ada_array_bound (arg2
, tem
, 1);
8868 arg2
= ada_array_bound (arg2
, tem
, 0);
8870 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8871 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8872 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8874 value_from_longest (type
,
8875 (value_less (arg1
, arg3
)
8876 || value_equal (arg1
, arg3
))
8877 && (value_less (arg2
, arg1
)
8878 || value_equal (arg2
, arg1
)));
8880 case TERNOP_IN_RANGE
:
8881 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8882 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8883 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8885 if (noside
== EVAL_SKIP
)
8888 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8889 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8890 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8892 value_from_longest (type
,
8893 (value_less (arg1
, arg3
)
8894 || value_equal (arg1
, arg3
))
8895 && (value_less (arg2
, arg1
)
8896 || value_equal (arg2
, arg1
)));
8902 struct type
*type_arg
;
8903 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8905 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8907 type_arg
= exp
->elts
[pc
+ 2].type
;
8911 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8915 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
8916 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
8917 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
8920 if (noside
== EVAL_SKIP
)
8923 if (type_arg
== NULL
)
8925 arg1
= ada_coerce_ref (arg1
);
8927 if (ada_is_packed_array_type (value_type (arg1
)))
8928 arg1
= ada_coerce_to_simple_array (arg1
);
8930 if (tem
< 1 || tem
> ada_array_arity (value_type (arg1
)))
8931 error (_("invalid dimension number to '%s"),
8932 ada_attribute_name (op
));
8934 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8936 type
= ada_index_type (value_type (arg1
), tem
);
8939 (_("attempt to take bound of something that is not an array"));
8940 return allocate_value (type
);
8945 default: /* Should never happen. */
8946 error (_("unexpected attribute encountered"));
8948 return ada_array_bound (arg1
, tem
, 0);
8950 return ada_array_bound (arg1
, tem
, 1);
8952 return ada_array_length (arg1
, tem
);
8955 else if (discrete_type_p (type_arg
))
8957 struct type
*range_type
;
8958 char *name
= ada_type_name (type_arg
);
8960 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
8962 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
8963 if (range_type
== NULL
)
8964 range_type
= type_arg
;
8968 error (_("unexpected attribute encountered"));
8970 return value_from_longest
8971 (range_type
, discrete_type_low_bound (range_type
));
8973 return value_from_longest
8974 (range_type
, discrete_type_high_bound (range_type
));
8976 error (_("the 'length attribute applies only to array types"));
8979 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
8980 error (_("unimplemented type attribute"));
8985 if (ada_is_packed_array_type (type_arg
))
8986 type_arg
= decode_packed_array_type (type_arg
);
8988 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
8989 error (_("invalid dimension number to '%s"),
8990 ada_attribute_name (op
));
8992 type
= ada_index_type (type_arg
, tem
);
8995 (_("attempt to take bound of something that is not an array"));
8996 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8997 return allocate_value (type
);
9002 error (_("unexpected attribute encountered"));
9004 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9005 return value_from_longest (type
, low
);
9007 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
9008 return value_from_longest (type
, high
);
9010 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9011 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
9012 return value_from_longest (type
, high
- low
+ 1);
9018 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9019 if (noside
== EVAL_SKIP
)
9022 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9023 return value_zero (ada_tag_type (arg1
), not_lval
);
9025 return ada_value_tag (arg1
);
9029 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9030 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9031 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9032 if (noside
== EVAL_SKIP
)
9034 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9035 return value_zero (value_type (arg1
), not_lval
);
9038 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9039 return value_binop (arg1
, arg2
,
9040 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
9043 case OP_ATR_MODULUS
:
9045 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
9046 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9048 if (noside
== EVAL_SKIP
)
9051 if (!ada_is_modular_type (type_arg
))
9052 error (_("'modulus must be applied to modular type"));
9054 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
9055 ada_modulus (type_arg
));
9060 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9061 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9062 if (noside
== EVAL_SKIP
)
9064 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9065 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9066 return value_zero (type
, not_lval
);
9068 return value_pos_atr (type
, arg1
);
9071 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9072 type
= value_type (arg1
);
9074 /* If the argument is a reference, then dereference its type, since
9075 the user is really asking for the size of the actual object,
9076 not the size of the pointer. */
9077 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
9078 type
= TYPE_TARGET_TYPE (type
);
9080 if (noside
== EVAL_SKIP
)
9082 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9083 return value_zero (builtin_type_int32
, not_lval
);
9085 return value_from_longest (builtin_type_int32
,
9086 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
9089 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9090 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9091 type
= exp
->elts
[pc
+ 2].type
;
9092 if (noside
== EVAL_SKIP
)
9094 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9095 return value_zero (type
, not_lval
);
9097 return value_val_atr (type
, arg1
);
9100 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9101 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9102 if (noside
== EVAL_SKIP
)
9104 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9105 return value_zero (value_type (arg1
), not_lval
);
9108 /* For integer exponentiation operations,
9109 only promote the first argument. */
9110 if (is_integral_type (value_type (arg2
)))
9111 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9113 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9115 return value_binop (arg1
, arg2
, op
);
9119 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9120 if (noside
== EVAL_SKIP
)
9126 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9127 if (noside
== EVAL_SKIP
)
9129 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9130 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
9131 return value_neg (arg1
);
9136 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9137 if (noside
== EVAL_SKIP
)
9139 type
= ada_check_typedef (value_type (arg1
));
9140 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9142 if (ada_is_array_descriptor_type (type
))
9143 /* GDB allows dereferencing GNAT array descriptors. */
9145 struct type
*arrType
= ada_type_of_array (arg1
, 0);
9146 if (arrType
== NULL
)
9147 error (_("Attempt to dereference null array pointer."));
9148 return value_at_lazy (arrType
, 0);
9150 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
9151 || TYPE_CODE (type
) == TYPE_CODE_REF
9152 /* In C you can dereference an array to get the 1st elt. */
9153 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9155 type
= to_static_fixed_type
9157 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
9159 return value_zero (type
, lval_memory
);
9161 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9163 /* GDB allows dereferencing an int. */
9164 if (expect_type
== NULL
)
9165 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
9170 to_static_fixed_type (ada_aligned_type (expect_type
));
9171 return value_zero (expect_type
, lval_memory
);
9175 error (_("Attempt to take contents of a non-pointer value."));
9177 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
9178 type
= ada_check_typedef (value_type (arg1
));
9180 if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9181 /* GDB allows dereferencing an int. If we were given
9182 the expect_type, then use that as the target type.
9183 Otherwise, assume that the target type is an int. */
9185 if (expect_type
!= NULL
)
9186 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
9189 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
9190 (CORE_ADDR
) value_as_address (arg1
));
9193 if (ada_is_array_descriptor_type (type
))
9194 /* GDB allows dereferencing GNAT array descriptors. */
9195 return ada_coerce_to_simple_array (arg1
);
9197 return ada_value_ind (arg1
);
9199 case STRUCTOP_STRUCT
:
9200 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9201 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
9202 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9203 if (noside
== EVAL_SKIP
)
9205 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9207 struct type
*type1
= value_type (arg1
);
9208 if (ada_is_tagged_type (type1
, 1))
9210 type
= ada_lookup_struct_elt_type (type1
,
9211 &exp
->elts
[pc
+ 2].string
,
9214 /* In this case, we assume that the field COULD exist
9215 in some extension of the type. Return an object of
9216 "type" void, which will match any formal
9217 (see ada_type_match). */
9218 return value_zero (builtin_type_void
, lval_memory
);
9222 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
9225 return value_zero (ada_aligned_type (type
), lval_memory
);
9229 ada_to_fixed_value (unwrap_value
9230 (ada_value_struct_elt
9231 (arg1
, &exp
->elts
[pc
+ 2].string
, 0)));
9233 /* The value is not supposed to be used. This is here to make it
9234 easier to accommodate expressions that contain types. */
9236 if (noside
== EVAL_SKIP
)
9238 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9239 return allocate_value (exp
->elts
[pc
+ 1].type
);
9241 error (_("Attempt to use a type name as an expression"));
9246 case OP_DISCRETE_RANGE
:
9249 if (noside
== EVAL_NORMAL
)
9253 error (_("Undefined name, ambiguous name, or renaming used in "
9254 "component association: %s."), &exp
->elts
[pc
+2].string
);
9256 error (_("Aggregates only allowed on the right of an assignment"));
9258 internal_error (__FILE__
, __LINE__
, _("aggregate apparently mangled"));
9261 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
9263 for (tem
= 0; tem
< nargs
; tem
+= 1)
9264 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9269 return value_from_longest (builtin_type_int8
, (LONGEST
) 1);
9275 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9276 type name that encodes the 'small and 'delta information.
9277 Otherwise, return NULL. */
9280 fixed_type_info (struct type
*type
)
9282 const char *name
= ada_type_name (type
);
9283 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
9285 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
9287 const char *tail
= strstr (name
, "___XF_");
9293 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
9294 return fixed_type_info (TYPE_TARGET_TYPE (type
));
9299 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9302 ada_is_fixed_point_type (struct type
*type
)
9304 return fixed_type_info (type
) != NULL
;
9307 /* Return non-zero iff TYPE represents a System.Address type. */
9310 ada_is_system_address_type (struct type
*type
)
9312 return (TYPE_NAME (type
)
9313 && strcmp (TYPE_NAME (type
), "system__address") == 0);
9316 /* Assuming that TYPE is the representation of an Ada fixed-point
9317 type, return its delta, or -1 if the type is malformed and the
9318 delta cannot be determined. */
9321 ada_delta (struct type
*type
)
9323 const char *encoding
= fixed_type_info (type
);
9326 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
9329 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
9332 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9333 factor ('SMALL value) associated with the type. */
9336 scaling_factor (struct type
*type
)
9338 const char *encoding
= fixed_type_info (type
);
9339 unsigned long num0
, den0
, num1
, den1
;
9342 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
9347 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
9349 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
9353 /* Assuming that X is the representation of a value of fixed-point
9354 type TYPE, return its floating-point equivalent. */
9357 ada_fixed_to_float (struct type
*type
, LONGEST x
)
9359 return (DOUBLEST
) x
*scaling_factor (type
);
9362 /* The representation of a fixed-point value of type TYPE
9363 corresponding to the value X. */
9366 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
9368 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
9372 /* VAX floating formats */
9374 /* Non-zero iff TYPE represents one of the special VAX floating-point
9378 ada_is_vax_floating_type (struct type
*type
)
9381 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
9384 && (TYPE_CODE (type
) == TYPE_CODE_INT
9385 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
9386 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
9389 /* The type of special VAX floating-point type this is, assuming
9390 ada_is_vax_floating_point. */
9393 ada_vax_float_type_suffix (struct type
*type
)
9395 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
9398 /* A value representing the special debugging function that outputs
9399 VAX floating-point values of the type represented by TYPE. Assumes
9400 ada_is_vax_floating_type (TYPE). */
9403 ada_vax_float_print_function (struct type
*type
)
9405 switch (ada_vax_float_type_suffix (type
))
9408 return get_var_value ("DEBUG_STRING_F", 0);
9410 return get_var_value ("DEBUG_STRING_D", 0);
9412 return get_var_value ("DEBUG_STRING_G", 0);
9414 error (_("invalid VAX floating-point type"));
9421 /* Scan STR beginning at position K for a discriminant name, and
9422 return the value of that discriminant field of DVAL in *PX. If
9423 PNEW_K is not null, put the position of the character beyond the
9424 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9425 not alter *PX and *PNEW_K if unsuccessful. */
9428 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
9431 static char *bound_buffer
= NULL
;
9432 static size_t bound_buffer_len
= 0;
9435 struct value
*bound_val
;
9437 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9440 pend
= strstr (str
+ k
, "__");
9444 k
+= strlen (bound
);
9448 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9449 bound
= bound_buffer
;
9450 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9451 bound
[pend
- (str
+ k
)] = '\0';
9455 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
9456 if (bound_val
== NULL
)
9459 *px
= value_as_long (bound_val
);
9465 /* Value of variable named NAME in the current environment. If
9466 no such variable found, then if ERR_MSG is null, returns 0, and
9467 otherwise causes an error with message ERR_MSG. */
9469 static struct value
*
9470 get_var_value (char *name
, char *err_msg
)
9472 struct ada_symbol_info
*syms
;
9475 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9480 if (err_msg
== NULL
)
9483 error (("%s"), err_msg
);
9486 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9489 /* Value of integer variable named NAME in the current environment. If
9490 no such variable found, returns 0, and sets *FLAG to 0. If
9491 successful, sets *FLAG to 1. */
9494 get_int_var_value (char *name
, int *flag
)
9496 struct value
*var_val
= get_var_value (name
, 0);
9508 return value_as_long (var_val
);
9513 /* Return a range type whose base type is that of the range type named
9514 NAME in the current environment, and whose bounds are calculated
9515 from NAME according to the GNAT range encoding conventions.
9516 Extract discriminant values, if needed, from DVAL. If a new type
9517 must be created, allocate in OBJFILE's space. The bounds
9518 information, in general, is encoded in NAME, the base type given in
9519 the named range type. */
9521 static struct type
*
9522 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
9524 struct type
*raw_type
= ada_find_any_type (name
);
9525 struct type
*base_type
;
9528 if (raw_type
== NULL
)
9529 base_type
= builtin_type_int32
;
9530 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9531 base_type
= TYPE_TARGET_TYPE (raw_type
);
9533 base_type
= raw_type
;
9535 subtype_info
= strstr (name
, "___XD");
9536 if (subtype_info
== NULL
)
9538 LONGEST L
= discrete_type_low_bound (raw_type
);
9539 LONGEST U
= discrete_type_high_bound (raw_type
);
9540 if (L
< INT_MIN
|| U
> INT_MAX
)
9543 return create_range_type (alloc_type (objfile
), raw_type
,
9544 discrete_type_low_bound (raw_type
),
9545 discrete_type_high_bound (raw_type
));
9549 static char *name_buf
= NULL
;
9550 static size_t name_len
= 0;
9551 int prefix_len
= subtype_info
- name
;
9557 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
9558 strncpy (name_buf
, name
, prefix_len
);
9559 name_buf
[prefix_len
] = '\0';
9562 bounds_str
= strchr (subtype_info
, '_');
9565 if (*subtype_info
== 'L')
9567 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
9568 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
9570 if (bounds_str
[n
] == '_')
9572 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
9579 strcpy (name_buf
+ prefix_len
, "___L");
9580 L
= get_int_var_value (name_buf
, &ok
);
9583 lim_warning (_("Unknown lower bound, using 1."));
9588 if (*subtype_info
== 'U')
9590 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
9591 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
9597 strcpy (name_buf
+ prefix_len
, "___U");
9598 U
= get_int_var_value (name_buf
, &ok
);
9601 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
9606 if (objfile
== NULL
)
9607 objfile
= TYPE_OBJFILE (base_type
);
9608 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
9609 TYPE_NAME (type
) = name
;
9614 /* True iff NAME is the name of a range type. */
9617 ada_is_range_type_name (const char *name
)
9619 return (name
!= NULL
&& strstr (name
, "___XD"));
9625 /* True iff TYPE is an Ada modular type. */
9628 ada_is_modular_type (struct type
*type
)
9630 struct type
*subranged_type
= base_type (type
);
9632 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
9633 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
9634 && TYPE_UNSIGNED (subranged_type
));
9637 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9640 ada_modulus (struct type
* type
)
9642 return (ULONGEST
) (unsigned int) TYPE_HIGH_BOUND (type
) + 1;
9646 /* Ada exception catchpoint support:
9647 ---------------------------------
9649 We support 3 kinds of exception catchpoints:
9650 . catchpoints on Ada exceptions
9651 . catchpoints on unhandled Ada exceptions
9652 . catchpoints on failed assertions
9654 Exceptions raised during failed assertions, or unhandled exceptions
9655 could perfectly be caught with the general catchpoint on Ada exceptions.
9656 However, we can easily differentiate these two special cases, and having
9657 the option to distinguish these two cases from the rest can be useful
9658 to zero-in on certain situations.
9660 Exception catchpoints are a specialized form of breakpoint,
9661 since they rely on inserting breakpoints inside known routines
9662 of the GNAT runtime. The implementation therefore uses a standard
9663 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9666 Support in the runtime for exception catchpoints have been changed
9667 a few times already, and these changes affect the implementation
9668 of these catchpoints. In order to be able to support several
9669 variants of the runtime, we use a sniffer that will determine
9670 the runtime variant used by the program being debugged.
9672 At this time, we do not support the use of conditions on Ada exception
9673 catchpoints. The COND and COND_STRING fields are therefore set
9674 to NULL (most of the time, see below).
9676 Conditions where EXP_STRING, COND, and COND_STRING are used:
9678 When a user specifies the name of a specific exception in the case
9679 of catchpoints on Ada exceptions, we store the name of that exception
9680 in the EXP_STRING. We then translate this request into an actual
9681 condition stored in COND_STRING, and then parse it into an expression
9684 /* The different types of catchpoints that we introduced for catching
9687 enum exception_catchpoint_kind
9690 ex_catch_exception_unhandled
,
9694 /* Ada's standard exceptions. */
9696 static char *standard_exc
[] = {
9703 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
9705 /* A structure that describes how to support exception catchpoints
9706 for a given executable. */
9708 struct exception_support_info
9710 /* The name of the symbol to break on in order to insert
9711 a catchpoint on exceptions. */
9712 const char *catch_exception_sym
;
9714 /* The name of the symbol to break on in order to insert
9715 a catchpoint on unhandled exceptions. */
9716 const char *catch_exception_unhandled_sym
;
9718 /* The name of the symbol to break on in order to insert
9719 a catchpoint on failed assertions. */
9720 const char *catch_assert_sym
;
9722 /* Assuming that the inferior just triggered an unhandled exception
9723 catchpoint, this function is responsible for returning the address
9724 in inferior memory where the name of that exception is stored.
9725 Return zero if the address could not be computed. */
9726 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
9729 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
9730 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
9732 /* The following exception support info structure describes how to
9733 implement exception catchpoints with the latest version of the
9734 Ada runtime (as of 2007-03-06). */
9736 static const struct exception_support_info default_exception_support_info
=
9738 "__gnat_debug_raise_exception", /* catch_exception_sym */
9739 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9740 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9741 ada_unhandled_exception_name_addr
9744 /* The following exception support info structure describes how to
9745 implement exception catchpoints with a slightly older version
9746 of the Ada runtime. */
9748 static const struct exception_support_info exception_support_info_fallback
=
9750 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9751 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9752 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9753 ada_unhandled_exception_name_addr_from_raise
9756 /* For each executable, we sniff which exception info structure to use
9757 and cache it in the following global variable. */
9759 static const struct exception_support_info
*exception_info
= NULL
;
9761 /* Inspect the Ada runtime and determine which exception info structure
9762 should be used to provide support for exception catchpoints.
9764 This function will always set exception_info, or raise an error. */
9767 ada_exception_support_info_sniffer (void)
9771 /* If the exception info is already known, then no need to recompute it. */
9772 if (exception_info
!= NULL
)
9775 /* Check the latest (default) exception support info. */
9776 sym
= standard_lookup (default_exception_support_info
.catch_exception_sym
,
9780 exception_info
= &default_exception_support_info
;
9784 /* Try our fallback exception suport info. */
9785 sym
= standard_lookup (exception_support_info_fallback
.catch_exception_sym
,
9789 exception_info
= &exception_support_info_fallback
;
9793 /* Sometimes, it is normal for us to not be able to find the routine
9794 we are looking for. This happens when the program is linked with
9795 the shared version of the GNAT runtime, and the program has not been
9796 started yet. Inform the user of these two possible causes if
9799 if (ada_update_initial_language (language_unknown
, NULL
) != language_ada
)
9800 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9802 /* If the symbol does not exist, then check that the program is
9803 already started, to make sure that shared libraries have been
9804 loaded. If it is not started, this may mean that the symbol is
9805 in a shared library. */
9807 if (ptid_get_pid (inferior_ptid
) == 0)
9808 error (_("Unable to insert catchpoint. Try to start the program first."));
9810 /* At this point, we know that we are debugging an Ada program and
9811 that the inferior has been started, but we still are not able to
9812 find the run-time symbols. That can mean that we are in
9813 configurable run time mode, or that a-except as been optimized
9814 out by the linker... In any case, at this point it is not worth
9815 supporting this feature. */
9817 error (_("Cannot insert catchpoints in this configuration."));
9820 /* An observer of "executable_changed" events.
9821 Its role is to clear certain cached values that need to be recomputed
9822 each time a new executable is loaded by GDB. */
9825 ada_executable_changed_observer (void)
9827 /* If the executable changed, then it is possible that the Ada runtime
9828 is different. So we need to invalidate the exception support info
9830 exception_info
= NULL
;
9833 /* Return the name of the function at PC, NULL if could not find it.
9834 This function only checks the debugging information, not the symbol
9838 function_name_from_pc (CORE_ADDR pc
)
9842 if (!find_pc_partial_function (pc
, &func_name
, NULL
, NULL
))
9848 /* True iff FRAME is very likely to be that of a function that is
9849 part of the runtime system. This is all very heuristic, but is
9850 intended to be used as advice as to what frames are uninteresting
9854 is_known_support_routine (struct frame_info
*frame
)
9856 struct symtab_and_line sal
;
9860 /* If this code does not have any debugging information (no symtab),
9861 This cannot be any user code. */
9863 find_frame_sal (frame
, &sal
);
9864 if (sal
.symtab
== NULL
)
9867 /* If there is a symtab, but the associated source file cannot be
9868 located, then assume this is not user code: Selecting a frame
9869 for which we cannot display the code would not be very helpful
9870 for the user. This should also take care of case such as VxWorks
9871 where the kernel has some debugging info provided for a few units. */
9873 if (symtab_to_fullname (sal
.symtab
) == NULL
)
9876 /* Check the unit filename againt the Ada runtime file naming.
9877 We also check the name of the objfile against the name of some
9878 known system libraries that sometimes come with debugging info
9881 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
9883 re_comp (known_runtime_file_name_patterns
[i
]);
9884 if (re_exec (sal
.symtab
->filename
))
9886 if (sal
.symtab
->objfile
!= NULL
9887 && re_exec (sal
.symtab
->objfile
->name
))
9891 /* Check whether the function is a GNAT-generated entity. */
9893 func_name
= function_name_from_pc (get_frame_address_in_block (frame
));
9894 if (func_name
== NULL
)
9897 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
9899 re_comp (known_auxiliary_function_name_patterns
[i
]);
9900 if (re_exec (func_name
))
9907 /* Find the first frame that contains debugging information and that is not
9908 part of the Ada run-time, starting from FI and moving upward. */
9911 ada_find_printable_frame (struct frame_info
*fi
)
9913 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
9915 if (!is_known_support_routine (fi
))
9924 /* Assuming that the inferior just triggered an unhandled exception
9925 catchpoint, return the address in inferior memory where the name
9926 of the exception is stored.
9928 Return zero if the address could not be computed. */
9931 ada_unhandled_exception_name_addr (void)
9933 return parse_and_eval_address ("e.full_name");
9936 /* Same as ada_unhandled_exception_name_addr, except that this function
9937 should be used when the inferior uses an older version of the runtime,
9938 where the exception name needs to be extracted from a specific frame
9939 several frames up in the callstack. */
9942 ada_unhandled_exception_name_addr_from_raise (void)
9945 struct frame_info
*fi
;
9947 /* To determine the name of this exception, we need to select
9948 the frame corresponding to RAISE_SYM_NAME. This frame is
9949 at least 3 levels up, so we simply skip the first 3 frames
9950 without checking the name of their associated function. */
9951 fi
= get_current_frame ();
9952 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
9954 fi
= get_prev_frame (fi
);
9958 const char *func_name
=
9959 function_name_from_pc (get_frame_address_in_block (fi
));
9960 if (func_name
!= NULL
9961 && strcmp (func_name
, exception_info
->catch_exception_sym
) == 0)
9962 break; /* We found the frame we were looking for... */
9963 fi
= get_prev_frame (fi
);
9970 return parse_and_eval_address ("id.full_name");
9973 /* Assuming the inferior just triggered an Ada exception catchpoint
9974 (of any type), return the address in inferior memory where the name
9975 of the exception is stored, if applicable.
9977 Return zero if the address could not be computed, or if not relevant. */
9980 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex
,
9981 struct breakpoint
*b
)
9985 case ex_catch_exception
:
9986 return (parse_and_eval_address ("e.full_name"));
9989 case ex_catch_exception_unhandled
:
9990 return exception_info
->unhandled_exception_name_addr ();
9993 case ex_catch_assert
:
9994 return 0; /* Exception name is not relevant in this case. */
9998 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10002 return 0; /* Should never be reached. */
10005 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
10006 any error that ada_exception_name_addr_1 might cause to be thrown.
10007 When an error is intercepted, a warning with the error message is printed,
10008 and zero is returned. */
10011 ada_exception_name_addr (enum exception_catchpoint_kind ex
,
10012 struct breakpoint
*b
)
10014 struct gdb_exception e
;
10015 CORE_ADDR result
= 0;
10017 TRY_CATCH (e
, RETURN_MASK_ERROR
)
10019 result
= ada_exception_name_addr_1 (ex
, b
);
10024 warning (_("failed to get exception name: %s"), e
.message
);
10031 /* Implement the PRINT_IT method in the breakpoint_ops structure
10032 for all exception catchpoint kinds. */
10034 static enum print_stop_action
10035 print_it_exception (enum exception_catchpoint_kind ex
, struct breakpoint
*b
)
10037 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
10038 char exception_name
[256];
10042 read_memory (addr
, exception_name
, sizeof (exception_name
) - 1);
10043 exception_name
[sizeof (exception_name
) - 1] = '\0';
10046 ada_find_printable_frame (get_current_frame ());
10048 annotate_catchpoint (b
->number
);
10051 case ex_catch_exception
:
10053 printf_filtered (_("\nCatchpoint %d, %s at "),
10054 b
->number
, exception_name
);
10056 printf_filtered (_("\nCatchpoint %d, exception at "), b
->number
);
10058 case ex_catch_exception_unhandled
:
10060 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10061 b
->number
, exception_name
);
10063 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10066 case ex_catch_assert
:
10067 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10072 return PRINT_SRC_AND_LOC
;
10075 /* Implement the PRINT_ONE method in the breakpoint_ops structure
10076 for all exception catchpoint kinds. */
10079 print_one_exception (enum exception_catchpoint_kind ex
,
10080 struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10082 struct value_print_options opts
;
10084 get_user_print_options (&opts
);
10085 if (opts
.addressprint
)
10087 annotate_field (4);
10088 ui_out_field_core_addr (uiout
, "addr", b
->loc
->address
);
10091 annotate_field (5);
10092 *last_addr
= b
->loc
->address
;
10095 case ex_catch_exception
:
10096 if (b
->exp_string
!= NULL
)
10098 char *msg
= xstrprintf (_("`%s' Ada exception"), b
->exp_string
);
10100 ui_out_field_string (uiout
, "what", msg
);
10104 ui_out_field_string (uiout
, "what", "all Ada exceptions");
10108 case ex_catch_exception_unhandled
:
10109 ui_out_field_string (uiout
, "what", "unhandled Ada exceptions");
10112 case ex_catch_assert
:
10113 ui_out_field_string (uiout
, "what", "failed Ada assertions");
10117 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10122 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
10123 for all exception catchpoint kinds. */
10126 print_mention_exception (enum exception_catchpoint_kind ex
,
10127 struct breakpoint
*b
)
10131 case ex_catch_exception
:
10132 if (b
->exp_string
!= NULL
)
10133 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10134 b
->number
, b
->exp_string
);
10136 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b
->number
);
10140 case ex_catch_exception_unhandled
:
10141 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10145 case ex_catch_assert
:
10146 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b
->number
);
10150 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10155 /* Virtual table for "catch exception" breakpoints. */
10157 static enum print_stop_action
10158 print_it_catch_exception (struct breakpoint
*b
)
10160 return print_it_exception (ex_catch_exception
, b
);
10164 print_one_catch_exception (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10166 print_one_exception (ex_catch_exception
, b
, last_addr
);
10170 print_mention_catch_exception (struct breakpoint
*b
)
10172 print_mention_exception (ex_catch_exception
, b
);
10175 static struct breakpoint_ops catch_exception_breakpoint_ops
=
10179 NULL
, /* breakpoint_hit */
10180 print_it_catch_exception
,
10181 print_one_catch_exception
,
10182 print_mention_catch_exception
10185 /* Virtual table for "catch exception unhandled" breakpoints. */
10187 static enum print_stop_action
10188 print_it_catch_exception_unhandled (struct breakpoint
*b
)
10190 return print_it_exception (ex_catch_exception_unhandled
, b
);
10194 print_one_catch_exception_unhandled (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10196 print_one_exception (ex_catch_exception_unhandled
, b
, last_addr
);
10200 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
10202 print_mention_exception (ex_catch_exception_unhandled
, b
);
10205 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
= {
10208 NULL
, /* breakpoint_hit */
10209 print_it_catch_exception_unhandled
,
10210 print_one_catch_exception_unhandled
,
10211 print_mention_catch_exception_unhandled
10214 /* Virtual table for "catch assert" breakpoints. */
10216 static enum print_stop_action
10217 print_it_catch_assert (struct breakpoint
*b
)
10219 return print_it_exception (ex_catch_assert
, b
);
10223 print_one_catch_assert (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10225 print_one_exception (ex_catch_assert
, b
, last_addr
);
10229 print_mention_catch_assert (struct breakpoint
*b
)
10231 print_mention_exception (ex_catch_assert
, b
);
10234 static struct breakpoint_ops catch_assert_breakpoint_ops
= {
10237 NULL
, /* breakpoint_hit */
10238 print_it_catch_assert
,
10239 print_one_catch_assert
,
10240 print_mention_catch_assert
10243 /* Return non-zero if B is an Ada exception catchpoint. */
10246 ada_exception_catchpoint_p (struct breakpoint
*b
)
10248 return (b
->ops
== &catch_exception_breakpoint_ops
10249 || b
->ops
== &catch_exception_unhandled_breakpoint_ops
10250 || b
->ops
== &catch_assert_breakpoint_ops
);
10253 /* Return a newly allocated copy of the first space-separated token
10254 in ARGSP, and then adjust ARGSP to point immediately after that
10257 Return NULL if ARGPS does not contain any more tokens. */
10260 ada_get_next_arg (char **argsp
)
10262 char *args
= *argsp
;
10266 /* Skip any leading white space. */
10268 while (isspace (*args
))
10271 if (args
[0] == '\0')
10272 return NULL
; /* No more arguments. */
10274 /* Find the end of the current argument. */
10277 while (*end
!= '\0' && !isspace (*end
))
10280 /* Adjust ARGSP to point to the start of the next argument. */
10284 /* Make a copy of the current argument and return it. */
10286 result
= xmalloc (end
- args
+ 1);
10287 strncpy (result
, args
, end
- args
);
10288 result
[end
- args
] = '\0';
10293 /* Split the arguments specified in a "catch exception" command.
10294 Set EX to the appropriate catchpoint type.
10295 Set EXP_STRING to the name of the specific exception if
10296 specified by the user. */
10299 catch_ada_exception_command_split (char *args
,
10300 enum exception_catchpoint_kind
*ex
,
10303 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
10304 char *exception_name
;
10306 exception_name
= ada_get_next_arg (&args
);
10307 make_cleanup (xfree
, exception_name
);
10309 /* Check that we do not have any more arguments. Anything else
10312 while (isspace (*args
))
10315 if (args
[0] != '\0')
10316 error (_("Junk at end of expression"));
10318 discard_cleanups (old_chain
);
10320 if (exception_name
== NULL
)
10322 /* Catch all exceptions. */
10323 *ex
= ex_catch_exception
;
10324 *exp_string
= NULL
;
10326 else if (strcmp (exception_name
, "unhandled") == 0)
10328 /* Catch unhandled exceptions. */
10329 *ex
= ex_catch_exception_unhandled
;
10330 *exp_string
= NULL
;
10334 /* Catch a specific exception. */
10335 *ex
= ex_catch_exception
;
10336 *exp_string
= exception_name
;
10340 /* Return the name of the symbol on which we should break in order to
10341 implement a catchpoint of the EX kind. */
10343 static const char *
10344 ada_exception_sym_name (enum exception_catchpoint_kind ex
)
10346 gdb_assert (exception_info
!= NULL
);
10350 case ex_catch_exception
:
10351 return (exception_info
->catch_exception_sym
);
10353 case ex_catch_exception_unhandled
:
10354 return (exception_info
->catch_exception_unhandled_sym
);
10356 case ex_catch_assert
:
10357 return (exception_info
->catch_assert_sym
);
10360 internal_error (__FILE__
, __LINE__
,
10361 _("unexpected catchpoint kind (%d)"), ex
);
10365 /* Return the breakpoint ops "virtual table" used for catchpoints
10368 static struct breakpoint_ops
*
10369 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex
)
10373 case ex_catch_exception
:
10374 return (&catch_exception_breakpoint_ops
);
10376 case ex_catch_exception_unhandled
:
10377 return (&catch_exception_unhandled_breakpoint_ops
);
10379 case ex_catch_assert
:
10380 return (&catch_assert_breakpoint_ops
);
10383 internal_error (__FILE__
, __LINE__
,
10384 _("unexpected catchpoint kind (%d)"), ex
);
10388 /* Return the condition that will be used to match the current exception
10389 being raised with the exception that the user wants to catch. This
10390 assumes that this condition is used when the inferior just triggered
10391 an exception catchpoint.
10393 The string returned is a newly allocated string that needs to be
10394 deallocated later. */
10397 ada_exception_catchpoint_cond_string (const char *exp_string
)
10401 /* The standard exceptions are a special case. They are defined in
10402 runtime units that have been compiled without debugging info; if
10403 EXP_STRING is the not-fully-qualified name of a standard
10404 exception (e.g. "constraint_error") then, during the evaluation
10405 of the condition expression, the symbol lookup on this name would
10406 *not* return this standard exception. The catchpoint condition
10407 may then be set only on user-defined exceptions which have the
10408 same not-fully-qualified name (e.g. my_package.constraint_error).
10410 To avoid this unexcepted behavior, these standard exceptions are
10411 systematically prefixed by "standard". This means that "catch
10412 exception constraint_error" is rewritten into "catch exception
10413 standard.constraint_error".
10415 If an exception named contraint_error is defined in another package of
10416 the inferior program, then the only way to specify this exception as a
10417 breakpoint condition is to use its fully-qualified named:
10418 e.g. my_package.constraint_error. */
10420 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
10422 if (strcmp (standard_exc
[i
], exp_string
) == 0)
10424 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
10428 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string
);
10431 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
10433 static struct expression
*
10434 ada_parse_catchpoint_condition (char *cond_string
,
10435 struct symtab_and_line sal
)
10437 return (parse_exp_1 (&cond_string
, block_for_pc (sal
.pc
), 0));
10440 /* Return the symtab_and_line that should be used to insert an exception
10441 catchpoint of the TYPE kind.
10443 EX_STRING should contain the name of a specific exception
10444 that the catchpoint should catch, or NULL otherwise.
10446 The idea behind all the remaining parameters is that their names match
10447 the name of certain fields in the breakpoint structure that are used to
10448 handle exception catchpoints. This function returns the value to which
10449 these fields should be set, depending on the type of catchpoint we need
10452 If COND and COND_STRING are both non-NULL, any value they might
10453 hold will be free'ed, and then replaced by newly allocated ones.
10454 These parameters are left untouched otherwise. */
10456 static struct symtab_and_line
10457 ada_exception_sal (enum exception_catchpoint_kind ex
, char *exp_string
,
10458 char **addr_string
, char **cond_string
,
10459 struct expression
**cond
, struct breakpoint_ops
**ops
)
10461 const char *sym_name
;
10462 struct symbol
*sym
;
10463 struct symtab_and_line sal
;
10465 /* First, find out which exception support info to use. */
10466 ada_exception_support_info_sniffer ();
10468 /* Then lookup the function on which we will break in order to catch
10469 the Ada exceptions requested by the user. */
10471 sym_name
= ada_exception_sym_name (ex
);
10472 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
10474 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10475 that should be compiled with debugging information. As a result, we
10476 expect to find that symbol in the symtabs. If we don't find it, then
10477 the target most likely does not support Ada exceptions, or we cannot
10478 insert exception breakpoints yet, because the GNAT runtime hasn't been
10481 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10482 in such a way that no debugging information is produced for the symbol
10483 we are looking for. In this case, we could search the minimal symbols
10484 as a fall-back mechanism. This would still be operating in degraded
10485 mode, however, as we would still be missing the debugging information
10486 that is needed in order to extract the name of the exception being
10487 raised (this name is printed in the catchpoint message, and is also
10488 used when trying to catch a specific exception). We do not handle
10489 this case for now. */
10492 error (_("Unable to break on '%s' in this configuration."), sym_name
);
10494 /* Make sure that the symbol we found corresponds to a function. */
10495 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
10496 error (_("Symbol \"%s\" is not a function (class = %d)"),
10497 sym_name
, SYMBOL_CLASS (sym
));
10499 sal
= find_function_start_sal (sym
, 1);
10501 /* Set ADDR_STRING. */
10503 *addr_string
= xstrdup (sym_name
);
10505 /* Set the COND and COND_STRING (if not NULL). */
10507 if (cond_string
!= NULL
&& cond
!= NULL
)
10509 if (*cond_string
!= NULL
)
10511 xfree (*cond_string
);
10512 *cond_string
= NULL
;
10519 if (exp_string
!= NULL
)
10521 *cond_string
= ada_exception_catchpoint_cond_string (exp_string
);
10522 *cond
= ada_parse_catchpoint_condition (*cond_string
, sal
);
10527 *ops
= ada_exception_breakpoint_ops (ex
);
10532 /* Parse the arguments (ARGS) of the "catch exception" command.
10534 Set TYPE to the appropriate exception catchpoint type.
10535 If the user asked the catchpoint to catch only a specific
10536 exception, then save the exception name in ADDR_STRING.
10538 See ada_exception_sal for a description of all the remaining
10539 function arguments of this function. */
10541 struct symtab_and_line
10542 ada_decode_exception_location (char *args
, char **addr_string
,
10543 char **exp_string
, char **cond_string
,
10544 struct expression
**cond
,
10545 struct breakpoint_ops
**ops
)
10547 enum exception_catchpoint_kind ex
;
10549 catch_ada_exception_command_split (args
, &ex
, exp_string
);
10550 return ada_exception_sal (ex
, *exp_string
, addr_string
, cond_string
,
10554 struct symtab_and_line
10555 ada_decode_assert_location (char *args
, char **addr_string
,
10556 struct breakpoint_ops
**ops
)
10558 /* Check that no argument where provided at the end of the command. */
10562 while (isspace (*args
))
10565 error (_("Junk at end of arguments."));
10568 return ada_exception_sal (ex_catch_assert
, NULL
, addr_string
, NULL
, NULL
,
10573 /* Information about operators given special treatment in functions
10575 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10577 #define ADA_OPERATORS \
10578 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10579 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10580 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10581 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10582 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10583 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10584 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10585 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10586 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10587 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10588 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10589 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10590 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10591 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10592 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
10593 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10594 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10595 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10596 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
10599 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
10601 switch (exp
->elts
[pc
- 1].opcode
)
10604 operator_length_standard (exp
, pc
, oplenp
, argsp
);
10607 #define OP_DEFN(op, len, args, binop) \
10608 case op: *oplenp = len; *argsp = args; break;
10614 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
10619 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
10625 ada_op_name (enum exp_opcode opcode
)
10630 return op_name_standard (opcode
);
10632 #define OP_DEFN(op, len, args, binop) case op: return #op;
10637 return "OP_AGGREGATE";
10639 return "OP_CHOICES";
10645 /* As for operator_length, but assumes PC is pointing at the first
10646 element of the operator, and gives meaningful results only for the
10647 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
10650 ada_forward_operator_length (struct expression
*exp
, int pc
,
10651 int *oplenp
, int *argsp
)
10653 switch (exp
->elts
[pc
].opcode
)
10656 *oplenp
= *argsp
= 0;
10659 #define OP_DEFN(op, len, args, binop) \
10660 case op: *oplenp = len; *argsp = args; break;
10666 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10671 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
10677 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10678 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
10686 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
10688 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
10693 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
10697 /* Ada attributes ('Foo). */
10700 case OP_ATR_LENGTH
:
10704 case OP_ATR_MODULUS
:
10711 case UNOP_IN_RANGE
:
10713 /* XXX: gdb_sprint_host_address, type_sprint */
10714 fprintf_filtered (stream
, _("Type @"));
10715 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
10716 fprintf_filtered (stream
, " (");
10717 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
10718 fprintf_filtered (stream
, ")");
10720 case BINOP_IN_BOUNDS
:
10721 fprintf_filtered (stream
, " (%d)",
10722 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
10724 case TERNOP_IN_RANGE
:
10729 case OP_DISCRETE_RANGE
:
10730 case OP_POSITIONAL
:
10737 char *name
= &exp
->elts
[elt
+ 2].string
;
10738 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
10739 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
10744 return dump_subexp_body_standard (exp
, stream
, elt
);
10748 for (i
= 0; i
< nargs
; i
+= 1)
10749 elt
= dump_subexp (exp
, stream
, elt
);
10754 /* The Ada extension of print_subexp (q.v.). */
10757 ada_print_subexp (struct expression
*exp
, int *pos
,
10758 struct ui_file
*stream
, enum precedence prec
)
10760 int oplen
, nargs
, i
;
10762 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
10764 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
10771 print_subexp_standard (exp
, pos
, stream
, prec
);
10775 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
10778 case BINOP_IN_BOUNDS
:
10779 /* XXX: sprint_subexp */
10780 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10781 fputs_filtered (" in ", stream
);
10782 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10783 fputs_filtered ("'range", stream
);
10784 if (exp
->elts
[pc
+ 1].longconst
> 1)
10785 fprintf_filtered (stream
, "(%ld)",
10786 (long) exp
->elts
[pc
+ 1].longconst
);
10789 case TERNOP_IN_RANGE
:
10790 if (prec
>= PREC_EQUAL
)
10791 fputs_filtered ("(", stream
);
10792 /* XXX: sprint_subexp */
10793 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10794 fputs_filtered (" in ", stream
);
10795 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10796 fputs_filtered (" .. ", stream
);
10797 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10798 if (prec
>= PREC_EQUAL
)
10799 fputs_filtered (")", stream
);
10804 case OP_ATR_LENGTH
:
10808 case OP_ATR_MODULUS
:
10813 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10815 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
10816 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
10820 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10821 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
10825 for (tem
= 1; tem
< nargs
; tem
+= 1)
10827 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
10828 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
10830 fputs_filtered (")", stream
);
10835 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
10836 fputs_filtered ("'(", stream
);
10837 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
10838 fputs_filtered (")", stream
);
10841 case UNOP_IN_RANGE
:
10842 /* XXX: sprint_subexp */
10843 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10844 fputs_filtered (" in ", stream
);
10845 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
10848 case OP_DISCRETE_RANGE
:
10849 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10850 fputs_filtered ("..", stream
);
10851 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10855 fputs_filtered ("others => ", stream
);
10856 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10860 for (i
= 0; i
< nargs
-1; i
+= 1)
10863 fputs_filtered ("|", stream
);
10864 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10866 fputs_filtered (" => ", stream
);
10867 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10870 case OP_POSITIONAL
:
10871 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10875 fputs_filtered ("(", stream
);
10876 for (i
= 0; i
< nargs
; i
+= 1)
10879 fputs_filtered (", ", stream
);
10880 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10882 fputs_filtered (")", stream
);
10887 /* Table mapping opcodes into strings for printing operators
10888 and precedences of the operators. */
10890 static const struct op_print ada_op_print_tab
[] = {
10891 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
10892 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
10893 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
10894 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
10895 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
10896 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
10897 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
10898 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
10899 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
10900 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
10901 {">", BINOP_GTR
, PREC_ORDER
, 0},
10902 {"<", BINOP_LESS
, PREC_ORDER
, 0},
10903 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
10904 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
10905 {"+", BINOP_ADD
, PREC_ADD
, 0},
10906 {"-", BINOP_SUB
, PREC_ADD
, 0},
10907 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
10908 {"*", BINOP_MUL
, PREC_MUL
, 0},
10909 {"/", BINOP_DIV
, PREC_MUL
, 0},
10910 {"rem", BINOP_REM
, PREC_MUL
, 0},
10911 {"mod", BINOP_MOD
, PREC_MUL
, 0},
10912 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
10913 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
10914 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
10915 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
10916 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
10917 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
10918 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
10919 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
10920 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
10921 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
10925 enum ada_primitive_types
{
10926 ada_primitive_type_int
,
10927 ada_primitive_type_long
,
10928 ada_primitive_type_short
,
10929 ada_primitive_type_char
,
10930 ada_primitive_type_float
,
10931 ada_primitive_type_double
,
10932 ada_primitive_type_void
,
10933 ada_primitive_type_long_long
,
10934 ada_primitive_type_long_double
,
10935 ada_primitive_type_natural
,
10936 ada_primitive_type_positive
,
10937 ada_primitive_type_system_address
,
10938 nr_ada_primitive_types
10942 ada_language_arch_info (struct gdbarch
*gdbarch
,
10943 struct language_arch_info
*lai
)
10945 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
10946 lai
->primitive_type_vector
10947 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
10949 lai
->primitive_type_vector
[ada_primitive_type_int
] =
10950 init_type (TYPE_CODE_INT
,
10951 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10952 0, "integer", (struct objfile
*) NULL
);
10953 lai
->primitive_type_vector
[ada_primitive_type_long
] =
10954 init_type (TYPE_CODE_INT
,
10955 gdbarch_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10956 0, "long_integer", (struct objfile
*) NULL
);
10957 lai
->primitive_type_vector
[ada_primitive_type_short
] =
10958 init_type (TYPE_CODE_INT
,
10959 gdbarch_short_bit (gdbarch
) / TARGET_CHAR_BIT
,
10960 0, "short_integer", (struct objfile
*) NULL
);
10961 lai
->string_char_type
=
10962 lai
->primitive_type_vector
[ada_primitive_type_char
] =
10963 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10964 0, "character", (struct objfile
*) NULL
);
10965 lai
->primitive_type_vector
[ada_primitive_type_float
] =
10966 init_type (TYPE_CODE_FLT
,
10967 gdbarch_float_bit (gdbarch
)/ TARGET_CHAR_BIT
,
10968 0, "float", (struct objfile
*) NULL
);
10969 lai
->primitive_type_vector
[ada_primitive_type_double
] =
10970 init_type (TYPE_CODE_FLT
,
10971 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10972 0, "long_float", (struct objfile
*) NULL
);
10973 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
10974 init_type (TYPE_CODE_INT
,
10975 gdbarch_long_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10976 0, "long_long_integer", (struct objfile
*) NULL
);
10977 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
10978 init_type (TYPE_CODE_FLT
,
10979 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10980 0, "long_long_float", (struct objfile
*) NULL
);
10981 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
10982 init_type (TYPE_CODE_INT
,
10983 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10984 0, "natural", (struct objfile
*) NULL
);
10985 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
10986 init_type (TYPE_CODE_INT
,
10987 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10988 0, "positive", (struct objfile
*) NULL
);
10989 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
10991 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
10992 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
10993 (struct objfile
*) NULL
));
10994 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
10995 = "system__address";
10997 lai
->bool_type_symbol
= "boolean";
10998 lai
->bool_type_default
= builtin
->builtin_bool
;
11001 /* Language vector */
11003 /* Not really used, but needed in the ada_language_defn. */
11006 emit_char (int c
, struct ui_file
*stream
, int quoter
)
11008 ada_emit_char (c
, stream
, quoter
, 1);
11014 warnings_issued
= 0;
11015 return ada_parse ();
11018 static const struct exp_descriptor ada_exp_descriptor
= {
11020 ada_operator_length
,
11022 ada_dump_subexp_body
,
11023 ada_evaluate_subexp
11026 const struct language_defn ada_language_defn
= {
11027 "ada", /* Language name */
11031 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
11032 that's not quite what this means. */
11034 macro_expansion_no
,
11035 &ada_exp_descriptor
,
11039 ada_printchar
, /* Print a character constant */
11040 ada_printstr
, /* Function to print string constant */
11041 emit_char
, /* Function to print single char (not used) */
11042 ada_print_type
, /* Print a type using appropriate syntax */
11043 default_print_typedef
, /* Print a typedef using appropriate syntax */
11044 ada_val_print
, /* Print a value using appropriate syntax */
11045 ada_value_print
, /* Print a top-level value */
11046 NULL
, /* Language specific skip_trampoline */
11047 NULL
, /* name_of_this */
11048 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
11049 basic_lookup_transparent_type
, /* lookup_transparent_type */
11050 ada_la_decode
, /* Language specific symbol demangler */
11051 NULL
, /* Language specific class_name_from_physname */
11052 ada_op_print_tab
, /* expression operators for printing */
11053 0, /* c-style arrays */
11054 1, /* String lower bound */
11055 ada_get_gdb_completer_word_break_characters
,
11056 ada_make_symbol_completion_list
,
11057 ada_language_arch_info
,
11058 ada_print_array_index
,
11059 default_pass_by_reference
,
11064 _initialize_ada_language (void)
11066 add_language (&ada_language_defn
);
11068 varsize_limit
= 65536;
11070 obstack_init (&symbol_list_obstack
);
11072 decoded_names_store
= htab_create_alloc
11073 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
11074 NULL
, xcalloc
, xfree
);
11076 observer_attach_executable_changed (ada_executable_changed_observer
);