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 set_value_component_location (result
, val
);
487 set_value_bitsize (result
, value_bitsize (val
));
488 set_value_bitpos (result
, value_bitpos (val
));
489 VALUE_ADDRESS (result
) += value_offset (val
);
491 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
492 set_value_lazy (result
, 1);
494 memcpy (value_contents_raw (result
), value_contents (val
),
500 static const gdb_byte
*
501 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
506 return valaddr
+ offset
;
510 cond_offset_target (CORE_ADDR address
, long offset
)
515 return address
+ offset
;
518 /* Issue a warning (as for the definition of warning in utils.c, but
519 with exactly one argument rather than ...), unless the limit on the
520 number of warnings has passed during the evaluation of the current
523 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
524 provided by "complaint". */
525 static void lim_warning (const char *format
, ...) ATTR_FORMAT (printf
, 1, 2);
528 lim_warning (const char *format
, ...)
531 va_start (args
, format
);
533 warnings_issued
+= 1;
534 if (warnings_issued
<= warning_limit
)
535 vwarning (format
, args
);
540 /* Issue an error if the size of an object of type T is unreasonable,
541 i.e. if it would be a bad idea to allocate a value of this type in
545 check_size (const struct type
*type
)
547 if (TYPE_LENGTH (type
) > varsize_limit
)
548 error (_("object size is larger than varsize-limit"));
552 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
553 gdbtypes.h, but some of the necessary definitions in that file
554 seem to have gone missing. */
556 /* Maximum value of a SIZE-byte signed integer type. */
558 max_of_size (int size
)
560 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
561 return top_bit
| (top_bit
- 1);
564 /* Minimum value of a SIZE-byte signed integer type. */
566 min_of_size (int size
)
568 return -max_of_size (size
) - 1;
571 /* Maximum value of a SIZE-byte unsigned integer type. */
573 umax_of_size (int size
)
575 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
576 return top_bit
| (top_bit
- 1);
579 /* Maximum value of integral type T, as a signed quantity. */
581 max_of_type (struct type
*t
)
583 if (TYPE_UNSIGNED (t
))
584 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
586 return max_of_size (TYPE_LENGTH (t
));
589 /* Minimum value of integral type T, as a signed quantity. */
591 min_of_type (struct type
*t
)
593 if (TYPE_UNSIGNED (t
))
596 return min_of_size (TYPE_LENGTH (t
));
599 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
601 discrete_type_high_bound (struct type
*type
)
603 switch (TYPE_CODE (type
))
605 case TYPE_CODE_RANGE
:
606 return TYPE_HIGH_BOUND (type
);
608 return TYPE_FIELD_BITPOS (type
, TYPE_NFIELDS (type
) - 1);
613 return max_of_type (type
);
615 error (_("Unexpected type in discrete_type_high_bound."));
619 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
621 discrete_type_low_bound (struct type
*type
)
623 switch (TYPE_CODE (type
))
625 case TYPE_CODE_RANGE
:
626 return TYPE_LOW_BOUND (type
);
628 return TYPE_FIELD_BITPOS (type
, 0);
633 return min_of_type (type
);
635 error (_("Unexpected type in discrete_type_low_bound."));
639 /* The identity on non-range types. For range types, the underlying
640 non-range scalar type. */
643 base_type (struct type
*type
)
645 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
647 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
649 type
= TYPE_TARGET_TYPE (type
);
655 /* Language Selection */
657 /* If the main program is in Ada, return language_ada, otherwise return LANG
658 (the main program is in Ada iif the adainit symbol is found).
660 MAIN_PST is not used. */
663 ada_update_initial_language (enum language lang
,
664 struct partial_symtab
*main_pst
)
666 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
667 (struct objfile
*) NULL
) != NULL
)
673 /* If the main procedure is written in Ada, then return its name.
674 The result is good until the next call. Return NULL if the main
675 procedure doesn't appear to be in Ada. */
680 struct minimal_symbol
*msym
;
681 CORE_ADDR main_program_name_addr
;
682 static char main_program_name
[1024];
684 /* For Ada, the name of the main procedure is stored in a specific
685 string constant, generated by the binder. Look for that symbol,
686 extract its address, and then read that string. If we didn't find
687 that string, then most probably the main procedure is not written
689 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
693 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
694 if (main_program_name_addr
== 0)
695 error (_("Invalid address for Ada main program name."));
697 extract_string (main_program_name_addr
, main_program_name
);
698 return main_program_name
;
701 /* The main procedure doesn't seem to be in Ada. */
707 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
710 const struct ada_opname_map ada_opname_table
[] = {
711 {"Oadd", "\"+\"", BINOP_ADD
},
712 {"Osubtract", "\"-\"", BINOP_SUB
},
713 {"Omultiply", "\"*\"", BINOP_MUL
},
714 {"Odivide", "\"/\"", BINOP_DIV
},
715 {"Omod", "\"mod\"", BINOP_MOD
},
716 {"Orem", "\"rem\"", BINOP_REM
},
717 {"Oexpon", "\"**\"", BINOP_EXP
},
718 {"Olt", "\"<\"", BINOP_LESS
},
719 {"Ole", "\"<=\"", BINOP_LEQ
},
720 {"Ogt", "\">\"", BINOP_GTR
},
721 {"Oge", "\">=\"", BINOP_GEQ
},
722 {"Oeq", "\"=\"", BINOP_EQUAL
},
723 {"One", "\"/=\"", BINOP_NOTEQUAL
},
724 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
725 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
726 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
727 {"Oconcat", "\"&\"", BINOP_CONCAT
},
728 {"Oabs", "\"abs\"", UNOP_ABS
},
729 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
730 {"Oadd", "\"+\"", UNOP_PLUS
},
731 {"Osubtract", "\"-\"", UNOP_NEG
},
735 /* Return non-zero if STR should be suppressed in info listings. */
738 is_suppressed_name (const char *str
)
740 if (strncmp (str
, "_ada_", 5) == 0)
742 if (str
[0] == '_' || str
[0] == '\000')
747 const char *suffix
= strstr (str
, "___");
748 if (suffix
!= NULL
&& suffix
[3] != 'X')
751 suffix
= str
+ strlen (str
);
752 for (p
= suffix
- 1; p
!= str
; p
-= 1)
756 if (p
[0] == 'X' && p
[-1] != '_')
760 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
761 if (strncmp (ada_opname_table
[i
].encoded
, p
,
762 strlen (ada_opname_table
[i
].encoded
)) == 0)
771 /* The "encoded" form of DECODED, according to GNAT conventions.
772 The result is valid until the next call to ada_encode. */
775 ada_encode (const char *decoded
)
777 static char *encoding_buffer
= NULL
;
778 static size_t encoding_buffer_size
= 0;
785 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
786 2 * strlen (decoded
) + 10);
789 for (p
= decoded
; *p
!= '\0'; p
+= 1)
793 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
798 const struct ada_opname_map
*mapping
;
800 for (mapping
= ada_opname_table
;
801 mapping
->encoded
!= NULL
802 && strncmp (mapping
->decoded
, p
,
803 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
805 if (mapping
->encoded
== NULL
)
806 error (_("invalid Ada operator name: %s"), p
);
807 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
808 k
+= strlen (mapping
->encoded
);
813 encoding_buffer
[k
] = *p
;
818 encoding_buffer
[k
] = '\0';
819 return encoding_buffer
;
822 /* Return NAME folded to lower case, or, if surrounded by single
823 quotes, unfolded, but with the quotes stripped away. Result good
827 ada_fold_name (const char *name
)
829 static char *fold_buffer
= NULL
;
830 static size_t fold_buffer_size
= 0;
832 int len
= strlen (name
);
833 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
837 strncpy (fold_buffer
, name
+ 1, len
- 2);
838 fold_buffer
[len
- 2] = '\000';
843 for (i
= 0; i
<= len
; i
+= 1)
844 fold_buffer
[i
] = tolower (name
[i
]);
850 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
853 is_lower_alphanum (const char c
)
855 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
858 /* Remove either of these suffixes:
863 These are suffixes introduced by the compiler for entities such as
864 nested subprogram for instance, in order to avoid name clashes.
865 They do not serve any purpose for the debugger. */
868 ada_remove_trailing_digits (const char *encoded
, int *len
)
870 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
873 while (i
> 0 && isdigit (encoded
[i
]))
875 if (i
>= 0 && encoded
[i
] == '.')
877 else if (i
>= 0 && encoded
[i
] == '$')
879 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
881 else if (i
>= 1 && strncmp (encoded
+ i
- 1, "__", 2) == 0)
886 /* Remove the suffix introduced by the compiler for protected object
890 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
892 /* Remove trailing N. */
894 /* Protected entry subprograms are broken into two
895 separate subprograms: The first one is unprotected, and has
896 a 'N' suffix; the second is the protected version, and has
897 the 'P' suffix. The second calls the first one after handling
898 the protection. Since the P subprograms are internally generated,
899 we leave these names undecoded, giving the user a clue that this
900 entity is internal. */
903 && encoded
[*len
- 1] == 'N'
904 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
908 /* If ENCODED follows the GNAT entity encoding conventions, then return
909 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
912 The resulting string is valid until the next call of ada_decode.
913 If the string is unchanged by decoding, the original string pointer
917 ada_decode (const char *encoded
)
924 static char *decoding_buffer
= NULL
;
925 static size_t decoding_buffer_size
= 0;
927 /* The name of the Ada main procedure starts with "_ada_".
928 This prefix is not part of the decoded name, so skip this part
929 if we see this prefix. */
930 if (strncmp (encoded
, "_ada_", 5) == 0)
933 /* If the name starts with '_', then it is not a properly encoded
934 name, so do not attempt to decode it. Similarly, if the name
935 starts with '<', the name should not be decoded. */
936 if (encoded
[0] == '_' || encoded
[0] == '<')
939 len0
= strlen (encoded
);
941 ada_remove_trailing_digits (encoded
, &len0
);
942 ada_remove_po_subprogram_suffix (encoded
, &len0
);
944 /* Remove the ___X.* suffix if present. Do not forget to verify that
945 the suffix is located before the current "end" of ENCODED. We want
946 to avoid re-matching parts of ENCODED that have previously been
947 marked as discarded (by decrementing LEN0). */
948 p
= strstr (encoded
, "___");
949 if (p
!= NULL
&& p
- encoded
< len0
- 3)
957 /* Remove any trailing TKB suffix. It tells us that this symbol
958 is for the body of a task, but that information does not actually
959 appear in the decoded name. */
961 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
964 /* Remove trailing "B" suffixes. */
965 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
967 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
970 /* Make decoded big enough for possible expansion by operator name. */
972 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
973 decoded
= decoding_buffer
;
975 /* Remove trailing __{digit}+ or trailing ${digit}+. */
977 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
980 while ((i
>= 0 && isdigit (encoded
[i
]))
981 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
983 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
985 else if (encoded
[i
] == '$')
989 /* The first few characters that are not alphabetic are not part
990 of any encoding we use, so we can copy them over verbatim. */
992 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
993 decoded
[j
] = encoded
[i
];
998 /* Is this a symbol function? */
999 if (at_start_name
&& encoded
[i
] == 'O')
1002 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1004 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1005 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1007 && !isalnum (encoded
[i
+ op_len
]))
1009 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1012 j
+= strlen (ada_opname_table
[k
].decoded
);
1016 if (ada_opname_table
[k
].encoded
!= NULL
)
1021 /* Replace "TK__" with "__", which will eventually be translated
1022 into "." (just below). */
1024 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
1027 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1028 be translated into "." (just below). These are internal names
1029 generated for anonymous blocks inside which our symbol is nested. */
1031 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1032 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1033 && isdigit (encoded
[i
+4]))
1037 while (k
< len0
&& isdigit (encoded
[k
]))
1038 k
++; /* Skip any extra digit. */
1040 /* Double-check that the "__B_{DIGITS}+" sequence we found
1041 is indeed followed by "__". */
1042 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1046 /* Remove _E{DIGITS}+[sb] */
1048 /* Just as for protected object subprograms, there are 2 categories
1049 of subprograms created by the compiler for each entry. The first
1050 one implements the actual entry code, and has a suffix following
1051 the convention above; the second one implements the barrier and
1052 uses the same convention as above, except that the 'E' is replaced
1055 Just as above, we do not decode the name of barrier functions
1056 to give the user a clue that the code he is debugging has been
1057 internally generated. */
1059 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1060 && isdigit (encoded
[i
+2]))
1064 while (k
< len0
&& isdigit (encoded
[k
]))
1068 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1071 /* Just as an extra precaution, make sure that if this
1072 suffix is followed by anything else, it is a '_'.
1073 Otherwise, we matched this sequence by accident. */
1075 || (k
< len0
&& encoded
[k
] == '_'))
1080 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1081 the GNAT front-end in protected object subprograms. */
1084 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1086 /* Backtrack a bit up until we reach either the begining of
1087 the encoded name, or "__". Make sure that we only find
1088 digits or lowercase characters. */
1089 const char *ptr
= encoded
+ i
- 1;
1091 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1094 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1098 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1100 /* This is a X[bn]* sequence not separated from the previous
1101 part of the name with a non-alpha-numeric character (in other
1102 words, immediately following an alpha-numeric character), then
1103 verify that it is placed at the end of the encoded name. If
1104 not, then the encoding is not valid and we should abort the
1105 decoding. Otherwise, just skip it, it is used in body-nested
1109 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1113 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1115 /* Replace '__' by '.'. */
1123 /* It's a character part of the decoded name, so just copy it
1125 decoded
[j
] = encoded
[i
];
1130 decoded
[j
] = '\000';
1132 /* Decoded names should never contain any uppercase character.
1133 Double-check this, and abort the decoding if we find one. */
1135 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1136 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1139 if (strcmp (decoded
, encoded
) == 0)
1145 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1146 decoded
= decoding_buffer
;
1147 if (encoded
[0] == '<')
1148 strcpy (decoded
, encoded
);
1150 sprintf (decoded
, "<%s>", encoded
);
1155 /* Table for keeping permanent unique copies of decoded names. Once
1156 allocated, names in this table are never released. While this is a
1157 storage leak, it should not be significant unless there are massive
1158 changes in the set of decoded names in successive versions of a
1159 symbol table loaded during a single session. */
1160 static struct htab
*decoded_names_store
;
1162 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1163 in the language-specific part of GSYMBOL, if it has not been
1164 previously computed. Tries to save the decoded name in the same
1165 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1166 in any case, the decoded symbol has a lifetime at least that of
1168 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1169 const, but nevertheless modified to a semantically equivalent form
1170 when a decoded name is cached in it.
1174 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1177 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
1178 if (*resultp
== NULL
)
1180 const char *decoded
= ada_decode (gsymbol
->name
);
1181 if (gsymbol
->obj_section
!= NULL
)
1183 struct objfile
*objf
= gsymbol
->obj_section
->objfile
;
1184 *resultp
= obsavestring (decoded
, strlen (decoded
),
1185 &objf
->objfile_obstack
);
1187 /* Sometimes, we can't find a corresponding objfile, in which
1188 case, we put the result on the heap. Since we only decode
1189 when needed, we hope this usually does not cause a
1190 significant memory leak (FIXME). */
1191 if (*resultp
== NULL
)
1193 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1196 *slot
= xstrdup (decoded
);
1205 ada_la_decode (const char *encoded
, int options
)
1207 return xstrdup (ada_decode (encoded
));
1210 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1211 suffixes that encode debugging information or leading _ada_ on
1212 SYM_NAME (see is_name_suffix commentary for the debugging
1213 information that is ignored). If WILD, then NAME need only match a
1214 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1215 either argument is NULL. */
1218 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1220 if (sym_name
== NULL
|| name
== NULL
)
1223 return wild_match (name
, strlen (name
), sym_name
);
1226 int len_name
= strlen (name
);
1227 return (strncmp (sym_name
, name
, len_name
) == 0
1228 && is_name_suffix (sym_name
+ len_name
))
1229 || (strncmp (sym_name
, "_ada_", 5) == 0
1230 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1231 && is_name_suffix (sym_name
+ len_name
+ 5));
1235 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1236 suppressed in info listings. */
1239 ada_suppress_symbol_printing (struct symbol
*sym
)
1241 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1244 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1250 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1252 static char *bound_name
[] = {
1253 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1254 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1257 /* Maximum number of array dimensions we are prepared to handle. */
1259 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1261 /* Like modify_field, but allows bitpos > wordlength. */
1264 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1266 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1270 /* The desc_* routines return primitive portions of array descriptors
1273 /* The descriptor or array type, if any, indicated by TYPE; removes
1274 level of indirection, if needed. */
1276 static struct type
*
1277 desc_base_type (struct type
*type
)
1281 type
= ada_check_typedef (type
);
1283 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1284 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1285 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1290 /* True iff TYPE indicates a "thin" array pointer type. */
1293 is_thin_pntr (struct type
*type
)
1296 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1297 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1300 /* The descriptor type for thin pointer type TYPE. */
1302 static struct type
*
1303 thin_descriptor_type (struct type
*type
)
1305 struct type
*base_type
= desc_base_type (type
);
1306 if (base_type
== NULL
)
1308 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1312 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1313 if (alt_type
== NULL
)
1320 /* A pointer to the array data for thin-pointer value VAL. */
1322 static struct value
*
1323 thin_data_pntr (struct value
*val
)
1325 struct type
*type
= value_type (val
);
1326 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1327 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1330 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1331 VALUE_ADDRESS (val
) + value_offset (val
));
1334 /* True iff TYPE indicates a "thick" array pointer type. */
1337 is_thick_pntr (struct type
*type
)
1339 type
= desc_base_type (type
);
1340 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1341 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1344 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1345 pointer to one, the type of its bounds data; otherwise, NULL. */
1347 static struct type
*
1348 desc_bounds_type (struct type
*type
)
1352 type
= desc_base_type (type
);
1356 else if (is_thin_pntr (type
))
1358 type
= thin_descriptor_type (type
);
1361 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1363 return ada_check_typedef (r
);
1365 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1367 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1369 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1374 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1375 one, a pointer to its bounds data. Otherwise NULL. */
1377 static struct value
*
1378 desc_bounds (struct value
*arr
)
1380 struct type
*type
= ada_check_typedef (value_type (arr
));
1381 if (is_thin_pntr (type
))
1383 struct type
*bounds_type
=
1384 desc_bounds_type (thin_descriptor_type (type
));
1387 if (bounds_type
== NULL
)
1388 error (_("Bad GNAT array descriptor"));
1390 /* NOTE: The following calculation is not really kosher, but
1391 since desc_type is an XVE-encoded type (and shouldn't be),
1392 the correct calculation is a real pain. FIXME (and fix GCC). */
1393 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1394 addr
= value_as_long (arr
);
1396 addr
= VALUE_ADDRESS (arr
) + value_offset (arr
);
1399 value_from_longest (lookup_pointer_type (bounds_type
),
1400 addr
- TYPE_LENGTH (bounds_type
));
1403 else if (is_thick_pntr (type
))
1404 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1405 _("Bad GNAT array descriptor"));
1410 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1411 position of the field containing the address of the bounds data. */
1414 fat_pntr_bounds_bitpos (struct type
*type
)
1416 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1419 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1420 size of the field containing the address of the bounds data. */
1423 fat_pntr_bounds_bitsize (struct type
*type
)
1425 type
= desc_base_type (type
);
1427 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1428 return TYPE_FIELD_BITSIZE (type
, 1);
1430 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1433 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1434 pointer to one, the type of its array data (a
1435 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1436 ada_type_of_array to get an array type with bounds data. */
1438 static struct type
*
1439 desc_data_type (struct type
*type
)
1441 type
= desc_base_type (type
);
1443 /* NOTE: The following is bogus; see comment in desc_bounds. */
1444 if (is_thin_pntr (type
))
1445 return lookup_pointer_type
1446 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1447 else if (is_thick_pntr (type
))
1448 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1453 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1456 static struct value
*
1457 desc_data (struct value
*arr
)
1459 struct type
*type
= value_type (arr
);
1460 if (is_thin_pntr (type
))
1461 return thin_data_pntr (arr
);
1462 else if (is_thick_pntr (type
))
1463 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1464 _("Bad GNAT array descriptor"));
1470 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1471 position of the field containing the address of the data. */
1474 fat_pntr_data_bitpos (struct type
*type
)
1476 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1479 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1480 size of the field containing the address of the data. */
1483 fat_pntr_data_bitsize (struct type
*type
)
1485 type
= desc_base_type (type
);
1487 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1488 return TYPE_FIELD_BITSIZE (type
, 0);
1490 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1493 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1494 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1495 bound, if WHICH is 1. The first bound is I=1. */
1497 static struct value
*
1498 desc_one_bound (struct value
*bounds
, int i
, int which
)
1500 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1501 _("Bad GNAT array descriptor bounds"));
1504 /* If BOUNDS is an array-bounds structure type, return the bit position
1505 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1506 bound, if WHICH is 1. The first bound is I=1. */
1509 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1511 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1514 /* If BOUNDS is an array-bounds structure type, return the bit field size
1515 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1516 bound, if WHICH is 1. The first bound is I=1. */
1519 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1521 type
= desc_base_type (type
);
1523 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1524 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1526 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1529 /* If TYPE is the type of an array-bounds structure, the type of its
1530 Ith bound (numbering from 1). Otherwise, NULL. */
1532 static struct type
*
1533 desc_index_type (struct type
*type
, int i
)
1535 type
= desc_base_type (type
);
1537 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1538 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1543 /* The number of index positions in the array-bounds type TYPE.
1544 Return 0 if TYPE is NULL. */
1547 desc_arity (struct type
*type
)
1549 type
= desc_base_type (type
);
1552 return TYPE_NFIELDS (type
) / 2;
1556 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1557 an array descriptor type (representing an unconstrained array
1561 ada_is_direct_array_type (struct type
*type
)
1565 type
= ada_check_typedef (type
);
1566 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1567 || ada_is_array_descriptor_type (type
));
1570 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1574 ada_is_array_type (struct type
*type
)
1577 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1578 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1579 type
= TYPE_TARGET_TYPE (type
);
1580 return ada_is_direct_array_type (type
);
1583 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1586 ada_is_simple_array_type (struct type
*type
)
1590 type
= ada_check_typedef (type
);
1591 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1592 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1593 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1596 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1599 ada_is_array_descriptor_type (struct type
*type
)
1601 struct type
*data_type
= desc_data_type (type
);
1605 type
= ada_check_typedef (type
);
1608 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1609 && TYPE_TARGET_TYPE (data_type
) != NULL
1610 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1611 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1612 && desc_arity (desc_bounds_type (type
)) > 0;
1615 /* Non-zero iff type is a partially mal-formed GNAT array
1616 descriptor. FIXME: This is to compensate for some problems with
1617 debugging output from GNAT. Re-examine periodically to see if it
1621 ada_is_bogus_array_descriptor (struct type
*type
)
1625 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1626 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1627 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1628 && !ada_is_array_descriptor_type (type
);
1632 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1633 (fat pointer) returns the type of the array data described---specifically,
1634 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1635 in from the descriptor; otherwise, they are left unspecified. If
1636 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1637 returns NULL. The result is simply the type of ARR if ARR is not
1640 ada_type_of_array (struct value
*arr
, int bounds
)
1642 if (ada_is_packed_array_type (value_type (arr
)))
1643 return decode_packed_array_type (value_type (arr
));
1645 if (!ada_is_array_descriptor_type (value_type (arr
)))
1646 return value_type (arr
);
1650 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr
))));
1653 struct type
*elt_type
;
1655 struct value
*descriptor
;
1656 struct objfile
*objf
= TYPE_OBJFILE (value_type (arr
));
1658 elt_type
= ada_array_element_type (value_type (arr
), -1);
1659 arity
= ada_array_arity (value_type (arr
));
1661 if (elt_type
== NULL
|| arity
== 0)
1662 return ada_check_typedef (value_type (arr
));
1664 descriptor
= desc_bounds (arr
);
1665 if (value_as_long (descriptor
) == 0)
1669 struct type
*range_type
= alloc_type (objf
);
1670 struct type
*array_type
= alloc_type (objf
);
1671 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1672 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1675 create_range_type (range_type
, value_type (low
),
1676 longest_to_int (value_as_long (low
)),
1677 longest_to_int (value_as_long (high
)));
1678 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1681 return lookup_pointer_type (elt_type
);
1685 /* If ARR does not represent an array, returns ARR unchanged.
1686 Otherwise, returns either a standard GDB array with bounds set
1687 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1688 GDB array. Returns NULL if ARR is a null fat pointer. */
1691 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1693 if (ada_is_array_descriptor_type (value_type (arr
)))
1695 struct type
*arrType
= ada_type_of_array (arr
, 1);
1696 if (arrType
== NULL
)
1698 return value_cast (arrType
, value_copy (desc_data (arr
)));
1700 else if (ada_is_packed_array_type (value_type (arr
)))
1701 return decode_packed_array (arr
);
1706 /* If ARR does not represent an array, returns ARR unchanged.
1707 Otherwise, returns a standard GDB array describing ARR (which may
1708 be ARR itself if it already is in the proper form). */
1710 static struct value
*
1711 ada_coerce_to_simple_array (struct value
*arr
)
1713 if (ada_is_array_descriptor_type (value_type (arr
)))
1715 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1717 error (_("Bounds unavailable for null array pointer."));
1718 check_size (TYPE_TARGET_TYPE (value_type (arrVal
)));
1719 return value_ind (arrVal
);
1721 else if (ada_is_packed_array_type (value_type (arr
)))
1722 return decode_packed_array (arr
);
1727 /* If TYPE represents a GNAT array type, return it translated to an
1728 ordinary GDB array type (possibly with BITSIZE fields indicating
1729 packing). For other types, is the identity. */
1732 ada_coerce_to_simple_array_type (struct type
*type
)
1734 struct value
*mark
= value_mark ();
1735 struct value
*dummy
= value_from_longest (builtin_type_int32
, 0);
1736 struct type
*result
;
1737 deprecated_set_value_type (dummy
, type
);
1738 result
= ada_type_of_array (dummy
, 0);
1739 value_free_to_mark (mark
);
1743 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1746 ada_is_packed_array_type (struct type
*type
)
1750 type
= desc_base_type (type
);
1751 type
= ada_check_typedef (type
);
1753 ada_type_name (type
) != NULL
1754 && strstr (ada_type_name (type
), "___XP") != NULL
;
1757 /* Given that TYPE is a standard GDB array type with all bounds filled
1758 in, and that the element size of its ultimate scalar constituents
1759 (that is, either its elements, or, if it is an array of arrays, its
1760 elements' elements, etc.) is *ELT_BITS, return an identical type,
1761 but with the bit sizes of its elements (and those of any
1762 constituent arrays) recorded in the BITSIZE components of its
1763 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1766 static struct type
*
1767 packed_array_type (struct type
*type
, long *elt_bits
)
1769 struct type
*new_elt_type
;
1770 struct type
*new_type
;
1771 LONGEST low_bound
, high_bound
;
1773 type
= ada_check_typedef (type
);
1774 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1777 new_type
= alloc_type (TYPE_OBJFILE (type
));
1778 new_elt_type
= packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1780 create_array_type (new_type
, new_elt_type
, TYPE_INDEX_TYPE (type
));
1781 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1782 TYPE_NAME (new_type
) = ada_type_name (type
);
1784 if (get_discrete_bounds (TYPE_INDEX_TYPE (type
),
1785 &low_bound
, &high_bound
) < 0)
1786 low_bound
= high_bound
= 0;
1787 if (high_bound
< low_bound
)
1788 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1791 *elt_bits
*= (high_bound
- low_bound
+ 1);
1792 TYPE_LENGTH (new_type
) =
1793 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1796 TYPE_FIXED_INSTANCE (new_type
) = 1;
1800 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1802 static struct type
*
1803 decode_packed_array_type (struct type
*type
)
1806 struct block
**blocks
;
1807 char *raw_name
= ada_type_name (ada_check_typedef (type
));
1810 struct type
*shadow_type
;
1815 raw_name
= ada_type_name (desc_base_type (type
));
1820 name
= (char *) alloca (strlen (raw_name
) + 1);
1821 tail
= strstr (raw_name
, "___XP");
1822 type
= desc_base_type (type
);
1824 memcpy (name
, raw_name
, tail
- raw_name
);
1825 name
[tail
- raw_name
] = '\000';
1827 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1828 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1830 lim_warning (_("could not find bounds information on packed array"));
1833 shadow_type
= SYMBOL_TYPE (sym
);
1835 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1837 lim_warning (_("could not understand bounds information on packed array"));
1841 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1844 (_("could not understand bit size information on packed array"));
1848 return packed_array_type (shadow_type
, &bits
);
1851 /* Given that ARR is a struct value *indicating a GNAT packed array,
1852 returns a simple array that denotes that array. Its type is a
1853 standard GDB array type except that the BITSIZEs of the array
1854 target types are set to the number of bits in each element, and the
1855 type length is set appropriately. */
1857 static struct value
*
1858 decode_packed_array (struct value
*arr
)
1862 arr
= ada_coerce_ref (arr
);
1863 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
1864 arr
= ada_value_ind (arr
);
1866 type
= decode_packed_array_type (value_type (arr
));
1869 error (_("can't unpack array"));
1873 if (gdbarch_bits_big_endian (current_gdbarch
)
1874 && ada_is_modular_type (value_type (arr
)))
1876 /* This is a (right-justified) modular type representing a packed
1877 array with no wrapper. In order to interpret the value through
1878 the (left-justified) packed array type we just built, we must
1879 first left-justify it. */
1880 int bit_size
, bit_pos
;
1883 mod
= ada_modulus (value_type (arr
)) - 1;
1890 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
1891 arr
= ada_value_primitive_packed_val (arr
, NULL
,
1892 bit_pos
/ HOST_CHAR_BIT
,
1893 bit_pos
% HOST_CHAR_BIT
,
1898 return coerce_unspec_val_to_type (arr
, type
);
1902 /* The value of the element of packed array ARR at the ARITY indices
1903 given in IND. ARR must be a simple array. */
1905 static struct value
*
1906 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1909 int bits
, elt_off
, bit_off
;
1910 long elt_total_bit_offset
;
1911 struct type
*elt_type
;
1915 elt_total_bit_offset
= 0;
1916 elt_type
= ada_check_typedef (value_type (arr
));
1917 for (i
= 0; i
< arity
; i
+= 1)
1919 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1920 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1922 (_("attempt to do packed indexing of something other than a packed array"));
1925 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1926 LONGEST lowerbound
, upperbound
;
1929 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1931 lim_warning (_("don't know bounds of array"));
1932 lowerbound
= upperbound
= 0;
1935 idx
= pos_atr (ind
[i
]);
1936 if (idx
< lowerbound
|| idx
> upperbound
)
1937 lim_warning (_("packed array index %ld out of bounds"), (long) idx
);
1938 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1939 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1940 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
1943 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1944 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1946 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1951 /* Non-zero iff TYPE includes negative integer values. */
1954 has_negatives (struct type
*type
)
1956 switch (TYPE_CODE (type
))
1961 return !TYPE_UNSIGNED (type
);
1962 case TYPE_CODE_RANGE
:
1963 return TYPE_LOW_BOUND (type
) < 0;
1968 /* Create a new value of type TYPE from the contents of OBJ starting
1969 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1970 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1971 assigning through the result will set the field fetched from.
1972 VALADDR is ignored unless OBJ is NULL, in which case,
1973 VALADDR+OFFSET must address the start of storage containing the
1974 packed value. The value returned in this case is never an lval.
1975 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1978 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
1979 long offset
, int bit_offset
, int bit_size
,
1983 int src
, /* Index into the source area */
1984 targ
, /* Index into the target area */
1985 srcBitsLeft
, /* Number of source bits left to move */
1986 nsrc
, ntarg
, /* Number of source and target bytes */
1987 unusedLS
, /* Number of bits in next significant
1988 byte of source that are unused */
1989 accumSize
; /* Number of meaningful bits in accum */
1990 unsigned char *bytes
; /* First byte containing data to unpack */
1991 unsigned char *unpacked
;
1992 unsigned long accum
; /* Staging area for bits being transferred */
1994 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1995 /* Transmit bytes from least to most significant; delta is the direction
1996 the indices move. */
1997 int delta
= gdbarch_bits_big_endian (current_gdbarch
) ? -1 : 1;
1999 type
= ada_check_typedef (type
);
2003 v
= allocate_value (type
);
2004 bytes
= (unsigned char *) (valaddr
+ offset
);
2006 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2009 VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
);
2010 bytes
= (unsigned char *) alloca (len
);
2011 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
2015 v
= allocate_value (type
);
2016 bytes
= (unsigned char *) value_contents (obj
) + offset
;
2021 set_value_component_location (v
, obj
);
2022 VALUE_ADDRESS (v
) += value_offset (obj
) + offset
;
2023 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2024 set_value_bitsize (v
, bit_size
);
2025 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2027 VALUE_ADDRESS (v
) += 1;
2028 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2032 set_value_bitsize (v
, bit_size
);
2033 unpacked
= (unsigned char *) value_contents (v
);
2035 srcBitsLeft
= bit_size
;
2037 ntarg
= TYPE_LENGTH (type
);
2041 memset (unpacked
, 0, TYPE_LENGTH (type
));
2044 else if (gdbarch_bits_big_endian (current_gdbarch
))
2047 if (has_negatives (type
)
2048 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2052 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2055 switch (TYPE_CODE (type
))
2057 case TYPE_CODE_ARRAY
:
2058 case TYPE_CODE_UNION
:
2059 case TYPE_CODE_STRUCT
:
2060 /* Non-scalar values must be aligned at a byte boundary... */
2062 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2063 /* ... And are placed at the beginning (most-significant) bytes
2065 targ
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2069 targ
= TYPE_LENGTH (type
) - 1;
2075 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2078 unusedLS
= bit_offset
;
2081 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
2088 /* Mask for removing bits of the next source byte that are not
2089 part of the value. */
2090 unsigned int unusedMSMask
=
2091 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2093 /* Sign-extend bits for this byte. */
2094 unsigned int signMask
= sign
& ~unusedMSMask
;
2096 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2097 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2098 if (accumSize
>= HOST_CHAR_BIT
)
2100 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2101 accumSize
-= HOST_CHAR_BIT
;
2102 accum
>>= HOST_CHAR_BIT
;
2106 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2113 accum
|= sign
<< accumSize
;
2114 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2115 accumSize
-= HOST_CHAR_BIT
;
2116 accum
>>= HOST_CHAR_BIT
;
2124 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2125 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2128 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
2129 int src_offset
, int n
)
2131 unsigned int accum
, mask
;
2132 int accum_bits
, chunk_size
;
2134 target
+= targ_offset
/ HOST_CHAR_BIT
;
2135 targ_offset
%= HOST_CHAR_BIT
;
2136 source
+= src_offset
/ HOST_CHAR_BIT
;
2137 src_offset
%= HOST_CHAR_BIT
;
2138 if (gdbarch_bits_big_endian (current_gdbarch
))
2140 accum
= (unsigned char) *source
;
2142 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2147 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2148 accum_bits
+= HOST_CHAR_BIT
;
2150 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2153 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2154 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2157 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2159 accum_bits
-= chunk_size
;
2166 accum
= (unsigned char) *source
>> src_offset
;
2168 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2172 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2173 accum_bits
+= HOST_CHAR_BIT
;
2175 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2178 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2179 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2181 accum_bits
-= chunk_size
;
2182 accum
>>= chunk_size
;
2189 /* Store the contents of FROMVAL into the location of TOVAL.
2190 Return a new value with the location of TOVAL and contents of
2191 FROMVAL. Handles assignment into packed fields that have
2192 floating-point or non-scalar types. */
2194 static struct value
*
2195 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2197 struct type
*type
= value_type (toval
);
2198 int bits
= value_bitsize (toval
);
2200 toval
= ada_coerce_ref (toval
);
2201 fromval
= ada_coerce_ref (fromval
);
2203 if (ada_is_direct_array_type (value_type (toval
)))
2204 toval
= ada_coerce_to_simple_array (toval
);
2205 if (ada_is_direct_array_type (value_type (fromval
)))
2206 fromval
= ada_coerce_to_simple_array (fromval
);
2208 if (!deprecated_value_modifiable (toval
))
2209 error (_("Left operand of assignment is not a modifiable lvalue."));
2211 if (VALUE_LVAL (toval
) == lval_memory
2213 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2214 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2216 int len
= (value_bitpos (toval
)
2217 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2219 char *buffer
= (char *) alloca (len
);
2221 CORE_ADDR to_addr
= VALUE_ADDRESS (toval
) + value_offset (toval
);
2223 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2224 fromval
= value_cast (type
, fromval
);
2226 read_memory (to_addr
, buffer
, len
);
2227 from_size
= value_bitsize (fromval
);
2229 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2230 if (gdbarch_bits_big_endian (current_gdbarch
))
2231 move_bits (buffer
, value_bitpos (toval
),
2232 value_contents (fromval
), from_size
- bits
, bits
);
2234 move_bits (buffer
, value_bitpos (toval
), value_contents (fromval
),
2236 write_memory (to_addr
, buffer
, len
);
2237 if (deprecated_memory_changed_hook
)
2238 deprecated_memory_changed_hook (to_addr
, len
);
2240 val
= value_copy (toval
);
2241 memcpy (value_contents_raw (val
), value_contents (fromval
),
2242 TYPE_LENGTH (type
));
2243 deprecated_set_value_type (val
, type
);
2248 return value_assign (toval
, fromval
);
2252 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2253 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2254 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2255 * COMPONENT, and not the inferior's memory. The current contents
2256 * of COMPONENT are ignored. */
2258 value_assign_to_component (struct value
*container
, struct value
*component
,
2261 LONGEST offset_in_container
=
2262 (LONGEST
) (VALUE_ADDRESS (component
) + value_offset (component
)
2263 - VALUE_ADDRESS (container
) - value_offset (container
));
2264 int bit_offset_in_container
=
2265 value_bitpos (component
) - value_bitpos (container
);
2268 val
= value_cast (value_type (component
), val
);
2270 if (value_bitsize (component
) == 0)
2271 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2273 bits
= value_bitsize (component
);
2275 if (gdbarch_bits_big_endian (current_gdbarch
))
2276 move_bits (value_contents_writeable (container
) + offset_in_container
,
2277 value_bitpos (container
) + bit_offset_in_container
,
2278 value_contents (val
),
2279 TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
,
2282 move_bits (value_contents_writeable (container
) + offset_in_container
,
2283 value_bitpos (container
) + bit_offset_in_container
,
2284 value_contents (val
), 0, bits
);
2287 /* The value of the element of array ARR at the ARITY indices given in IND.
2288 ARR may be either a simple array, GNAT array descriptor, or pointer
2292 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2296 struct type
*elt_type
;
2298 elt
= ada_coerce_to_simple_array (arr
);
2300 elt_type
= ada_check_typedef (value_type (elt
));
2301 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2302 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2303 return value_subscript_packed (elt
, arity
, ind
);
2305 for (k
= 0; k
< arity
; k
+= 1)
2307 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2308 error (_("too many subscripts (%d expected)"), k
);
2309 elt
= value_subscript (elt
, value_pos_atr (builtin_type_int32
, ind
[k
]));
2314 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2315 value of the element of *ARR at the ARITY indices given in
2316 IND. Does not read the entire array into memory. */
2319 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2324 for (k
= 0; k
< arity
; k
+= 1)
2329 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2330 error (_("too many subscripts (%d expected)"), k
);
2331 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2333 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2334 idx
= value_pos_atr (builtin_type_int32
, ind
[k
]);
2336 idx
= value_binop (idx
, value_from_longest (value_type (idx
), lwb
),
2339 arr
= value_ptradd (arr
, idx
);
2340 type
= TYPE_TARGET_TYPE (type
);
2343 return value_ind (arr
);
2346 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2347 actual type of ARRAY_PTR is ignored), returns the Ada slice of HIGH-LOW+1
2348 elements starting at index LOW. The lower bound of this array is LOW, as
2350 static struct value
*
2351 ada_value_slice_from_ptr (struct value
*array_ptr
, struct type
*type
,
2354 CORE_ADDR base
= value_as_address (array_ptr
)
2355 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2356 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2357 struct type
*index_type
=
2358 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2360 struct type
*slice_type
=
2361 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2362 return value_at_lazy (slice_type
, base
);
2366 static struct value
*
2367 ada_value_slice (struct value
*array
, int low
, int high
)
2369 struct type
*type
= value_type (array
);
2370 struct type
*index_type
=
2371 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2372 struct type
*slice_type
=
2373 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2374 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2377 /* If type is a record type in the form of a standard GNAT array
2378 descriptor, returns the number of dimensions for type. If arr is a
2379 simple array, returns the number of "array of"s that prefix its
2380 type designation. Otherwise, returns 0. */
2383 ada_array_arity (struct type
*type
)
2390 type
= desc_base_type (type
);
2393 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2394 return desc_arity (desc_bounds_type (type
));
2396 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2399 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2405 /* If TYPE is a record type in the form of a standard GNAT array
2406 descriptor or a simple array type, returns the element type for
2407 TYPE after indexing by NINDICES indices, or by all indices if
2408 NINDICES is -1. Otherwise, returns NULL. */
2411 ada_array_element_type (struct type
*type
, int nindices
)
2413 type
= desc_base_type (type
);
2415 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2418 struct type
*p_array_type
;
2420 p_array_type
= desc_data_type (type
);
2422 k
= ada_array_arity (type
);
2426 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2427 if (nindices
>= 0 && k
> nindices
)
2429 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2430 while (k
> 0 && p_array_type
!= NULL
)
2432 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2435 return p_array_type
;
2437 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2439 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2441 type
= TYPE_TARGET_TYPE (type
);
2450 /* The type of nth index in arrays of given type (n numbering from 1).
2451 Does not examine memory. */
2454 ada_index_type (struct type
*type
, int n
)
2456 struct type
*result_type
;
2458 type
= desc_base_type (type
);
2460 if (n
> ada_array_arity (type
))
2463 if (ada_is_simple_array_type (type
))
2467 for (i
= 1; i
< n
; i
+= 1)
2468 type
= TYPE_TARGET_TYPE (type
);
2469 result_type
= TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
));
2470 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2471 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2472 perhaps stabsread.c would make more sense. */
2473 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2474 result_type
= builtin_type_int32
;
2479 return desc_index_type (desc_bounds_type (type
), n
);
2482 /* Given that arr is an array type, returns the lower bound of the
2483 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2484 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2485 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2486 bounds type. It works for other arrays with bounds supplied by
2487 run-time quantities other than discriminants. */
2490 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2491 struct type
** typep
)
2493 struct type
*type
, *index_type_desc
, *index_type
;
2496 gdb_assert (which
== 0 || which
== 1);
2498 if (ada_is_packed_array_type (arr_type
))
2499 arr_type
= decode_packed_array_type (arr_type
);
2501 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2504 *typep
= builtin_type_int32
;
2505 return (LONGEST
) - which
;
2508 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2509 type
= TYPE_TARGET_TYPE (arr_type
);
2513 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2514 if (index_type_desc
!= NULL
)
2515 index_type
= to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2516 NULL
, TYPE_OBJFILE (arr_type
));
2521 type
= TYPE_TARGET_TYPE (type
);
2525 index_type
= TYPE_INDEX_TYPE (type
);
2528 switch (TYPE_CODE (index_type
))
2530 case TYPE_CODE_RANGE
:
2531 retval
= which
== 0 ? TYPE_LOW_BOUND (index_type
)
2532 : TYPE_HIGH_BOUND (index_type
);
2534 case TYPE_CODE_ENUM
:
2535 retval
= which
== 0 ? TYPE_FIELD_BITPOS (index_type
, 0)
2536 : TYPE_FIELD_BITPOS (index_type
,
2537 TYPE_NFIELDS (index_type
) - 1);
2540 internal_error (__FILE__
, __LINE__
, _("invalid type code of index type"));
2544 *typep
= index_type
;
2549 /* Given that arr is an array value, returns the lower bound of the
2550 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2551 WHICH is 1. This routine will also work for arrays with bounds
2552 supplied by run-time quantities other than discriminants. */
2555 ada_array_bound (struct value
*arr
, int n
, int which
)
2557 struct type
*arr_type
= value_type (arr
);
2559 if (ada_is_packed_array_type (arr_type
))
2560 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2561 else if (ada_is_simple_array_type (arr_type
))
2564 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2565 return value_from_longest (type
, v
);
2568 return desc_one_bound (desc_bounds (arr
), n
, which
);
2571 /* Given that arr is an array value, returns the length of the
2572 nth index. This routine will also work for arrays with bounds
2573 supplied by run-time quantities other than discriminants.
2574 Does not work for arrays indexed by enumeration types with representation
2575 clauses at the moment. */
2578 ada_array_length (struct value
*arr
, int n
)
2580 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2582 if (ada_is_packed_array_type (arr_type
))
2583 return ada_array_length (decode_packed_array (arr
), n
);
2585 if (ada_is_simple_array_type (arr_type
))
2589 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2590 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2591 return value_from_longest (type
, v
);
2595 value_from_longest (builtin_type_int32
,
2596 value_as_long (desc_one_bound (desc_bounds (arr
),
2598 - value_as_long (desc_one_bound (desc_bounds (arr
),
2602 /* An empty array whose type is that of ARR_TYPE (an array type),
2603 with bounds LOW to LOW-1. */
2605 static struct value
*
2606 empty_array (struct type
*arr_type
, int low
)
2608 struct type
*index_type
=
2609 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2611 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2612 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2616 /* Name resolution */
2618 /* The "decoded" name for the user-definable Ada operator corresponding
2622 ada_decoded_op_name (enum exp_opcode op
)
2626 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2628 if (ada_opname_table
[i
].op
== op
)
2629 return ada_opname_table
[i
].decoded
;
2631 error (_("Could not find operator name for opcode"));
2635 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2636 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2637 undefined namespace) and converts operators that are
2638 user-defined into appropriate function calls. If CONTEXT_TYPE is
2639 non-null, it provides a preferred result type [at the moment, only
2640 type void has any effect---causing procedures to be preferred over
2641 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2642 return type is preferred. May change (expand) *EXP. */
2645 resolve (struct expression
**expp
, int void_context_p
)
2649 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2652 /* Resolve the operator of the subexpression beginning at
2653 position *POS of *EXPP. "Resolving" consists of replacing
2654 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2655 with their resolutions, replacing built-in operators with
2656 function calls to user-defined operators, where appropriate, and,
2657 when DEPROCEDURE_P is non-zero, converting function-valued variables
2658 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2659 are as in ada_resolve, above. */
2661 static struct value
*
2662 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2663 struct type
*context_type
)
2667 struct expression
*exp
; /* Convenience: == *expp. */
2668 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2669 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2670 int nargs
; /* Number of operands. */
2677 /* Pass one: resolve operands, saving their types and updating *pos,
2682 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2683 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2688 resolve_subexp (expp
, pos
, 0, NULL
);
2690 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2695 resolve_subexp (expp
, pos
, 0, NULL
);
2700 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2703 case OP_ATR_MODULUS
:
2713 case TERNOP_IN_RANGE
:
2714 case BINOP_IN_BOUNDS
:
2720 case OP_DISCRETE_RANGE
:
2722 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
2731 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2733 resolve_subexp (expp
, pos
, 1, NULL
);
2735 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2752 case BINOP_LOGICAL_AND
:
2753 case BINOP_LOGICAL_OR
:
2754 case BINOP_BITWISE_AND
:
2755 case BINOP_BITWISE_IOR
:
2756 case BINOP_BITWISE_XOR
:
2759 case BINOP_NOTEQUAL
:
2766 case BINOP_SUBSCRIPT
:
2774 case UNOP_LOGICAL_NOT
:
2790 case OP_INTERNALVAR
:
2800 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2803 case STRUCTOP_STRUCT
:
2804 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2817 error (_("Unexpected operator during name resolution"));
2820 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2821 for (i
= 0; i
< nargs
; i
+= 1)
2822 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2826 /* Pass two: perform any resolution on principal operator. */
2833 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2835 struct ada_symbol_info
*candidates
;
2839 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2840 (exp
->elts
[pc
+ 2].symbol
),
2841 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2844 if (n_candidates
> 1)
2846 /* Types tend to get re-introduced locally, so if there
2847 are any local symbols that are not types, first filter
2850 for (j
= 0; j
< n_candidates
; j
+= 1)
2851 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2856 case LOC_REGPARM_ADDR
:
2864 if (j
< n_candidates
)
2867 while (j
< n_candidates
)
2869 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2871 candidates
[j
] = candidates
[n_candidates
- 1];
2880 if (n_candidates
== 0)
2881 error (_("No definition found for %s"),
2882 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2883 else if (n_candidates
== 1)
2885 else if (deprocedure_p
2886 && !is_nonfunction (candidates
, n_candidates
))
2888 i
= ada_resolve_function
2889 (candidates
, n_candidates
, NULL
, 0,
2890 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2893 error (_("Could not find a match for %s"),
2894 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2898 printf_filtered (_("Multiple matches for %s\n"),
2899 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2900 user_select_syms (candidates
, n_candidates
, 1);
2904 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2905 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2906 if (innermost_block
== NULL
2907 || contained_in (candidates
[i
].block
, innermost_block
))
2908 innermost_block
= candidates
[i
].block
;
2912 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2915 replace_operator_with_call (expp
, pc
, 0, 0,
2916 exp
->elts
[pc
+ 2].symbol
,
2917 exp
->elts
[pc
+ 1].block
);
2924 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2925 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2927 struct ada_symbol_info
*candidates
;
2931 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2932 (exp
->elts
[pc
+ 5].symbol
),
2933 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2935 if (n_candidates
== 1)
2939 i
= ada_resolve_function
2940 (candidates
, n_candidates
,
2942 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2945 error (_("Could not find a match for %s"),
2946 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2949 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2950 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2951 if (innermost_block
== NULL
2952 || contained_in (candidates
[i
].block
, innermost_block
))
2953 innermost_block
= candidates
[i
].block
;
2964 case BINOP_BITWISE_AND
:
2965 case BINOP_BITWISE_IOR
:
2966 case BINOP_BITWISE_XOR
:
2968 case BINOP_NOTEQUAL
:
2976 case UNOP_LOGICAL_NOT
:
2978 if (possible_user_operator_p (op
, argvec
))
2980 struct ada_symbol_info
*candidates
;
2984 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2985 (struct block
*) NULL
, VAR_DOMAIN
,
2987 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2988 ada_decoded_op_name (op
), NULL
);
2992 replace_operator_with_call (expp
, pc
, nargs
, 1,
2993 candidates
[i
].sym
, candidates
[i
].block
);
3004 return evaluate_subexp_type (exp
, pos
);
3007 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3008 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3009 a non-pointer. A type of 'void' (which is never a valid expression type)
3010 by convention matches anything. */
3011 /* The term "match" here is rather loose. The match is heuristic and
3012 liberal. FIXME: TOO liberal, in fact. */
3015 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3017 ftype
= ada_check_typedef (ftype
);
3018 atype
= ada_check_typedef (atype
);
3020 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3021 ftype
= TYPE_TARGET_TYPE (ftype
);
3022 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3023 atype
= TYPE_TARGET_TYPE (atype
);
3025 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
3026 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
3029 switch (TYPE_CODE (ftype
))
3034 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3035 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3036 TYPE_TARGET_TYPE (atype
), 0);
3039 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3041 case TYPE_CODE_ENUM
:
3042 case TYPE_CODE_RANGE
:
3043 switch (TYPE_CODE (atype
))
3046 case TYPE_CODE_ENUM
:
3047 case TYPE_CODE_RANGE
:
3053 case TYPE_CODE_ARRAY
:
3054 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3055 || ada_is_array_descriptor_type (atype
));
3057 case TYPE_CODE_STRUCT
:
3058 if (ada_is_array_descriptor_type (ftype
))
3059 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3060 || ada_is_array_descriptor_type (atype
));
3062 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3063 && !ada_is_array_descriptor_type (atype
));
3065 case TYPE_CODE_UNION
:
3067 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3071 /* Return non-zero if the formals of FUNC "sufficiently match" the
3072 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3073 may also be an enumeral, in which case it is treated as a 0-
3074 argument function. */
3077 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3080 struct type
*func_type
= SYMBOL_TYPE (func
);
3082 if (SYMBOL_CLASS (func
) == LOC_CONST
3083 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3084 return (n_actuals
== 0);
3085 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3088 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3091 for (i
= 0; i
< n_actuals
; i
+= 1)
3093 if (actuals
[i
] == NULL
)
3097 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
3098 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3100 if (!ada_type_match (ftype
, atype
, 1))
3107 /* False iff function type FUNC_TYPE definitely does not produce a value
3108 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3109 FUNC_TYPE is not a valid function type with a non-null return type
3110 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3113 return_match (struct type
*func_type
, struct type
*context_type
)
3115 struct type
*return_type
;
3117 if (func_type
== NULL
)
3120 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3121 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
3123 return_type
= base_type (func_type
);
3124 if (return_type
== NULL
)
3127 context_type
= base_type (context_type
);
3129 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3130 return context_type
== NULL
|| return_type
== context_type
;
3131 else if (context_type
== NULL
)
3132 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3134 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3138 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3139 function (if any) that matches the types of the NARGS arguments in
3140 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3141 that returns that type, then eliminate matches that don't. If
3142 CONTEXT_TYPE is void and there is at least one match that does not
3143 return void, eliminate all matches that do.
3145 Asks the user if there is more than one match remaining. Returns -1
3146 if there is no such symbol or none is selected. NAME is used
3147 solely for messages. May re-arrange and modify SYMS in
3148 the process; the index returned is for the modified vector. */
3151 ada_resolve_function (struct ada_symbol_info syms
[],
3152 int nsyms
, struct value
**args
, int nargs
,
3153 const char *name
, struct type
*context_type
)
3156 int m
; /* Number of hits */
3157 struct type
*fallback
;
3158 struct type
*return_type
;
3160 return_type
= context_type
;
3161 if (context_type
== NULL
)
3162 fallback
= builtin_type_void
;
3169 for (k
= 0; k
< nsyms
; k
+= 1)
3171 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3173 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3174 && return_match (type
, return_type
))
3180 if (m
> 0 || return_type
== fallback
)
3183 return_type
= fallback
;
3190 printf_filtered (_("Multiple matches for %s\n"), name
);
3191 user_select_syms (syms
, m
, 1);
3197 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3198 in a listing of choices during disambiguation (see sort_choices, below).
3199 The idea is that overloadings of a subprogram name from the
3200 same package should sort in their source order. We settle for ordering
3201 such symbols by their trailing number (__N or $N). */
3204 encoded_ordered_before (char *N0
, char *N1
)
3208 else if (N0
== NULL
)
3213 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3215 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3217 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3218 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3222 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3225 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3227 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3228 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3230 return (strcmp (N0
, N1
) < 0);
3234 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3238 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3241 for (i
= 1; i
< nsyms
; i
+= 1)
3243 struct ada_symbol_info sym
= syms
[i
];
3246 for (j
= i
- 1; j
>= 0; j
-= 1)
3248 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3249 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3251 syms
[j
+ 1] = syms
[j
];
3257 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3258 by asking the user (if necessary), returning the number selected,
3259 and setting the first elements of SYMS items. Error if no symbols
3262 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3263 to be re-integrated one of these days. */
3266 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3269 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3271 int first_choice
= (max_results
== 1) ? 1 : 2;
3272 const char *select_mode
= multiple_symbols_select_mode ();
3274 if (max_results
< 1)
3275 error (_("Request to select 0 symbols!"));
3279 if (select_mode
== multiple_symbols_cancel
)
3281 canceled because the command is ambiguous\n\
3282 See set/show multiple-symbol."));
3284 /* If select_mode is "all", then return all possible symbols.
3285 Only do that if more than one symbol can be selected, of course.
3286 Otherwise, display the menu as usual. */
3287 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3290 printf_unfiltered (_("[0] cancel\n"));
3291 if (max_results
> 1)
3292 printf_unfiltered (_("[1] all\n"));
3294 sort_choices (syms
, nsyms
);
3296 for (i
= 0; i
< nsyms
; i
+= 1)
3298 if (syms
[i
].sym
== NULL
)
3301 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3303 struct symtab_and_line sal
=
3304 find_function_start_sal (syms
[i
].sym
, 1);
3305 if (sal
.symtab
== NULL
)
3306 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3308 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3311 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3312 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3313 sal
.symtab
->filename
, sal
.line
);
3319 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3320 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3321 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3322 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3324 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3325 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3327 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3328 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3329 else if (is_enumeral
3330 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3332 printf_unfiltered (("[%d] "), i
+ first_choice
);
3333 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3335 printf_unfiltered (_("'(%s) (enumeral)\n"),
3336 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3338 else if (symtab
!= NULL
)
3339 printf_unfiltered (is_enumeral
3340 ? _("[%d] %s in %s (enumeral)\n")
3341 : _("[%d] %s at %s:?\n"),
3343 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3346 printf_unfiltered (is_enumeral
3347 ? _("[%d] %s (enumeral)\n")
3348 : _("[%d] %s at ?\n"),
3350 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3354 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3357 for (i
= 0; i
< n_chosen
; i
+= 1)
3358 syms
[i
] = syms
[chosen
[i
]];
3363 /* Read and validate a set of numeric choices from the user in the
3364 range 0 .. N_CHOICES-1. Place the results in increasing
3365 order in CHOICES[0 .. N-1], and return N.
3367 The user types choices as a sequence of numbers on one line
3368 separated by blanks, encoding them as follows:
3370 + A choice of 0 means to cancel the selection, throwing an error.
3371 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3372 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3374 The user is not allowed to choose more than MAX_RESULTS values.
3376 ANNOTATION_SUFFIX, if present, is used to annotate the input
3377 prompts (for use with the -f switch). */
3380 get_selections (int *choices
, int n_choices
, int max_results
,
3381 int is_all_choice
, char *annotation_suffix
)
3386 int first_choice
= is_all_choice
? 2 : 1;
3388 prompt
= getenv ("PS2");
3392 args
= command_line_input (prompt
, 0, annotation_suffix
);
3395 error_no_arg (_("one or more choice numbers"));
3399 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3400 order, as given in args. Choices are validated. */
3406 while (isspace (*args
))
3408 if (*args
== '\0' && n_chosen
== 0)
3409 error_no_arg (_("one or more choice numbers"));
3410 else if (*args
== '\0')
3413 choice
= strtol (args
, &args2
, 10);
3414 if (args
== args2
|| choice
< 0
3415 || choice
> n_choices
+ first_choice
- 1)
3416 error (_("Argument must be choice number"));
3420 error (_("cancelled"));
3422 if (choice
< first_choice
)
3424 n_chosen
= n_choices
;
3425 for (j
= 0; j
< n_choices
; j
+= 1)
3429 choice
-= first_choice
;
3431 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3435 if (j
< 0 || choice
!= choices
[j
])
3438 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3439 choices
[k
+ 1] = choices
[k
];
3440 choices
[j
+ 1] = choice
;
3445 if (n_chosen
> max_results
)
3446 error (_("Select no more than %d of the above"), max_results
);
3451 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3452 on the function identified by SYM and BLOCK, and taking NARGS
3453 arguments. Update *EXPP as needed to hold more space. */
3456 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3457 int oplen
, struct symbol
*sym
,
3458 struct block
*block
)
3460 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3461 symbol, -oplen for operator being replaced). */
3462 struct expression
*newexp
= (struct expression
*)
3463 xmalloc (sizeof (struct expression
)
3464 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3465 struct expression
*exp
= *expp
;
3467 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3468 newexp
->language_defn
= exp
->language_defn
;
3469 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3470 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3471 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3473 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3474 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3476 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3477 newexp
->elts
[pc
+ 4].block
= block
;
3478 newexp
->elts
[pc
+ 5].symbol
= sym
;
3484 /* Type-class predicates */
3486 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3490 numeric_type_p (struct type
*type
)
3496 switch (TYPE_CODE (type
))
3501 case TYPE_CODE_RANGE
:
3502 return (type
== TYPE_TARGET_TYPE (type
)
3503 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3510 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3513 integer_type_p (struct type
*type
)
3519 switch (TYPE_CODE (type
))
3523 case TYPE_CODE_RANGE
:
3524 return (type
== TYPE_TARGET_TYPE (type
)
3525 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3532 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3535 scalar_type_p (struct type
*type
)
3541 switch (TYPE_CODE (type
))
3544 case TYPE_CODE_RANGE
:
3545 case TYPE_CODE_ENUM
:
3554 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3557 discrete_type_p (struct type
*type
)
3563 switch (TYPE_CODE (type
))
3566 case TYPE_CODE_RANGE
:
3567 case TYPE_CODE_ENUM
:
3575 /* Returns non-zero if OP with operands in the vector ARGS could be
3576 a user-defined function. Errs on the side of pre-defined operators
3577 (i.e., result 0). */
3580 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3582 struct type
*type0
=
3583 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3584 struct type
*type1
=
3585 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3599 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3603 case BINOP_BITWISE_AND
:
3604 case BINOP_BITWISE_IOR
:
3605 case BINOP_BITWISE_XOR
:
3606 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3609 case BINOP_NOTEQUAL
:
3614 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3617 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
3620 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3624 case UNOP_LOGICAL_NOT
:
3626 return (!numeric_type_p (type0
));
3635 1. In the following, we assume that a renaming type's name may
3636 have an ___XD suffix. It would be nice if this went away at some
3638 2. We handle both the (old) purely type-based representation of
3639 renamings and the (new) variable-based encoding. At some point,
3640 it is devoutly to be hoped that the former goes away
3641 (FIXME: hilfinger-2007-07-09).
3642 3. Subprogram renamings are not implemented, although the XRS
3643 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3645 /* If SYM encodes a renaming,
3647 <renaming> renames <renamed entity>,
3649 sets *LEN to the length of the renamed entity's name,
3650 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3651 the string describing the subcomponent selected from the renamed
3652 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3653 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3654 are undefined). Otherwise, returns a value indicating the category
3655 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3656 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3657 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3658 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3659 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3660 may be NULL, in which case they are not assigned.
3662 [Currently, however, GCC does not generate subprogram renamings.] */
3664 enum ada_renaming_category
3665 ada_parse_renaming (struct symbol
*sym
,
3666 const char **renamed_entity
, int *len
,
3667 const char **renaming_expr
)
3669 enum ada_renaming_category kind
;
3674 return ADA_NOT_RENAMING
;
3675 switch (SYMBOL_CLASS (sym
))
3678 return ADA_NOT_RENAMING
;
3680 return parse_old_style_renaming (SYMBOL_TYPE (sym
),
3681 renamed_entity
, len
, renaming_expr
);
3685 case LOC_OPTIMIZED_OUT
:
3686 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
3688 return ADA_NOT_RENAMING
;
3692 kind
= ADA_OBJECT_RENAMING
;
3696 kind
= ADA_EXCEPTION_RENAMING
;
3700 kind
= ADA_PACKAGE_RENAMING
;
3704 kind
= ADA_SUBPROGRAM_RENAMING
;
3708 return ADA_NOT_RENAMING
;
3712 if (renamed_entity
!= NULL
)
3713 *renamed_entity
= info
;
3714 suffix
= strstr (info
, "___XE");
3715 if (suffix
== NULL
|| suffix
== info
)
3716 return ADA_NOT_RENAMING
;
3718 *len
= strlen (info
) - strlen (suffix
);
3720 if (renaming_expr
!= NULL
)
3721 *renaming_expr
= suffix
;
3725 /* Assuming TYPE encodes a renaming according to the old encoding in
3726 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3727 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3728 ADA_NOT_RENAMING otherwise. */
3729 static enum ada_renaming_category
3730 parse_old_style_renaming (struct type
*type
,
3731 const char **renamed_entity
, int *len
,
3732 const char **renaming_expr
)
3734 enum ada_renaming_category kind
;
3739 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
3740 || TYPE_NFIELDS (type
) != 1)
3741 return ADA_NOT_RENAMING
;
3743 name
= type_name_no_tag (type
);
3745 return ADA_NOT_RENAMING
;
3747 name
= strstr (name
, "___XR");
3749 return ADA_NOT_RENAMING
;
3754 kind
= ADA_OBJECT_RENAMING
;
3757 kind
= ADA_EXCEPTION_RENAMING
;
3760 kind
= ADA_PACKAGE_RENAMING
;
3763 kind
= ADA_SUBPROGRAM_RENAMING
;
3766 return ADA_NOT_RENAMING
;
3769 info
= TYPE_FIELD_NAME (type
, 0);
3771 return ADA_NOT_RENAMING
;
3772 if (renamed_entity
!= NULL
)
3773 *renamed_entity
= info
;
3774 suffix
= strstr (info
, "___XE");
3775 if (renaming_expr
!= NULL
)
3776 *renaming_expr
= suffix
+ 5;
3777 if (suffix
== NULL
|| suffix
== info
)
3778 return ADA_NOT_RENAMING
;
3780 *len
= suffix
- info
;
3786 /* Evaluation: Function Calls */
3788 /* Return an lvalue containing the value VAL. This is the identity on
3789 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3790 on the stack, using and updating *SP as the stack pointer, and
3791 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3793 static struct value
*
3794 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3796 if (! VALUE_LVAL (val
))
3798 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3800 /* The following is taken from the structure-return code in
3801 call_function_by_hand. FIXME: Therefore, some refactoring seems
3803 if (gdbarch_inner_than (current_gdbarch
, 1, 2))
3805 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3806 reserving sufficient space. */
3808 if (gdbarch_frame_align_p (current_gdbarch
))
3809 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3810 VALUE_ADDRESS (val
) = *sp
;
3814 /* Stack grows upward. Align the frame, allocate space, and
3815 then again, re-align the frame. */
3816 if (gdbarch_frame_align_p (current_gdbarch
))
3817 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3818 VALUE_ADDRESS (val
) = *sp
;
3820 if (gdbarch_frame_align_p (current_gdbarch
))
3821 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3823 VALUE_LVAL (val
) = lval_memory
;
3825 write_memory (VALUE_ADDRESS (val
), value_contents_raw (val
), len
);
3831 /* Return the value ACTUAL, converted to be an appropriate value for a
3832 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3833 allocating any necessary descriptors (fat pointers), or copies of
3834 values not residing in memory, updating it as needed. */
3837 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
,
3840 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3841 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3842 struct type
*formal_target
=
3843 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3844 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3845 struct type
*actual_target
=
3846 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3847 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3849 if (ada_is_array_descriptor_type (formal_target
)
3850 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3851 return make_array_descriptor (formal_type
, actual
, sp
);
3852 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3853 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
3855 struct value
*result
;
3856 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3857 && ada_is_array_descriptor_type (actual_target
))
3858 result
= desc_data (actual
);
3859 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3861 if (VALUE_LVAL (actual
) != lval_memory
)
3864 actual_type
= ada_check_typedef (value_type (actual
));
3865 val
= allocate_value (actual_type
);
3866 memcpy ((char *) value_contents_raw (val
),
3867 (char *) value_contents (actual
),
3868 TYPE_LENGTH (actual_type
));
3869 actual
= ensure_lval (val
, sp
);
3871 result
= value_addr (actual
);
3875 return value_cast_pointers (formal_type
, result
);
3877 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3878 return ada_value_ind (actual
);
3884 /* Push a descriptor of type TYPE for array value ARR on the stack at
3885 *SP, updating *SP to reflect the new descriptor. Return either
3886 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3887 to-descriptor type rather than a descriptor type), a struct value *
3888 representing a pointer to this descriptor. */
3890 static struct value
*
3891 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3893 struct type
*bounds_type
= desc_bounds_type (type
);
3894 struct type
*desc_type
= desc_base_type (type
);
3895 struct value
*descriptor
= allocate_value (desc_type
);
3896 struct value
*bounds
= allocate_value (bounds_type
);
3899 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
3901 modify_general_field (value_contents_writeable (bounds
),
3902 value_as_long (ada_array_bound (arr
, i
, 0)),
3903 desc_bound_bitpos (bounds_type
, i
, 0),
3904 desc_bound_bitsize (bounds_type
, i
, 0));
3905 modify_general_field (value_contents_writeable (bounds
),
3906 value_as_long (ada_array_bound (arr
, i
, 1)),
3907 desc_bound_bitpos (bounds_type
, i
, 1),
3908 desc_bound_bitsize (bounds_type
, i
, 1));
3911 bounds
= ensure_lval (bounds
, sp
);
3913 modify_general_field (value_contents_writeable (descriptor
),
3914 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3915 fat_pntr_data_bitpos (desc_type
),
3916 fat_pntr_data_bitsize (desc_type
));
3918 modify_general_field (value_contents_writeable (descriptor
),
3919 VALUE_ADDRESS (bounds
),
3920 fat_pntr_bounds_bitpos (desc_type
),
3921 fat_pntr_bounds_bitsize (desc_type
));
3923 descriptor
= ensure_lval (descriptor
, sp
);
3925 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3926 return value_addr (descriptor
);
3931 /* Dummy definitions for an experimental caching module that is not
3932 * used in the public sources. */
3935 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3936 struct symbol
**sym
, struct block
**block
)
3942 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3943 struct block
*block
)
3949 /* Return the result of a standard (literal, C-like) lookup of NAME in
3950 given DOMAIN, visible from lexical block BLOCK. */
3952 static struct symbol
*
3953 standard_lookup (const char *name
, const struct block
*block
,
3958 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
))
3960 sym
= lookup_symbol_in_language (name
, block
, domain
, language_c
, 0);
3961 cache_symbol (name
, domain
, sym
, block_found
);
3966 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3967 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3968 since they contend in overloading in the same way. */
3970 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3974 for (i
= 0; i
< n
; i
+= 1)
3975 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3976 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3977 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3983 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3984 struct types. Otherwise, they may not. */
3987 equiv_types (struct type
*type0
, struct type
*type1
)
3991 if (type0
== NULL
|| type1
== NULL
3992 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3994 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3995 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3996 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3997 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4003 /* True iff SYM0 represents the same entity as SYM1, or one that is
4004 no more defined than that of SYM1. */
4007 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4011 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4012 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4015 switch (SYMBOL_CLASS (sym0
))
4021 struct type
*type0
= SYMBOL_TYPE (sym0
);
4022 struct type
*type1
= SYMBOL_TYPE (sym1
);
4023 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4024 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4025 int len0
= strlen (name0
);
4027 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4028 && (equiv_types (type0
, type1
)
4029 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4030 && strncmp (name1
+ len0
, "___XV", 5) == 0));
4033 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4034 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4040 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4041 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4044 add_defn_to_vec (struct obstack
*obstackp
,
4046 struct block
*block
)
4050 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
4052 /* Do not try to complete stub types, as the debugger is probably
4053 already scanning all symbols matching a certain name at the
4054 time when this function is called. Trying to replace the stub
4055 type by its associated full type will cause us to restart a scan
4056 which may lead to an infinite recursion. Instead, the client
4057 collecting the matching symbols will end up collecting several
4058 matches, with at least one of them complete. It can then filter
4059 out the stub ones if needed. */
4061 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4063 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
4065 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
4067 prevDefns
[i
].sym
= sym
;
4068 prevDefns
[i
].block
= block
;
4074 struct ada_symbol_info info
;
4078 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
4082 /* Number of ada_symbol_info structures currently collected in
4083 current vector in *OBSTACKP. */
4086 num_defns_collected (struct obstack
*obstackp
)
4088 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
4091 /* Vector of ada_symbol_info structures currently collected in current
4092 vector in *OBSTACKP. If FINISH, close off the vector and return
4093 its final address. */
4095 static struct ada_symbol_info
*
4096 defns_collected (struct obstack
*obstackp
, int finish
)
4099 return obstack_finish (obstackp
);
4101 return (struct ada_symbol_info
*) obstack_base (obstackp
);
4104 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
4105 Check the global symbols if GLOBAL, the static symbols if not.
4106 Do wild-card match if WILD. */
4108 static struct partial_symbol
*
4109 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
4110 int global
, domain_enum
namespace, int wild
)
4112 struct partial_symbol
**start
;
4113 int name_len
= strlen (name
);
4114 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
4123 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
4124 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
4128 for (i
= 0; i
< length
; i
+= 1)
4130 struct partial_symbol
*psym
= start
[i
];
4132 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4133 SYMBOL_DOMAIN (psym
), namespace)
4134 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
4148 int M
= (U
+ i
) >> 1;
4149 struct partial_symbol
*psym
= start
[M
];
4150 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
4152 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
4154 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
4165 struct partial_symbol
*psym
= start
[i
];
4167 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4168 SYMBOL_DOMAIN (psym
), namespace))
4170 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
4178 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4192 int M
= (U
+ i
) >> 1;
4193 struct partial_symbol
*psym
= start
[M
];
4194 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
4196 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
4198 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
4209 struct partial_symbol
*psym
= start
[i
];
4211 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4212 SYMBOL_DOMAIN (psym
), namespace))
4216 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
4219 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
4221 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
4231 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4241 /* Find a symbol table containing symbol SYM or NULL if none. */
4243 static struct symtab
*
4244 symtab_for_sym (struct symbol
*sym
)
4247 struct objfile
*objfile
;
4249 struct symbol
*tmp_sym
;
4250 struct dict_iterator iter
;
4253 ALL_PRIMARY_SYMTABS (objfile
, s
)
4255 switch (SYMBOL_CLASS (sym
))
4263 case LOC_CONST_BYTES
:
4264 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
4265 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4267 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
4268 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4274 switch (SYMBOL_CLASS (sym
))
4279 case LOC_REGPARM_ADDR
:
4283 for (j
= FIRST_LOCAL_BLOCK
;
4284 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
4286 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
4287 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4298 /* Return a minimal symbol matching NAME according to Ada decoding
4299 rules. Returns NULL if there is no such minimal symbol. Names
4300 prefixed with "standard__" are handled specially: "standard__" is
4301 first stripped off, and only static and global symbols are searched. */
4303 struct minimal_symbol
*
4304 ada_lookup_simple_minsym (const char *name
)
4306 struct objfile
*objfile
;
4307 struct minimal_symbol
*msymbol
;
4310 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4312 name
+= sizeof ("standard__") - 1;
4316 wild_match
= (strstr (name
, "__") == NULL
);
4318 ALL_MSYMBOLS (objfile
, msymbol
)
4320 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4321 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4328 /* For all subprograms that statically enclose the subprogram of the
4329 selected frame, add symbols matching identifier NAME in DOMAIN
4330 and their blocks to the list of data in OBSTACKP, as for
4331 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4335 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4336 const char *name
, domain_enum
namespace,
4341 /* True if TYPE is definitely an artificial type supplied to a symbol
4342 for which no debugging information was given in the symbol file. */
4345 is_nondebugging_type (struct type
*type
)
4347 char *name
= ada_type_name (type
);
4348 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4351 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4352 duplicate other symbols in the list (The only case I know of where
4353 this happens is when object files containing stabs-in-ecoff are
4354 linked with files containing ordinary ecoff debugging symbols (or no
4355 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4356 Returns the number of items in the modified list. */
4359 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4368 /* If two symbols have the same name and one of them is a stub type,
4369 the get rid of the stub. */
4371 if (TYPE_STUB (SYMBOL_TYPE (syms
[i
].sym
))
4372 && SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
)
4374 for (j
= 0; j
< nsyms
; j
++)
4377 && !TYPE_STUB (SYMBOL_TYPE (syms
[j
].sym
))
4378 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4379 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4380 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0)
4385 /* Two symbols with the same name, same class and same address
4386 should be identical. */
4388 else if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4389 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4390 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4392 for (j
= 0; j
< nsyms
; j
+= 1)
4395 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4396 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4397 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4398 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4399 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4400 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4407 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4408 syms
[j
- 1] = syms
[j
];
4417 /* Given a type that corresponds to a renaming entity, use the type name
4418 to extract the scope (package name or function name, fully qualified,
4419 and following the GNAT encoding convention) where this renaming has been
4420 defined. The string returned needs to be deallocated after use. */
4423 xget_renaming_scope (struct type
*renaming_type
)
4425 /* The renaming types adhere to the following convention:
4426 <scope>__<rename>___<XR extension>.
4427 So, to extract the scope, we search for the "___XR" extension,
4428 and then backtrack until we find the first "__". */
4430 const char *name
= type_name_no_tag (renaming_type
);
4431 char *suffix
= strstr (name
, "___XR");
4436 /* Now, backtrack a bit until we find the first "__". Start looking
4437 at suffix - 3, as the <rename> part is at least one character long. */
4439 for (last
= suffix
- 3; last
> name
; last
--)
4440 if (last
[0] == '_' && last
[1] == '_')
4443 /* Make a copy of scope and return it. */
4445 scope_len
= last
- name
;
4446 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4448 strncpy (scope
, name
, scope_len
);
4449 scope
[scope_len
] = '\0';
4454 /* Return nonzero if NAME corresponds to a package name. */
4457 is_package_name (const char *name
)
4459 /* Here, We take advantage of the fact that no symbols are generated
4460 for packages, while symbols are generated for each function.
4461 So the condition for NAME represent a package becomes equivalent
4462 to NAME not existing in our list of symbols. There is only one
4463 small complication with library-level functions (see below). */
4467 /* If it is a function that has not been defined at library level,
4468 then we should be able to look it up in the symbols. */
4469 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4472 /* Library-level function names start with "_ada_". See if function
4473 "_ada_" followed by NAME can be found. */
4475 /* Do a quick check that NAME does not contain "__", since library-level
4476 functions names cannot contain "__" in them. */
4477 if (strstr (name
, "__") != NULL
)
4480 fun_name
= xstrprintf ("_ada_%s", name
);
4482 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4485 /* Return nonzero if SYM corresponds to a renaming entity that is
4486 not visible from FUNCTION_NAME. */
4489 old_renaming_is_invisible (const struct symbol
*sym
, char *function_name
)
4493 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
4496 scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4498 make_cleanup (xfree
, scope
);
4500 /* If the rename has been defined in a package, then it is visible. */
4501 if (is_package_name (scope
))
4504 /* Check that the rename is in the current function scope by checking
4505 that its name starts with SCOPE. */
4507 /* If the function name starts with "_ada_", it means that it is
4508 a library-level function. Strip this prefix before doing the
4509 comparison, as the encoding for the renaming does not contain
4511 if (strncmp (function_name
, "_ada_", 5) == 0)
4514 return (strncmp (function_name
, scope
, strlen (scope
)) != 0);
4517 /* Remove entries from SYMS that corresponds to a renaming entity that
4518 is not visible from the function associated with CURRENT_BLOCK or
4519 that is superfluous due to the presence of more specific renaming
4520 information. Places surviving symbols in the initial entries of
4521 SYMS and returns the number of surviving symbols.
4524 First, in cases where an object renaming is implemented as a
4525 reference variable, GNAT may produce both the actual reference
4526 variable and the renaming encoding. In this case, we discard the
4529 Second, GNAT emits a type following a specified encoding for each renaming
4530 entity. Unfortunately, STABS currently does not support the definition
4531 of types that are local to a given lexical block, so all renamings types
4532 are emitted at library level. As a consequence, if an application
4533 contains two renaming entities using the same name, and a user tries to
4534 print the value of one of these entities, the result of the ada symbol
4535 lookup will also contain the wrong renaming type.
4537 This function partially covers for this limitation by attempting to
4538 remove from the SYMS list renaming symbols that should be visible
4539 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4540 method with the current information available. The implementation
4541 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4543 - When the user tries to print a rename in a function while there
4544 is another rename entity defined in a package: Normally, the
4545 rename in the function has precedence over the rename in the
4546 package, so the latter should be removed from the list. This is
4547 currently not the case.
4549 - This function will incorrectly remove valid renames if
4550 the CURRENT_BLOCK corresponds to a function which symbol name
4551 has been changed by an "Export" pragma. As a consequence,
4552 the user will be unable to print such rename entities. */
4555 remove_irrelevant_renamings (struct ada_symbol_info
*syms
,
4556 int nsyms
, const struct block
*current_block
)
4558 struct symbol
*current_function
;
4559 char *current_function_name
;
4561 int is_new_style_renaming
;
4563 /* If there is both a renaming foo___XR... encoded as a variable and
4564 a simple variable foo in the same block, discard the latter.
4565 First, zero out such symbols, then compress. */
4566 is_new_style_renaming
= 0;
4567 for (i
= 0; i
< nsyms
; i
+= 1)
4569 struct symbol
*sym
= syms
[i
].sym
;
4570 struct block
*block
= syms
[i
].block
;
4574 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
4576 name
= SYMBOL_LINKAGE_NAME (sym
);
4577 suffix
= strstr (name
, "___XR");
4581 int name_len
= suffix
- name
;
4583 is_new_style_renaming
= 1;
4584 for (j
= 0; j
< nsyms
; j
+= 1)
4585 if (i
!= j
&& syms
[j
].sym
!= NULL
4586 && strncmp (name
, SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
4588 && block
== syms
[j
].block
)
4592 if (is_new_style_renaming
)
4596 for (j
= k
= 0; j
< nsyms
; j
+= 1)
4597 if (syms
[j
].sym
!= NULL
)
4605 /* Extract the function name associated to CURRENT_BLOCK.
4606 Abort if unable to do so. */
4608 if (current_block
== NULL
)
4611 current_function
= block_linkage_function (current_block
);
4612 if (current_function
== NULL
)
4615 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4616 if (current_function_name
== NULL
)
4619 /* Check each of the symbols, and remove it from the list if it is
4620 a type corresponding to a renaming that is out of the scope of
4621 the current block. */
4626 if (ada_parse_renaming (syms
[i
].sym
, NULL
, NULL
, NULL
)
4627 == ADA_OBJECT_RENAMING
4628 && old_renaming_is_invisible (syms
[i
].sym
, current_function_name
))
4631 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4632 syms
[j
- 1] = syms
[j
];
4642 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4643 whose name and domain match NAME and DOMAIN respectively.
4644 If no match was found, then extend the search to "enclosing"
4645 routines (in other words, if we're inside a nested function,
4646 search the symbols defined inside the enclosing functions).
4648 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4651 ada_add_local_symbols (struct obstack
*obstackp
, const char *name
,
4652 struct block
*block
, domain_enum domain
,
4655 int block_depth
= 0;
4657 while (block
!= NULL
)
4660 ada_add_block_symbols (obstackp
, block
, name
, domain
, NULL
, wild_match
);
4662 /* If we found a non-function match, assume that's the one. */
4663 if (is_nonfunction (defns_collected (obstackp
, 0),
4664 num_defns_collected (obstackp
)))
4667 block
= BLOCK_SUPERBLOCK (block
);
4670 /* If no luck so far, try to find NAME as a local symbol in some lexically
4671 enclosing subprogram. */
4672 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
4673 add_symbols_from_enclosing_procs (obstackp
, name
, domain
, wild_match
);
4676 /* Add to OBSTACKP all non-local symbols whose name and domain match
4677 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
4678 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
4681 ada_add_non_local_symbols (struct obstack
*obstackp
, const char *name
,
4682 domain_enum domain
, int global
,
4685 struct objfile
*objfile
;
4686 struct partial_symtab
*ps
;
4688 ALL_PSYMTABS (objfile
, ps
)
4692 || ada_lookup_partial_symbol (ps
, name
, global
, domain
, wild_match
))
4694 struct symtab
*s
= PSYMTAB_TO_SYMTAB (ps
);
4695 const int block_kind
= global
? GLOBAL_BLOCK
: STATIC_BLOCK
;
4697 if (s
== NULL
|| !s
->primary
)
4699 ada_add_block_symbols (obstackp
,
4700 BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), block_kind
),
4701 name
, domain
, objfile
, wild_match
);
4706 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4707 scope and in global scopes, returning the number of matches. Sets
4708 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4709 indicating the symbols found and the blocks and symbol tables (if
4710 any) in which they were found. This vector are transient---good only to
4711 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4712 symbol match within the nest of blocks whose innermost member is BLOCK0,
4713 is the one match returned (no other matches in that or
4714 enclosing blocks is returned). If there are any matches in or
4715 surrounding BLOCK0, then these alone are returned. Otherwise, the
4716 search extends to global and file-scope (static) symbol tables.
4717 Names prefixed with "standard__" are handled specially: "standard__"
4718 is first stripped off, and only static and global symbols are searched. */
4721 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4722 domain_enum
namespace,
4723 struct ada_symbol_info
**results
)
4726 struct block
*block
;
4732 obstack_free (&symbol_list_obstack
, NULL
);
4733 obstack_init (&symbol_list_obstack
);
4737 /* Search specified block and its superiors. */
4739 wild_match
= (strstr (name0
, "__") == NULL
);
4741 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4742 needed, but adding const will
4743 have a cascade effect. */
4745 /* Special case: If the user specifies a symbol name inside package
4746 Standard, do a non-wild matching of the symbol name without
4747 the "standard__" prefix. This was primarily introduced in order
4748 to allow the user to specifically access the standard exceptions
4749 using, for instance, Standard.Constraint_Error when Constraint_Error
4750 is ambiguous (due to the user defining its own Constraint_Error
4751 entity inside its program). */
4752 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4756 name
= name0
+ sizeof ("standard__") - 1;
4759 /* Check the non-global symbols. If we have ANY match, then we're done. */
4761 ada_add_local_symbols (&symbol_list_obstack
, name
, block
, namespace,
4763 if (num_defns_collected (&symbol_list_obstack
) > 0)
4766 /* No non-global symbols found. Check our cache to see if we have
4767 already performed this search before. If we have, then return
4771 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
))
4774 add_defn_to_vec (&symbol_list_obstack
, sym
, block
);
4778 /* Search symbols from all global blocks. */
4780 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 1,
4783 /* Now add symbols from all per-file blocks if we've gotten no hits
4784 (not strictly correct, but perhaps better than an error). */
4786 if (num_defns_collected (&symbol_list_obstack
) == 0)
4787 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 0,
4791 ndefns
= num_defns_collected (&symbol_list_obstack
);
4792 *results
= defns_collected (&symbol_list_obstack
, 1);
4794 ndefns
= remove_extra_symbols (*results
, ndefns
);
4797 cache_symbol (name0
, namespace, NULL
, NULL
);
4799 if (ndefns
== 1 && cacheIfUnique
)
4800 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
);
4802 ndefns
= remove_irrelevant_renamings (*results
, ndefns
, block0
);
4808 ada_lookup_encoded_symbol (const char *name
, const struct block
*block0
,
4809 domain_enum
namespace, struct block
**block_found
)
4811 struct ada_symbol_info
*candidates
;
4814 n_candidates
= ada_lookup_symbol_list (name
, block0
, namespace, &candidates
);
4816 if (n_candidates
== 0)
4819 if (block_found
!= NULL
)
4820 *block_found
= candidates
[0].block
;
4822 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4825 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4826 scope and in global scopes, or NULL if none. NAME is folded and
4827 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4828 choosing the first symbol if there are multiple choices.
4829 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4830 table in which the symbol was found (in both cases, these
4831 assignments occur only if the pointers are non-null). */
4833 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4834 domain_enum
namespace, int *is_a_field_of_this
)
4836 if (is_a_field_of_this
!= NULL
)
4837 *is_a_field_of_this
= 0;
4840 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name
)),
4841 block0
, namespace, NULL
);
4844 static struct symbol
*
4845 ada_lookup_symbol_nonlocal (const char *name
,
4846 const char *linkage_name
,
4847 const struct block
*block
,
4848 const domain_enum domain
)
4850 if (linkage_name
== NULL
)
4851 linkage_name
= name
;
4852 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4857 /* True iff STR is a possible encoded suffix of a normal Ada name
4858 that is to be ignored for matching purposes. Suffixes of parallel
4859 names (e.g., XVE) are not included here. Currently, the possible suffixes
4860 are given by any of the regular expressions:
4862 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
4863 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4864 _E[0-9]+[bs]$ [protected object entry suffixes]
4865 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4867 Also, any leading "__[0-9]+" sequence is skipped before the suffix
4868 match is performed. This sequence is used to differentiate homonyms,
4869 is an optional part of a valid name suffix. */
4872 is_name_suffix (const char *str
)
4875 const char *matching
;
4876 const int len
= strlen (str
);
4878 /* Skip optional leading __[0-9]+. */
4880 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4883 while (isdigit (str
[0]))
4889 if (str
[0] == '.' || str
[0] == '$')
4892 while (isdigit (matching
[0]))
4894 if (matching
[0] == '\0')
4900 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4903 while (isdigit (matching
[0]))
4905 if (matching
[0] == '\0')
4910 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4911 with a N at the end. Unfortunately, the compiler uses the same
4912 convention for other internal types it creates. So treating
4913 all entity names that end with an "N" as a name suffix causes
4914 some regressions. For instance, consider the case of an enumerated
4915 type. To support the 'Image attribute, it creates an array whose
4917 Having a single character like this as a suffix carrying some
4918 information is a bit risky. Perhaps we should change the encoding
4919 to be something like "_N" instead. In the meantime, do not do
4920 the following check. */
4921 /* Protected Object Subprograms */
4922 if (len
== 1 && str
[0] == 'N')
4927 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
4930 while (isdigit (matching
[0]))
4932 if ((matching
[0] == 'b' || matching
[0] == 's')
4933 && matching
[1] == '\0')
4937 /* ??? We should not modify STR directly, as we are doing below. This
4938 is fine in this case, but may become problematic later if we find
4939 that this alternative did not work, and want to try matching
4940 another one from the begining of STR. Since we modified it, we
4941 won't be able to find the begining of the string anymore! */
4945 while (str
[0] != '_' && str
[0] != '\0')
4947 if (str
[0] != 'n' && str
[0] != 'b')
4953 if (str
[0] == '\000')
4958 if (str
[1] != '_' || str
[2] == '\000')
4962 if (strcmp (str
+ 3, "JM") == 0)
4964 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4965 the LJM suffix in favor of the JM one. But we will
4966 still accept LJM as a valid suffix for a reasonable
4967 amount of time, just to allow ourselves to debug programs
4968 compiled using an older version of GNAT. */
4969 if (strcmp (str
+ 3, "LJM") == 0)
4973 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4974 || str
[4] == 'U' || str
[4] == 'P')
4976 if (str
[4] == 'R' && str
[5] != 'T')
4980 if (!isdigit (str
[2]))
4982 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4983 if (!isdigit (str
[k
]) && str
[k
] != '_')
4987 if (str
[0] == '$' && isdigit (str
[1]))
4989 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4990 if (!isdigit (str
[k
]) && str
[k
] != '_')
4997 /* Return non-zero if the string starting at NAME and ending before
4998 NAME_END contains no capital letters. */
5001 is_valid_name_for_wild_match (const char *name0
)
5003 const char *decoded_name
= ada_decode (name0
);
5006 /* If the decoded name starts with an angle bracket, it means that
5007 NAME0 does not follow the GNAT encoding format. It should then
5008 not be allowed as a possible wild match. */
5009 if (decoded_name
[0] == '<')
5012 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5013 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5019 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
5020 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
5021 informational suffixes of NAME (i.e., for which is_name_suffix is
5025 wild_match (const char *patn0
, int patn_len
, const char *name0
)
5032 match
= strstr (start
, patn0
);
5037 || (match
> name0
+ 1 && match
[-1] == '_' && match
[-2] == '_')
5038 || (match
== name0
+ 5 && strncmp ("_ada_", name0
, 5) == 0))
5039 && is_name_suffix (match
+ patn_len
))
5040 return (match
== name0
|| is_valid_name_for_wild_match (name0
));
5046 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5047 vector *defn_symbols, updating the list of symbols in OBSTACKP
5048 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5049 OBJFILE is the section containing BLOCK.
5050 SYMTAB is recorded with each symbol added. */
5053 ada_add_block_symbols (struct obstack
*obstackp
,
5054 struct block
*block
, const char *name
,
5055 domain_enum domain
, struct objfile
*objfile
,
5058 struct dict_iterator iter
;
5059 int name_len
= strlen (name
);
5060 /* A matching argument symbol, if any. */
5061 struct symbol
*arg_sym
;
5062 /* Set true when we find a matching non-argument symbol. */
5071 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5073 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5074 SYMBOL_DOMAIN (sym
), domain
)
5075 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
5077 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5079 else if (SYMBOL_IS_ARGUMENT (sym
))
5084 add_defn_to_vec (obstackp
,
5085 fixup_symbol_section (sym
, objfile
),
5093 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5095 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5096 SYMBOL_DOMAIN (sym
), domain
))
5098 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
5100 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5102 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5104 if (SYMBOL_IS_ARGUMENT (sym
))
5109 add_defn_to_vec (obstackp
,
5110 fixup_symbol_section (sym
, objfile
),
5119 if (!found_sym
&& arg_sym
!= NULL
)
5121 add_defn_to_vec (obstackp
,
5122 fixup_symbol_section (arg_sym
, objfile
),
5131 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5133 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5134 SYMBOL_DOMAIN (sym
), domain
))
5138 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5141 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5143 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5148 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5150 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5152 if (SYMBOL_IS_ARGUMENT (sym
))
5157 add_defn_to_vec (obstackp
,
5158 fixup_symbol_section (sym
, objfile
),
5166 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5167 They aren't parameters, right? */
5168 if (!found_sym
&& arg_sym
!= NULL
)
5170 add_defn_to_vec (obstackp
,
5171 fixup_symbol_section (arg_sym
, objfile
),
5178 /* Symbol Completion */
5180 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5181 name in a form that's appropriate for the completion. The result
5182 does not need to be deallocated, but is only good until the next call.
5184 TEXT_LEN is equal to the length of TEXT.
5185 Perform a wild match if WILD_MATCH is set.
5186 ENCODED should be set if TEXT represents the start of a symbol name
5187 in its encoded form. */
5190 symbol_completion_match (const char *sym_name
,
5191 const char *text
, int text_len
,
5192 int wild_match
, int encoded
)
5195 const int verbatim_match
= (text
[0] == '<');
5200 /* Strip the leading angle bracket. */
5205 /* First, test against the fully qualified name of the symbol. */
5207 if (strncmp (sym_name
, text
, text_len
) == 0)
5210 if (match
&& !encoded
)
5212 /* One needed check before declaring a positive match is to verify
5213 that iff we are doing a verbatim match, the decoded version
5214 of the symbol name starts with '<'. Otherwise, this symbol name
5215 is not a suitable completion. */
5216 const char *sym_name_copy
= sym_name
;
5217 int has_angle_bracket
;
5219 sym_name
= ada_decode (sym_name
);
5220 has_angle_bracket
= (sym_name
[0] == '<');
5221 match
= (has_angle_bracket
== verbatim_match
);
5222 sym_name
= sym_name_copy
;
5225 if (match
&& !verbatim_match
)
5227 /* When doing non-verbatim match, another check that needs to
5228 be done is to verify that the potentially matching symbol name
5229 does not include capital letters, because the ada-mode would
5230 not be able to understand these symbol names without the
5231 angle bracket notation. */
5234 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
5239 /* Second: Try wild matching... */
5241 if (!match
&& wild_match
)
5243 /* Since we are doing wild matching, this means that TEXT
5244 may represent an unqualified symbol name. We therefore must
5245 also compare TEXT against the unqualified name of the symbol. */
5246 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
5248 if (strncmp (sym_name
, text
, text_len
) == 0)
5252 /* Finally: If we found a mach, prepare the result to return. */
5258 sym_name
= add_angle_brackets (sym_name
);
5261 sym_name
= ada_decode (sym_name
);
5266 typedef char *char_ptr
;
5267 DEF_VEC_P (char_ptr
);
5269 /* A companion function to ada_make_symbol_completion_list().
5270 Check if SYM_NAME represents a symbol which name would be suitable
5271 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5272 it is appended at the end of the given string vector SV.
5274 ORIG_TEXT is the string original string from the user command
5275 that needs to be completed. WORD is the entire command on which
5276 completion should be performed. These two parameters are used to
5277 determine which part of the symbol name should be added to the
5279 if WILD_MATCH is set, then wild matching is performed.
5280 ENCODED should be set if TEXT represents a symbol name in its
5281 encoded formed (in which case the completion should also be
5285 symbol_completion_add (VEC(char_ptr
) **sv
,
5286 const char *sym_name
,
5287 const char *text
, int text_len
,
5288 const char *orig_text
, const char *word
,
5289 int wild_match
, int encoded
)
5291 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
5292 wild_match
, encoded
);
5298 /* We found a match, so add the appropriate completion to the given
5301 if (word
== orig_text
)
5303 completion
= xmalloc (strlen (match
) + 5);
5304 strcpy (completion
, match
);
5306 else if (word
> orig_text
)
5308 /* Return some portion of sym_name. */
5309 completion
= xmalloc (strlen (match
) + 5);
5310 strcpy (completion
, match
+ (word
- orig_text
));
5314 /* Return some of ORIG_TEXT plus sym_name. */
5315 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
5316 strncpy (completion
, word
, orig_text
- word
);
5317 completion
[orig_text
- word
] = '\0';
5318 strcat (completion
, match
);
5321 VEC_safe_push (char_ptr
, *sv
, completion
);
5324 /* Return a list of possible symbol names completing TEXT0. The list
5325 is NULL terminated. WORD is the entire command on which completion
5329 ada_make_symbol_completion_list (char *text0
, char *word
)
5335 VEC(char_ptr
) *completions
= VEC_alloc (char_ptr
, 128);
5338 struct partial_symtab
*ps
;
5339 struct minimal_symbol
*msymbol
;
5340 struct objfile
*objfile
;
5341 struct block
*b
, *surrounding_static_block
= 0;
5343 struct dict_iterator iter
;
5345 if (text0
[0] == '<')
5347 text
= xstrdup (text0
);
5348 make_cleanup (xfree
, text
);
5349 text_len
= strlen (text
);
5355 text
= xstrdup (ada_encode (text0
));
5356 make_cleanup (xfree
, text
);
5357 text_len
= strlen (text
);
5358 for (i
= 0; i
< text_len
; i
++)
5359 text
[i
] = tolower (text
[i
]);
5361 encoded
= (strstr (text0
, "__") != NULL
);
5362 /* If the name contains a ".", then the user is entering a fully
5363 qualified entity name, and the match must not be done in wild
5364 mode. Similarly, if the user wants to complete what looks like
5365 an encoded name, the match must not be done in wild mode. */
5366 wild_match
= (strchr (text0
, '.') == NULL
&& !encoded
);
5369 /* First, look at the partial symtab symbols. */
5370 ALL_PSYMTABS (objfile
, ps
)
5372 struct partial_symbol
**psym
;
5374 /* If the psymtab's been read in we'll get it when we search
5375 through the blockvector. */
5379 for (psym
= objfile
->global_psymbols
.list
+ ps
->globals_offset
;
5380 psym
< (objfile
->global_psymbols
.list
+ ps
->globals_offset
5381 + ps
->n_global_syms
); psym
++)
5384 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (*psym
),
5385 text
, text_len
, text0
, word
,
5386 wild_match
, encoded
);
5389 for (psym
= objfile
->static_psymbols
.list
+ ps
->statics_offset
;
5390 psym
< (objfile
->static_psymbols
.list
+ ps
->statics_offset
5391 + ps
->n_static_syms
); psym
++)
5394 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (*psym
),
5395 text
, text_len
, text0
, word
,
5396 wild_match
, encoded
);
5400 /* At this point scan through the misc symbol vectors and add each
5401 symbol you find to the list. Eventually we want to ignore
5402 anything that isn't a text symbol (everything else will be
5403 handled by the psymtab code above). */
5405 ALL_MSYMBOLS (objfile
, msymbol
)
5408 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (msymbol
),
5409 text
, text_len
, text0
, word
, wild_match
, encoded
);
5412 /* Search upwards from currently selected frame (so that we can
5413 complete on local vars. */
5415 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
5417 if (!BLOCK_SUPERBLOCK (b
))
5418 surrounding_static_block
= b
; /* For elmin of dups */
5420 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5422 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5423 text
, text_len
, text0
, word
,
5424 wild_match
, encoded
);
5428 /* Go through the symtabs and check the externs and statics for
5429 symbols which match. */
5431 ALL_SYMTABS (objfile
, s
)
5434 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
5435 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5437 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5438 text
, text_len
, text0
, word
,
5439 wild_match
, encoded
);
5443 ALL_SYMTABS (objfile
, s
)
5446 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
5447 /* Don't do this block twice. */
5448 if (b
== surrounding_static_block
)
5450 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5452 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5453 text
, text_len
, text0
, word
,
5454 wild_match
, encoded
);
5458 /* Append the closing NULL entry. */
5459 VEC_safe_push (char_ptr
, completions
, NULL
);
5461 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5462 return the copy. It's unfortunate that we have to make a copy
5463 of an array that we're about to destroy, but there is nothing much
5464 we can do about it. Fortunately, it's typically not a very large
5467 const size_t completions_size
=
5468 VEC_length (char_ptr
, completions
) * sizeof (char *);
5469 char **result
= malloc (completions_size
);
5471 memcpy (result
, VEC_address (char_ptr
, completions
), completions_size
);
5473 VEC_free (char_ptr
, completions
);
5480 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5481 for tagged types. */
5484 ada_is_dispatch_table_ptr_type (struct type
*type
)
5488 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
5491 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
5495 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
5498 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5499 to be invisible to users. */
5502 ada_is_ignored_field (struct type
*type
, int field_num
)
5504 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5507 /* Check the name of that field. */
5509 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5511 /* Anonymous field names should not be printed.
5512 brobecker/2007-02-20: I don't think this can actually happen
5513 but we don't want to print the value of annonymous fields anyway. */
5517 /* A field named "_parent" is internally generated by GNAT for
5518 tagged types, and should not be printed either. */
5519 if (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0)
5523 /* If this is the dispatch table of a tagged type, then ignore. */
5524 if (ada_is_tagged_type (type
, 1)
5525 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
)))
5528 /* Not a special field, so it should not be ignored. */
5532 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5533 pointer or reference type whose ultimate target has a tag field. */
5536 ada_is_tagged_type (struct type
*type
, int refok
)
5538 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
5541 /* True iff TYPE represents the type of X'Tag */
5544 ada_is_tag_type (struct type
*type
)
5546 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
5550 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
5551 return (name
!= NULL
5552 && strcmp (name
, "ada__tags__dispatch_table") == 0);
5556 /* The type of the tag on VAL. */
5559 ada_tag_type (struct value
*val
)
5561 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
5564 /* The value of the tag on VAL. */
5567 ada_value_tag (struct value
*val
)
5569 return ada_value_struct_elt (val
, "_tag", 0);
5572 /* The value of the tag on the object of type TYPE whose contents are
5573 saved at VALADDR, if it is non-null, or is at memory address
5576 static struct value
*
5577 value_tag_from_contents_and_address (struct type
*type
,
5578 const gdb_byte
*valaddr
,
5581 int tag_byte_offset
, dummy1
, dummy2
;
5582 struct type
*tag_type
;
5583 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5586 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
5588 : valaddr
+ tag_byte_offset
);
5589 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5591 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5596 static struct type
*
5597 type_from_tag (struct value
*tag
)
5599 const char *type_name
= ada_tag_name (tag
);
5600 if (type_name
!= NULL
)
5601 return ada_find_any_type (ada_encode (type_name
));
5612 static int ada_tag_name_1 (void *);
5613 static int ada_tag_name_2 (struct tag_args
*);
5615 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5616 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5617 The value stored in ARGS->name is valid until the next call to
5621 ada_tag_name_1 (void *args0
)
5623 struct tag_args
*args
= (struct tag_args
*) args0
;
5624 static char name
[1024];
5628 val
= ada_value_struct_elt (args
->tag
, "tsd", 1);
5630 return ada_tag_name_2 (args
);
5631 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5634 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5635 for (p
= name
; *p
!= '\0'; p
+= 1)
5642 /* Utility function for ada_tag_name_1 that tries the second
5643 representation for the dispatch table (in which there is no
5644 explicit 'tsd' field in the referent of the tag pointer, and instead
5645 the tsd pointer is stored just before the dispatch table. */
5648 ada_tag_name_2 (struct tag_args
*args
)
5650 struct type
*info_type
;
5651 static char name
[1024];
5653 struct value
*val
, *valp
;
5656 info_type
= ada_find_any_type ("ada__tags__type_specific_data");
5657 if (info_type
== NULL
)
5659 info_type
= lookup_pointer_type (lookup_pointer_type (info_type
));
5660 valp
= value_cast (info_type
, args
->tag
);
5663 val
= value_ind (value_ptradd (valp
,
5664 value_from_longest (builtin_type_int8
, -1)));
5667 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5670 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5671 for (p
= name
; *p
!= '\0'; p
+= 1)
5678 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5682 ada_tag_name (struct value
*tag
)
5684 struct tag_args args
;
5685 if (!ada_is_tag_type (value_type (tag
)))
5689 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5693 /* The parent type of TYPE, or NULL if none. */
5696 ada_parent_type (struct type
*type
)
5700 type
= ada_check_typedef (type
);
5702 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5705 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5706 if (ada_is_parent_field (type
, i
))
5708 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
5710 /* If the _parent field is a pointer, then dereference it. */
5711 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
5712 parent_type
= TYPE_TARGET_TYPE (parent_type
);
5713 /* If there is a parallel XVS type, get the actual base type. */
5714 parent_type
= ada_get_base_type (parent_type
);
5716 return ada_check_typedef (parent_type
);
5722 /* True iff field number FIELD_NUM of structure type TYPE contains the
5723 parent-type (inherited) fields of a derived type. Assumes TYPE is
5724 a structure type with at least FIELD_NUM+1 fields. */
5727 ada_is_parent_field (struct type
*type
, int field_num
)
5729 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5730 return (name
!= NULL
5731 && (strncmp (name
, "PARENT", 6) == 0
5732 || strncmp (name
, "_parent", 7) == 0));
5735 /* True iff field number FIELD_NUM of structure type TYPE is a
5736 transparent wrapper field (which should be silently traversed when doing
5737 field selection and flattened when printing). Assumes TYPE is a
5738 structure type with at least FIELD_NUM+1 fields. Such fields are always
5742 ada_is_wrapper_field (struct type
*type
, int field_num
)
5744 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5745 return (name
!= NULL
5746 && (strncmp (name
, "PARENT", 6) == 0
5747 || strcmp (name
, "REP") == 0
5748 || strncmp (name
, "_parent", 7) == 0
5749 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5752 /* True iff field number FIELD_NUM of structure or union type TYPE
5753 is a variant wrapper. Assumes TYPE is a structure type with at least
5754 FIELD_NUM+1 fields. */
5757 ada_is_variant_part (struct type
*type
, int field_num
)
5759 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5760 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5761 || (is_dynamic_field (type
, field_num
)
5762 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5763 == TYPE_CODE_UNION
)));
5766 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5767 whose discriminants are contained in the record type OUTER_TYPE,
5768 returns the type of the controlling discriminant for the variant. */
5771 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5773 char *name
= ada_variant_discrim_name (var_type
);
5775 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5777 return builtin_type_int32
;
5782 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5783 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5784 represents a 'when others' clause; otherwise 0. */
5787 ada_is_others_clause (struct type
*type
, int field_num
)
5789 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5790 return (name
!= NULL
&& name
[0] == 'O');
5793 /* Assuming that TYPE0 is the type of the variant part of a record,
5794 returns the name of the discriminant controlling the variant.
5795 The value is valid until the next call to ada_variant_discrim_name. */
5798 ada_variant_discrim_name (struct type
*type0
)
5800 static char *result
= NULL
;
5801 static size_t result_len
= 0;
5804 const char *discrim_end
;
5805 const char *discrim_start
;
5807 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5808 type
= TYPE_TARGET_TYPE (type0
);
5812 name
= ada_type_name (type
);
5814 if (name
== NULL
|| name
[0] == '\000')
5817 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5820 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5823 if (discrim_end
== name
)
5826 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5829 if (discrim_start
== name
+ 1)
5831 if ((discrim_start
> name
+ 3
5832 && strncmp (discrim_start
- 3, "___", 3) == 0)
5833 || discrim_start
[-1] == '.')
5837 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5838 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5839 result
[discrim_end
- discrim_start
] = '\0';
5843 /* Scan STR for a subtype-encoded number, beginning at position K.
5844 Put the position of the character just past the number scanned in
5845 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5846 Return 1 if there was a valid number at the given position, and 0
5847 otherwise. A "subtype-encoded" number consists of the absolute value
5848 in decimal, followed by the letter 'm' to indicate a negative number.
5849 Assumes 0m does not occur. */
5852 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5856 if (!isdigit (str
[k
]))
5859 /* Do it the hard way so as not to make any assumption about
5860 the relationship of unsigned long (%lu scan format code) and
5863 while (isdigit (str
[k
]))
5865 RU
= RU
* 10 + (str
[k
] - '0');
5872 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5878 /* NOTE on the above: Technically, C does not say what the results of
5879 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5880 number representable as a LONGEST (although either would probably work
5881 in most implementations). When RU>0, the locution in the then branch
5882 above is always equivalent to the negative of RU. */
5889 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5890 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5891 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5894 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5896 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5909 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5918 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5919 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5921 if (val
>= L
&& val
<= U
)
5933 /* FIXME: Lots of redundancy below. Try to consolidate. */
5935 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5936 ARG_TYPE, extract and return the value of one of its (non-static)
5937 fields. FIELDNO says which field. Differs from value_primitive_field
5938 only in that it can handle packed values of arbitrary type. */
5940 static struct value
*
5941 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5942 struct type
*arg_type
)
5946 arg_type
= ada_check_typedef (arg_type
);
5947 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5949 /* Handle packed fields. */
5951 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5953 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5954 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5956 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
5957 offset
+ bit_pos
/ 8,
5958 bit_pos
% 8, bit_size
, type
);
5961 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5964 /* Find field with name NAME in object of type TYPE. If found,
5965 set the following for each argument that is non-null:
5966 - *FIELD_TYPE_P to the field's type;
5967 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
5968 an object of that type;
5969 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
5970 - *BIT_SIZE_P to its size in bits if the field is packed, and
5972 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
5973 fields up to but not including the desired field, or by the total
5974 number of fields if not found. A NULL value of NAME never
5975 matches; the function just counts visible fields in this case.
5977 Returns 1 if found, 0 otherwise. */
5980 find_struct_field (char *name
, struct type
*type
, int offset
,
5981 struct type
**field_type_p
,
5982 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
5987 type
= ada_check_typedef (type
);
5989 if (field_type_p
!= NULL
)
5990 *field_type_p
= NULL
;
5991 if (byte_offset_p
!= NULL
)
5993 if (bit_offset_p
!= NULL
)
5995 if (bit_size_p
!= NULL
)
5998 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6000 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6001 int fld_offset
= offset
+ bit_pos
/ 8;
6002 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6004 if (t_field_name
== NULL
)
6007 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
6009 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6010 if (field_type_p
!= NULL
)
6011 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6012 if (byte_offset_p
!= NULL
)
6013 *byte_offset_p
= fld_offset
;
6014 if (bit_offset_p
!= NULL
)
6015 *bit_offset_p
= bit_pos
% 8;
6016 if (bit_size_p
!= NULL
)
6017 *bit_size_p
= bit_size
;
6020 else if (ada_is_wrapper_field (type
, i
))
6022 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6023 field_type_p
, byte_offset_p
, bit_offset_p
,
6024 bit_size_p
, index_p
))
6027 else if (ada_is_variant_part (type
, i
))
6029 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6032 struct type
*field_type
6033 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6035 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6037 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
6039 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6040 field_type_p
, byte_offset_p
,
6041 bit_offset_p
, bit_size_p
, index_p
))
6045 else if (index_p
!= NULL
)
6051 /* Number of user-visible fields in record type TYPE. */
6054 num_visible_fields (struct type
*type
)
6058 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
6062 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6063 and search in it assuming it has (class) type TYPE.
6064 If found, return value, else return NULL.
6066 Searches recursively through wrapper fields (e.g., '_parent'). */
6068 static struct value
*
6069 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
6073 type
= ada_check_typedef (type
);
6075 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6077 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6079 if (t_field_name
== NULL
)
6082 else if (field_name_match (t_field_name
, name
))
6083 return ada_value_primitive_field (arg
, offset
, i
, type
);
6085 else if (ada_is_wrapper_field (type
, i
))
6087 struct value
*v
= /* Do not let indent join lines here. */
6088 ada_search_struct_field (name
, arg
,
6089 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6090 TYPE_FIELD_TYPE (type
, i
));
6095 else if (ada_is_variant_part (type
, i
))
6097 /* PNH: Do we ever get here? See find_struct_field. */
6099 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6100 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6102 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6104 struct value
*v
= ada_search_struct_field
/* Force line break. */
6106 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6107 TYPE_FIELD_TYPE (field_type
, j
));
6116 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
6117 int, struct type
*);
6120 /* Return field #INDEX in ARG, where the index is that returned by
6121 * find_struct_field through its INDEX_P argument. Adjust the address
6122 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6123 * If found, return value, else return NULL. */
6125 static struct value
*
6126 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
6129 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
6133 /* Auxiliary function for ada_index_struct_field. Like
6134 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6137 static struct value
*
6138 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
6142 type
= ada_check_typedef (type
);
6144 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6146 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
6148 else if (ada_is_wrapper_field (type
, i
))
6150 struct value
*v
= /* Do not let indent join lines here. */
6151 ada_index_struct_field_1 (index_p
, arg
,
6152 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6153 TYPE_FIELD_TYPE (type
, i
));
6158 else if (ada_is_variant_part (type
, i
))
6160 /* PNH: Do we ever get here? See ada_search_struct_field,
6161 find_struct_field. */
6162 error (_("Cannot assign this kind of variant record"));
6164 else if (*index_p
== 0)
6165 return ada_value_primitive_field (arg
, offset
, i
, type
);
6172 /* Given ARG, a value of type (pointer or reference to a)*
6173 structure/union, extract the component named NAME from the ultimate
6174 target structure/union and return it as a value with its
6177 The routine searches for NAME among all members of the structure itself
6178 and (recursively) among all members of any wrapper members
6181 If NO_ERR, then simply return NULL in case of error, rather than
6185 ada_value_struct_elt (struct value
*arg
, char *name
, int no_err
)
6187 struct type
*t
, *t1
;
6191 t1
= t
= ada_check_typedef (value_type (arg
));
6192 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6194 t1
= TYPE_TARGET_TYPE (t
);
6197 t1
= ada_check_typedef (t1
);
6198 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6200 arg
= coerce_ref (arg
);
6205 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6207 t1
= TYPE_TARGET_TYPE (t
);
6210 t1
= ada_check_typedef (t1
);
6211 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6213 arg
= value_ind (arg
);
6220 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
6224 v
= ada_search_struct_field (name
, arg
, 0, t
);
6227 int bit_offset
, bit_size
, byte_offset
;
6228 struct type
*field_type
;
6231 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6232 address
= value_as_address (arg
);
6234 address
= unpack_pointer (t
, value_contents (arg
));
6236 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
, 1);
6237 if (find_struct_field (name
, t1
, 0,
6238 &field_type
, &byte_offset
, &bit_offset
,
6243 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6244 arg
= ada_coerce_ref (arg
);
6246 arg
= ada_value_ind (arg
);
6247 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
6248 bit_offset
, bit_size
,
6252 v
= value_at_lazy (field_type
, address
+ byte_offset
);
6256 if (v
!= NULL
|| no_err
)
6259 error (_("There is no member named %s."), name
);
6265 error (_("Attempt to extract a component of a value that is not a record."));
6268 /* Given a type TYPE, look up the type of the component of type named NAME.
6269 If DISPP is non-null, add its byte displacement from the beginning of a
6270 structure (pointed to by a value) of type TYPE to *DISPP (does not
6271 work for packed fields).
6273 Matches any field whose name has NAME as a prefix, possibly
6276 TYPE can be either a struct or union. If REFOK, TYPE may also
6277 be a (pointer or reference)+ to a struct or union, and the
6278 ultimate target type will be searched.
6280 Looks recursively into variant clauses and parent types.
6282 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6283 TYPE is not a type of the right kind. */
6285 static struct type
*
6286 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
6287 int noerr
, int *dispp
)
6294 if (refok
&& type
!= NULL
)
6297 type
= ada_check_typedef (type
);
6298 if (TYPE_CODE (type
) != TYPE_CODE_PTR
6299 && TYPE_CODE (type
) != TYPE_CODE_REF
)
6301 type
= TYPE_TARGET_TYPE (type
);
6305 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
6306 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
6312 target_terminal_ours ();
6313 gdb_flush (gdb_stdout
);
6315 error (_("Type (null) is not a structure or union type"));
6318 /* XXX: type_sprint */
6319 fprintf_unfiltered (gdb_stderr
, _("Type "));
6320 type_print (type
, "", gdb_stderr
, -1);
6321 error (_(" is not a structure or union type"));
6326 type
= to_static_fixed_type (type
);
6328 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6330 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6334 if (t_field_name
== NULL
)
6337 else if (field_name_match (t_field_name
, name
))
6340 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
6341 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6344 else if (ada_is_wrapper_field (type
, i
))
6347 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
6352 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6357 else if (ada_is_variant_part (type
, i
))
6360 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6362 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
6364 /* FIXME pnh 2008/01/26: We check for a field that is
6365 NOT wrapped in a struct, since the compiler sometimes
6366 generates these for unchecked variant types. Revisit
6367 if the compiler changes this practice. */
6368 char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
6370 if (v_field_name
!= NULL
6371 && field_name_match (v_field_name
, name
))
6372 t
= ada_check_typedef (TYPE_FIELD_TYPE (field_type
, j
));
6374 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
6380 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6391 target_terminal_ours ();
6392 gdb_flush (gdb_stdout
);
6395 /* XXX: type_sprint */
6396 fprintf_unfiltered (gdb_stderr
, _("Type "));
6397 type_print (type
, "", gdb_stderr
, -1);
6398 error (_(" has no component named <null>"));
6402 /* XXX: type_sprint */
6403 fprintf_unfiltered (gdb_stderr
, _("Type "));
6404 type_print (type
, "", gdb_stderr
, -1);
6405 error (_(" has no component named %s"), name
);
6412 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6413 within a value of type OUTER_TYPE, return true iff VAR_TYPE
6414 represents an unchecked union (that is, the variant part of a
6415 record that is named in an Unchecked_Union pragma). */
6418 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
6420 char *discrim_name
= ada_variant_discrim_name (var_type
);
6421 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1, NULL
)
6426 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6427 within a value of type OUTER_TYPE that is stored in GDB at
6428 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6429 numbering from 0) is applicable. Returns -1 if none are. */
6432 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
6433 const gdb_byte
*outer_valaddr
)
6437 char *discrim_name
= ada_variant_discrim_name (var_type
);
6438 struct value
*outer
;
6439 struct value
*discrim
;
6440 LONGEST discrim_val
;
6442 outer
= value_from_contents_and_address (outer_type
, outer_valaddr
, 0);
6443 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
6444 if (discrim
== NULL
)
6446 discrim_val
= value_as_long (discrim
);
6449 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
6451 if (ada_is_others_clause (var_type
, i
))
6453 else if (ada_in_variant (discrim_val
, var_type
, i
))
6457 return others_clause
;
6462 /* Dynamic-Sized Records */
6464 /* Strategy: The type ostensibly attached to a value with dynamic size
6465 (i.e., a size that is not statically recorded in the debugging
6466 data) does not accurately reflect the size or layout of the value.
6467 Our strategy is to convert these values to values with accurate,
6468 conventional types that are constructed on the fly. */
6470 /* There is a subtle and tricky problem here. In general, we cannot
6471 determine the size of dynamic records without its data. However,
6472 the 'struct value' data structure, which GDB uses to represent
6473 quantities in the inferior process (the target), requires the size
6474 of the type at the time of its allocation in order to reserve space
6475 for GDB's internal copy of the data. That's why the
6476 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6477 rather than struct value*s.
6479 However, GDB's internal history variables ($1, $2, etc.) are
6480 struct value*s containing internal copies of the data that are not, in
6481 general, the same as the data at their corresponding addresses in
6482 the target. Fortunately, the types we give to these values are all
6483 conventional, fixed-size types (as per the strategy described
6484 above), so that we don't usually have to perform the
6485 'to_fixed_xxx_type' conversions to look at their values.
6486 Unfortunately, there is one exception: if one of the internal
6487 history variables is an array whose elements are unconstrained
6488 records, then we will need to create distinct fixed types for each
6489 element selected. */
6491 /* The upshot of all of this is that many routines take a (type, host
6492 address, target address) triple as arguments to represent a value.
6493 The host address, if non-null, is supposed to contain an internal
6494 copy of the relevant data; otherwise, the program is to consult the
6495 target at the target address. */
6497 /* Assuming that VAL0 represents a pointer value, the result of
6498 dereferencing it. Differs from value_ind in its treatment of
6499 dynamic-sized types. */
6502 ada_value_ind (struct value
*val0
)
6504 struct value
*val
= unwrap_value (value_ind (val0
));
6505 return ada_to_fixed_value (val
);
6508 /* The value resulting from dereferencing any "reference to"
6509 qualifiers on VAL0. */
6511 static struct value
*
6512 ada_coerce_ref (struct value
*val0
)
6514 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
6516 struct value
*val
= val0
;
6517 val
= coerce_ref (val
);
6518 val
= unwrap_value (val
);
6519 return ada_to_fixed_value (val
);
6525 /* Return OFF rounded upward if necessary to a multiple of
6526 ALIGNMENT (a power of 2). */
6529 align_value (unsigned int off
, unsigned int alignment
)
6531 return (off
+ alignment
- 1) & ~(alignment
- 1);
6534 /* Return the bit alignment required for field #F of template type TYPE. */
6537 field_alignment (struct type
*type
, int f
)
6539 const char *name
= TYPE_FIELD_NAME (type
, f
);
6543 /* The field name should never be null, unless the debugging information
6544 is somehow malformed. In this case, we assume the field does not
6545 require any alignment. */
6549 len
= strlen (name
);
6551 if (!isdigit (name
[len
- 1]))
6554 if (isdigit (name
[len
- 2]))
6555 align_offset
= len
- 2;
6557 align_offset
= len
- 1;
6559 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
6560 return TARGET_CHAR_BIT
;
6562 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
6565 /* Find a symbol named NAME. Ignores ambiguity. */
6568 ada_find_any_symbol (const char *name
)
6572 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
6573 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
6576 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
6580 /* Find a type named NAME. Ignores ambiguity. */
6583 ada_find_any_type (const char *name
)
6585 struct symbol
*sym
= ada_find_any_symbol (name
);
6588 return SYMBOL_TYPE (sym
);
6593 /* Given NAME and an associated BLOCK, search all symbols for
6594 NAME suffixed with "___XR", which is the ``renaming'' symbol
6595 associated to NAME. Return this symbol if found, return
6599 ada_find_renaming_symbol (const char *name
, struct block
*block
)
6603 sym
= find_old_style_renaming_symbol (name
, block
);
6608 /* Not right yet. FIXME pnh 7/20/2007. */
6609 sym
= ada_find_any_symbol (name
);
6610 if (sym
!= NULL
&& strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR") != NULL
)
6616 static struct symbol
*
6617 find_old_style_renaming_symbol (const char *name
, struct block
*block
)
6619 const struct symbol
*function_sym
= block_linkage_function (block
);
6622 if (function_sym
!= NULL
)
6624 /* If the symbol is defined inside a function, NAME is not fully
6625 qualified. This means we need to prepend the function name
6626 as well as adding the ``___XR'' suffix to build the name of
6627 the associated renaming symbol. */
6628 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
6629 /* Function names sometimes contain suffixes used
6630 for instance to qualify nested subprograms. When building
6631 the XR type name, we need to make sure that this suffix is
6632 not included. So do not include any suffix in the function
6633 name length below. */
6634 const int function_name_len
= ada_name_prefix_len (function_name
);
6635 const int rename_len
= function_name_len
+ 2 /* "__" */
6636 + strlen (name
) + 6 /* "___XR\0" */ ;
6638 /* Strip the suffix if necessary. */
6639 function_name
[function_name_len
] = '\0';
6641 /* Library-level functions are a special case, as GNAT adds
6642 a ``_ada_'' prefix to the function name to avoid namespace
6643 pollution. However, the renaming symbols themselves do not
6644 have this prefix, so we need to skip this prefix if present. */
6645 if (function_name_len
> 5 /* "_ada_" */
6646 && strstr (function_name
, "_ada_") == function_name
)
6647 function_name
= function_name
+ 5;
6649 rename
= (char *) alloca (rename_len
* sizeof (char));
6650 sprintf (rename
, "%s__%s___XR", function_name
, name
);
6654 const int rename_len
= strlen (name
) + 6;
6655 rename
= (char *) alloca (rename_len
* sizeof (char));
6656 sprintf (rename
, "%s___XR", name
);
6659 return ada_find_any_symbol (rename
);
6662 /* Because of GNAT encoding conventions, several GDB symbols may match a
6663 given type name. If the type denoted by TYPE0 is to be preferred to
6664 that of TYPE1 for purposes of type printing, return non-zero;
6665 otherwise return 0. */
6668 ada_prefer_type (struct type
*type0
, struct type
*type1
)
6672 else if (type0
== NULL
)
6674 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
6676 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
6678 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
6680 else if (ada_is_packed_array_type (type0
))
6682 else if (ada_is_array_descriptor_type (type0
)
6683 && !ada_is_array_descriptor_type (type1
))
6687 const char *type0_name
= type_name_no_tag (type0
);
6688 const char *type1_name
= type_name_no_tag (type1
);
6690 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
6691 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
6697 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6698 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6701 ada_type_name (struct type
*type
)
6705 else if (TYPE_NAME (type
) != NULL
)
6706 return TYPE_NAME (type
);
6708 return TYPE_TAG_NAME (type
);
6711 /* Find a parallel type to TYPE whose name is formed by appending
6712 SUFFIX to the name of TYPE. */
6715 ada_find_parallel_type (struct type
*type
, const char *suffix
)
6718 static size_t name_len
= 0;
6720 char *typename
= ada_type_name (type
);
6722 if (typename
== NULL
)
6725 len
= strlen (typename
);
6727 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
6729 strcpy (name
, typename
);
6730 strcpy (name
+ len
, suffix
);
6732 return ada_find_any_type (name
);
6736 /* If TYPE is a variable-size record type, return the corresponding template
6737 type describing its fields. Otherwise, return NULL. */
6739 static struct type
*
6740 dynamic_template_type (struct type
*type
)
6742 type
= ada_check_typedef (type
);
6744 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
6745 || ada_type_name (type
) == NULL
)
6749 int len
= strlen (ada_type_name (type
));
6750 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
6753 return ada_find_parallel_type (type
, "___XVE");
6757 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6758 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6761 is_dynamic_field (struct type
*templ_type
, int field_num
)
6763 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
6765 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
6766 && strstr (name
, "___XVL") != NULL
;
6769 /* The index of the variant field of TYPE, or -1 if TYPE does not
6770 represent a variant record type. */
6773 variant_field_index (struct type
*type
)
6777 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6780 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6782 if (ada_is_variant_part (type
, f
))
6788 /* A record type with no fields. */
6790 static struct type
*
6791 empty_record (struct objfile
*objfile
)
6793 struct type
*type
= alloc_type (objfile
);
6794 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6795 TYPE_NFIELDS (type
) = 0;
6796 TYPE_FIELDS (type
) = NULL
;
6797 INIT_CPLUS_SPECIFIC (type
);
6798 TYPE_NAME (type
) = "<empty>";
6799 TYPE_TAG_NAME (type
) = NULL
;
6800 TYPE_LENGTH (type
) = 0;
6804 /* An ordinary record type (with fixed-length fields) that describes
6805 the value of type TYPE at VALADDR or ADDRESS (see comments at
6806 the beginning of this section) VAL according to GNAT conventions.
6807 DVAL0 should describe the (portion of a) record that contains any
6808 necessary discriminants. It should be NULL if value_type (VAL) is
6809 an outer-level type (i.e., as opposed to a branch of a variant.) A
6810 variant field (unless unchecked) is replaced by a particular branch
6813 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6814 length are not statically known are discarded. As a consequence,
6815 VALADDR, ADDRESS and DVAL0 are ignored.
6817 NOTE: Limitations: For now, we assume that dynamic fields and
6818 variants occupy whole numbers of bytes. However, they need not be
6822 ada_template_to_fixed_record_type_1 (struct type
*type
,
6823 const gdb_byte
*valaddr
,
6824 CORE_ADDR address
, struct value
*dval0
,
6825 int keep_dynamic_fields
)
6827 struct value
*mark
= value_mark ();
6830 int nfields
, bit_len
;
6833 int fld_bit_len
, bit_incr
;
6836 /* Compute the number of fields in this record type that are going
6837 to be processed: unless keep_dynamic_fields, this includes only
6838 fields whose position and length are static will be processed. */
6839 if (keep_dynamic_fields
)
6840 nfields
= TYPE_NFIELDS (type
);
6844 while (nfields
< TYPE_NFIELDS (type
)
6845 && !ada_is_variant_part (type
, nfields
)
6846 && !is_dynamic_field (type
, nfields
))
6850 rtype
= alloc_type (TYPE_OBJFILE (type
));
6851 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6852 INIT_CPLUS_SPECIFIC (rtype
);
6853 TYPE_NFIELDS (rtype
) = nfields
;
6854 TYPE_FIELDS (rtype
) = (struct field
*)
6855 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6856 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6857 TYPE_NAME (rtype
) = ada_type_name (type
);
6858 TYPE_TAG_NAME (rtype
) = NULL
;
6859 TYPE_FIXED_INSTANCE (rtype
) = 1;
6865 for (f
= 0; f
< nfields
; f
+= 1)
6867 off
= align_value (off
, field_alignment (type
, f
))
6868 + TYPE_FIELD_BITPOS (type
, f
);
6869 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6870 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6872 if (ada_is_variant_part (type
, f
))
6875 fld_bit_len
= bit_incr
= 0;
6877 else if (is_dynamic_field (type
, f
))
6880 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6884 /* Get the fixed type of the field. Note that, in this case, we
6885 do not want to get the real type out of the tag: if the current
6886 field is the parent part of a tagged record, we will get the
6887 tag of the object. Clearly wrong: the real type of the parent
6888 is not the real type of the child. We would end up in an infinite
6890 TYPE_FIELD_TYPE (rtype
, f
) =
6893 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6894 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6895 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
, 0);
6896 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6897 bit_incr
= fld_bit_len
=
6898 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6902 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6903 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6904 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6905 bit_incr
= fld_bit_len
=
6906 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6908 bit_incr
= fld_bit_len
=
6909 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6911 if (off
+ fld_bit_len
> bit_len
)
6912 bit_len
= off
+ fld_bit_len
;
6914 TYPE_LENGTH (rtype
) =
6915 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6918 /* We handle the variant part, if any, at the end because of certain
6919 odd cases in which it is re-ordered so as NOT to be the last field of
6920 the record. This can happen in the presence of representation
6922 if (variant_field
>= 0)
6924 struct type
*branch_type
;
6926 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6929 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6934 to_fixed_variant_branch_type
6935 (TYPE_FIELD_TYPE (type
, variant_field
),
6936 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6937 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6938 if (branch_type
== NULL
)
6940 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6941 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6942 TYPE_NFIELDS (rtype
) -= 1;
6946 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6947 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6949 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6951 if (off
+ fld_bit_len
> bit_len
)
6952 bit_len
= off
+ fld_bit_len
;
6953 TYPE_LENGTH (rtype
) =
6954 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6958 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6959 should contain the alignment of that record, which should be a strictly
6960 positive value. If null or negative, then something is wrong, most
6961 probably in the debug info. In that case, we don't round up the size
6962 of the resulting type. If this record is not part of another structure,
6963 the current RTYPE length might be good enough for our purposes. */
6964 if (TYPE_LENGTH (type
) <= 0)
6966 if (TYPE_NAME (rtype
))
6967 warning (_("Invalid type size for `%s' detected: %d."),
6968 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
6970 warning (_("Invalid type size for <unnamed> detected: %d."),
6971 TYPE_LENGTH (type
));
6975 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
6976 TYPE_LENGTH (type
));
6979 value_free_to_mark (mark
);
6980 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6981 error (_("record type with dynamic size is larger than varsize-limit"));
6985 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6988 static struct type
*
6989 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
6990 CORE_ADDR address
, struct value
*dval0
)
6992 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
6996 /* An ordinary record type in which ___XVL-convention fields and
6997 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6998 static approximations, containing all possible fields. Uses
6999 no runtime values. Useless for use in values, but that's OK,
7000 since the results are used only for type determinations. Works on both
7001 structs and unions. Representation note: to save space, we memorize
7002 the result of this function in the TYPE_TARGET_TYPE of the
7005 static struct type
*
7006 template_to_static_fixed_type (struct type
*type0
)
7012 if (TYPE_TARGET_TYPE (type0
) != NULL
)
7013 return TYPE_TARGET_TYPE (type0
);
7015 nfields
= TYPE_NFIELDS (type0
);
7018 for (f
= 0; f
< nfields
; f
+= 1)
7020 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
7021 struct type
*new_type
;
7023 if (is_dynamic_field (type0
, f
))
7024 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
7026 new_type
= static_unwrap_type (field_type
);
7027 if (type
== type0
&& new_type
!= field_type
)
7029 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
7030 TYPE_CODE (type
) = TYPE_CODE (type0
);
7031 INIT_CPLUS_SPECIFIC (type
);
7032 TYPE_NFIELDS (type
) = nfields
;
7033 TYPE_FIELDS (type
) = (struct field
*)
7034 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
7035 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
7036 sizeof (struct field
) * nfields
);
7037 TYPE_NAME (type
) = ada_type_name (type0
);
7038 TYPE_TAG_NAME (type
) = NULL
;
7039 TYPE_FIXED_INSTANCE (type
) = 1;
7040 TYPE_LENGTH (type
) = 0;
7042 TYPE_FIELD_TYPE (type
, f
) = new_type
;
7043 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
7048 /* Given an object of type TYPE whose contents are at VALADDR and
7049 whose address in memory is ADDRESS, returns a revision of TYPE,
7050 which should be a non-dynamic-sized record, in which the variant
7051 part, if any, is replaced with the appropriate branch. Looks
7052 for discriminant values in DVAL0, which can be NULL if the record
7053 contains the necessary discriminant values. */
7055 static struct type
*
7056 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
7057 CORE_ADDR address
, struct value
*dval0
)
7059 struct value
*mark
= value_mark ();
7062 struct type
*branch_type
;
7063 int nfields
= TYPE_NFIELDS (type
);
7064 int variant_field
= variant_field_index (type
);
7066 if (variant_field
== -1)
7070 dval
= value_from_contents_and_address (type
, valaddr
, address
);
7074 rtype
= alloc_type (TYPE_OBJFILE (type
));
7075 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7076 INIT_CPLUS_SPECIFIC (rtype
);
7077 TYPE_NFIELDS (rtype
) = nfields
;
7078 TYPE_FIELDS (rtype
) =
7079 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7080 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
7081 sizeof (struct field
) * nfields
);
7082 TYPE_NAME (rtype
) = ada_type_name (type
);
7083 TYPE_TAG_NAME (rtype
) = NULL
;
7084 TYPE_FIXED_INSTANCE (rtype
) = 1;
7085 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
7087 branch_type
= to_fixed_variant_branch_type
7088 (TYPE_FIELD_TYPE (type
, variant_field
),
7089 cond_offset_host (valaddr
,
7090 TYPE_FIELD_BITPOS (type
, variant_field
)
7092 cond_offset_target (address
,
7093 TYPE_FIELD_BITPOS (type
, variant_field
)
7094 / TARGET_CHAR_BIT
), dval
);
7095 if (branch_type
== NULL
)
7098 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
7099 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7100 TYPE_NFIELDS (rtype
) -= 1;
7104 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7105 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7106 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
7107 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
7109 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
7111 value_free_to_mark (mark
);
7115 /* An ordinary record type (with fixed-length fields) that describes
7116 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7117 beginning of this section]. Any necessary discriminants' values
7118 should be in DVAL, a record value; it may be NULL if the object
7119 at ADDR itself contains any necessary discriminant values.
7120 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7121 values from the record are needed. Except in the case that DVAL,
7122 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7123 unchecked) is replaced by a particular branch of the variant.
7125 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7126 is questionable and may be removed. It can arise during the
7127 processing of an unconstrained-array-of-record type where all the
7128 variant branches have exactly the same size. This is because in
7129 such cases, the compiler does not bother to use the XVS convention
7130 when encoding the record. I am currently dubious of this
7131 shortcut and suspect the compiler should be altered. FIXME. */
7133 static struct type
*
7134 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
7135 CORE_ADDR address
, struct value
*dval
)
7137 struct type
*templ_type
;
7139 if (TYPE_FIXED_INSTANCE (type0
))
7142 templ_type
= dynamic_template_type (type0
);
7144 if (templ_type
!= NULL
)
7145 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
7146 else if (variant_field_index (type0
) >= 0)
7148 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
7150 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
7155 TYPE_FIXED_INSTANCE (type0
) = 1;
7161 /* An ordinary record type (with fixed-length fields) that describes
7162 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7163 union type. Any necessary discriminants' values should be in DVAL,
7164 a record value. That is, this routine selects the appropriate
7165 branch of the union at ADDR according to the discriminant value
7166 indicated in the union's type name. Returns VAR_TYPE0 itself if
7167 it represents a variant subject to a pragma Unchecked_Union. */
7169 static struct type
*
7170 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
7171 CORE_ADDR address
, struct value
*dval
)
7174 struct type
*templ_type
;
7175 struct type
*var_type
;
7177 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
7178 var_type
= TYPE_TARGET_TYPE (var_type0
);
7180 var_type
= var_type0
;
7182 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
7184 if (templ_type
!= NULL
)
7185 var_type
= templ_type
;
7187 if (is_unchecked_variant (var_type
, value_type (dval
)))
7190 ada_which_variant_applies (var_type
,
7191 value_type (dval
), value_contents (dval
));
7194 return empty_record (TYPE_OBJFILE (var_type
));
7195 else if (is_dynamic_field (var_type
, which
))
7196 return to_fixed_record_type
7197 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
7198 valaddr
, address
, dval
);
7199 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
7201 to_fixed_record_type
7202 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
7204 return TYPE_FIELD_TYPE (var_type
, which
);
7207 /* Assuming that TYPE0 is an array type describing the type of a value
7208 at ADDR, and that DVAL describes a record containing any
7209 discriminants used in TYPE0, returns a type for the value that
7210 contains no dynamic components (that is, no components whose sizes
7211 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7212 true, gives an error message if the resulting type's size is over
7215 static struct type
*
7216 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
7219 struct type
*index_type_desc
;
7220 struct type
*result
;
7222 if (ada_is_packed_array_type (type0
) /* revisit? */
7223 || TYPE_FIXED_INSTANCE (type0
))
7226 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
7227 if (index_type_desc
== NULL
)
7229 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
7230 /* NOTE: elt_type---the fixed version of elt_type0---should never
7231 depend on the contents of the array in properly constructed
7233 /* Create a fixed version of the array element type.
7234 We're not providing the address of an element here,
7235 and thus the actual object value cannot be inspected to do
7236 the conversion. This should not be a problem, since arrays of
7237 unconstrained objects are not allowed. In particular, all
7238 the elements of an array of a tagged type should all be of
7239 the same type specified in the debugging info. No need to
7240 consult the object tag. */
7241 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
7243 if (elt_type0
== elt_type
)
7246 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7247 elt_type
, TYPE_INDEX_TYPE (type0
));
7252 struct type
*elt_type0
;
7255 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
7256 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
7258 /* NOTE: result---the fixed version of elt_type0---should never
7259 depend on the contents of the array in properly constructed
7261 /* Create a fixed version of the array element type.
7262 We're not providing the address of an element here,
7263 and thus the actual object value cannot be inspected to do
7264 the conversion. This should not be a problem, since arrays of
7265 unconstrained objects are not allowed. In particular, all
7266 the elements of an array of a tagged type should all be of
7267 the same type specified in the debugging info. No need to
7268 consult the object tag. */
7270 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
7271 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
7273 struct type
*range_type
=
7274 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
7275 dval
, TYPE_OBJFILE (type0
));
7276 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7277 result
, range_type
);
7279 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
7280 error (_("array type with dynamic size is larger than varsize-limit"));
7283 TYPE_FIXED_INSTANCE (result
) = 1;
7288 /* A standard type (containing no dynamically sized components)
7289 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7290 DVAL describes a record containing any discriminants used in TYPE0,
7291 and may be NULL if there are none, or if the object of type TYPE at
7292 ADDRESS or in VALADDR contains these discriminants.
7294 If CHECK_TAG is not null, in the case of tagged types, this function
7295 attempts to locate the object's tag and use it to compute the actual
7296 type. However, when ADDRESS is null, we cannot use it to determine the
7297 location of the tag, and therefore compute the tagged type's actual type.
7298 So we return the tagged type without consulting the tag. */
7300 static struct type
*
7301 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
7302 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7304 type
= ada_check_typedef (type
);
7305 switch (TYPE_CODE (type
))
7309 case TYPE_CODE_STRUCT
:
7311 struct type
*static_type
= to_static_fixed_type (type
);
7312 struct type
*fixed_record_type
=
7313 to_fixed_record_type (type
, valaddr
, address
, NULL
);
7314 /* If STATIC_TYPE is a tagged type and we know the object's address,
7315 then we can determine its tag, and compute the object's actual
7316 type from there. Note that we have to use the fixed record
7317 type (the parent part of the record may have dynamic fields
7318 and the way the location of _tag is expressed may depend on
7321 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
7323 struct type
*real_type
=
7324 type_from_tag (value_tag_from_contents_and_address
7328 if (real_type
!= NULL
)
7329 return to_fixed_record_type (real_type
, valaddr
, address
, NULL
);
7332 /* Check to see if there is a parallel ___XVZ variable.
7333 If there is, then it provides the actual size of our type. */
7334 else if (ada_type_name (fixed_record_type
) != NULL
)
7336 char *name
= ada_type_name (fixed_record_type
);
7337 char *xvz_name
= alloca (strlen (name
) + 7 /* "___XVZ\0" */);
7341 sprintf (xvz_name
, "%s___XVZ", name
);
7342 size
= get_int_var_value (xvz_name
, &xvz_found
);
7343 if (xvz_found
&& TYPE_LENGTH (fixed_record_type
) != size
)
7345 fixed_record_type
= copy_type (fixed_record_type
);
7346 TYPE_LENGTH (fixed_record_type
) = size
;
7348 /* The FIXED_RECORD_TYPE may have be a stub. We have
7349 observed this when the debugging info is STABS, and
7350 apparently it is something that is hard to fix.
7352 In practice, we don't need the actual type definition
7353 at all, because the presence of the XVZ variable allows us
7354 to assume that there must be a XVS type as well, which we
7355 should be able to use later, when we need the actual type
7358 In the meantime, pretend that the "fixed" type we are
7359 returning is NOT a stub, because this can cause trouble
7360 when using this type to create new types targeting it.
7361 Indeed, the associated creation routines often check
7362 whether the target type is a stub and will try to replace
7363 it, thus using a type with the wrong size. This, in turn,
7364 might cause the new type to have the wrong size too.
7365 Consider the case of an array, for instance, where the size
7366 of the array is computed from the number of elements in
7367 our array multiplied by the size of its element. */
7368 TYPE_STUB (fixed_record_type
) = 0;
7371 return fixed_record_type
;
7373 case TYPE_CODE_ARRAY
:
7374 return to_fixed_array_type (type
, dval
, 1);
7375 case TYPE_CODE_UNION
:
7379 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
7383 /* The same as ada_to_fixed_type_1, except that it preserves the type
7384 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7385 ada_to_fixed_type_1 would return the type referenced by TYPE. */
7388 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
7389 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7392 struct type
*fixed_type
=
7393 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
7395 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
7396 && TYPE_TARGET_TYPE (type
) == fixed_type
)
7402 /* A standard (static-sized) type corresponding as well as possible to
7403 TYPE0, but based on no runtime data. */
7405 static struct type
*
7406 to_static_fixed_type (struct type
*type0
)
7413 if (TYPE_FIXED_INSTANCE (type0
))
7416 type0
= ada_check_typedef (type0
);
7418 switch (TYPE_CODE (type0
))
7422 case TYPE_CODE_STRUCT
:
7423 type
= dynamic_template_type (type0
);
7425 return template_to_static_fixed_type (type
);
7427 return template_to_static_fixed_type (type0
);
7428 case TYPE_CODE_UNION
:
7429 type
= ada_find_parallel_type (type0
, "___XVU");
7431 return template_to_static_fixed_type (type
);
7433 return template_to_static_fixed_type (type0
);
7437 /* A static approximation of TYPE with all type wrappers removed. */
7439 static struct type
*
7440 static_unwrap_type (struct type
*type
)
7442 if (ada_is_aligner_type (type
))
7444 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
7445 if (ada_type_name (type1
) == NULL
)
7446 TYPE_NAME (type1
) = ada_type_name (type
);
7448 return static_unwrap_type (type1
);
7452 struct type
*raw_real_type
= ada_get_base_type (type
);
7453 if (raw_real_type
== type
)
7456 return to_static_fixed_type (raw_real_type
);
7460 /* In some cases, incomplete and private types require
7461 cross-references that are not resolved as records (for example,
7463 type FooP is access Foo;
7465 type Foo is array ...;
7466 ). In these cases, since there is no mechanism for producing
7467 cross-references to such types, we instead substitute for FooP a
7468 stub enumeration type that is nowhere resolved, and whose tag is
7469 the name of the actual type. Call these types "non-record stubs". */
7471 /* A type equivalent to TYPE that is not a non-record stub, if one
7472 exists, otherwise TYPE. */
7475 ada_check_typedef (struct type
*type
)
7480 CHECK_TYPEDEF (type
);
7481 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
7482 || !TYPE_STUB (type
)
7483 || TYPE_TAG_NAME (type
) == NULL
)
7487 char *name
= TYPE_TAG_NAME (type
);
7488 struct type
*type1
= ada_find_any_type (name
);
7489 return (type1
== NULL
) ? type
: type1
;
7493 /* A value representing the data at VALADDR/ADDRESS as described by
7494 type TYPE0, but with a standard (static-sized) type that correctly
7495 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7496 type, then return VAL0 [this feature is simply to avoid redundant
7497 creation of struct values]. */
7499 static struct value
*
7500 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
7503 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
7504 if (type
== type0
&& val0
!= NULL
)
7507 return value_from_contents_and_address (type
, 0, address
);
7510 /* A value representing VAL, but with a standard (static-sized) type
7511 that correctly describes it. Does not necessarily create a new
7514 static struct value
*
7515 ada_to_fixed_value (struct value
*val
)
7517 return ada_to_fixed_value_create (value_type (val
),
7518 VALUE_ADDRESS (val
) + value_offset (val
),
7522 /* A value representing VAL, but with a standard (static-sized) type
7523 chosen to approximate the real type of VAL as well as possible, but
7524 without consulting any runtime values. For Ada dynamic-sized
7525 types, therefore, the type of the result is likely to be inaccurate. */
7528 ada_to_static_fixed_value (struct value
*val
)
7531 to_static_fixed_type (static_unwrap_type (value_type (val
)));
7532 if (type
== value_type (val
))
7535 return coerce_unspec_val_to_type (val
, type
);
7541 /* Table mapping attribute numbers to names.
7542 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7544 static const char *attribute_names
[] = {
7562 ada_attribute_name (enum exp_opcode n
)
7564 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
7565 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
7567 return attribute_names
[0];
7570 /* Evaluate the 'POS attribute applied to ARG. */
7573 pos_atr (struct value
*arg
)
7575 struct value
*val
= coerce_ref (arg
);
7576 struct type
*type
= value_type (val
);
7578 if (!discrete_type_p (type
))
7579 error (_("'POS only defined on discrete types"));
7581 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7584 LONGEST v
= value_as_long (val
);
7586 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7588 if (v
== TYPE_FIELD_BITPOS (type
, i
))
7591 error (_("enumeration value is invalid: can't find 'POS"));
7594 return value_as_long (val
);
7597 static struct value
*
7598 value_pos_atr (struct type
*type
, struct value
*arg
)
7600 return value_from_longest (type
, pos_atr (arg
));
7603 /* Evaluate the TYPE'VAL attribute applied to ARG. */
7605 static struct value
*
7606 value_val_atr (struct type
*type
, struct value
*arg
)
7608 if (!discrete_type_p (type
))
7609 error (_("'VAL only defined on discrete types"));
7610 if (!integer_type_p (value_type (arg
)))
7611 error (_("'VAL requires integral argument"));
7613 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7615 long pos
= value_as_long (arg
);
7616 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
7617 error (_("argument to 'VAL out of range"));
7618 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
7621 return value_from_longest (type
, value_as_long (arg
));
7627 /* True if TYPE appears to be an Ada character type.
7628 [At the moment, this is true only for Character and Wide_Character;
7629 It is a heuristic test that could stand improvement]. */
7632 ada_is_character_type (struct type
*type
)
7636 /* If the type code says it's a character, then assume it really is,
7637 and don't check any further. */
7638 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
7641 /* Otherwise, assume it's a character type iff it is a discrete type
7642 with a known character type name. */
7643 name
= ada_type_name (type
);
7644 return (name
!= NULL
7645 && (TYPE_CODE (type
) == TYPE_CODE_INT
7646 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7647 && (strcmp (name
, "character") == 0
7648 || strcmp (name
, "wide_character") == 0
7649 || strcmp (name
, "wide_wide_character") == 0
7650 || strcmp (name
, "unsigned char") == 0));
7653 /* True if TYPE appears to be an Ada string type. */
7656 ada_is_string_type (struct type
*type
)
7658 type
= ada_check_typedef (type
);
7660 && TYPE_CODE (type
) != TYPE_CODE_PTR
7661 && (ada_is_simple_array_type (type
)
7662 || ada_is_array_descriptor_type (type
))
7663 && ada_array_arity (type
) == 1)
7665 struct type
*elttype
= ada_array_element_type (type
, 1);
7667 return ada_is_character_type (elttype
);
7674 /* True if TYPE is a struct type introduced by the compiler to force the
7675 alignment of a value. Such types have a single field with a
7676 distinctive name. */
7679 ada_is_aligner_type (struct type
*type
)
7681 type
= ada_check_typedef (type
);
7683 /* If we can find a parallel XVS type, then the XVS type should
7684 be used instead of this type. And hence, this is not an aligner
7686 if (ada_find_parallel_type (type
, "___XVS") != NULL
)
7689 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
7690 && TYPE_NFIELDS (type
) == 1
7691 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
7694 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7695 the parallel type. */
7698 ada_get_base_type (struct type
*raw_type
)
7700 struct type
*real_type_namer
;
7701 struct type
*raw_real_type
;
7703 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
7706 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
7707 if (real_type_namer
== NULL
7708 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
7709 || TYPE_NFIELDS (real_type_namer
) != 1)
7712 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
7713 if (raw_real_type
== NULL
)
7716 return raw_real_type
;
7719 /* The type of value designated by TYPE, with all aligners removed. */
7722 ada_aligned_type (struct type
*type
)
7724 if (ada_is_aligner_type (type
))
7725 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
7727 return ada_get_base_type (type
);
7731 /* The address of the aligned value in an object at address VALADDR
7732 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7735 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
7737 if (ada_is_aligner_type (type
))
7738 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
7740 TYPE_FIELD_BITPOS (type
,
7741 0) / TARGET_CHAR_BIT
);
7748 /* The printed representation of an enumeration literal with encoded
7749 name NAME. The value is good to the next call of ada_enum_name. */
7751 ada_enum_name (const char *name
)
7753 static char *result
;
7754 static size_t result_len
= 0;
7757 /* First, unqualify the enumeration name:
7758 1. Search for the last '.' character. If we find one, then skip
7759 all the preceeding characters, the unqualified name starts
7760 right after that dot.
7761 2. Otherwise, we may be debugging on a target where the compiler
7762 translates dots into "__". Search forward for double underscores,
7763 but stop searching when we hit an overloading suffix, which is
7764 of the form "__" followed by digits. */
7766 tmp
= strrchr (name
, '.');
7771 while ((tmp
= strstr (name
, "__")) != NULL
)
7773 if (isdigit (tmp
[2]))
7783 if (name
[1] == 'U' || name
[1] == 'W')
7785 if (sscanf (name
+ 2, "%x", &v
) != 1)
7791 GROW_VECT (result
, result_len
, 16);
7792 if (isascii (v
) && isprint (v
))
7793 sprintf (result
, "'%c'", v
);
7794 else if (name
[1] == 'U')
7795 sprintf (result
, "[\"%02x\"]", v
);
7797 sprintf (result
, "[\"%04x\"]", v
);
7803 tmp
= strstr (name
, "__");
7805 tmp
= strstr (name
, "$");
7808 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
7809 strncpy (result
, name
, tmp
- name
);
7810 result
[tmp
- name
] = '\0';
7818 static struct value
*
7819 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
7822 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7823 (expect_type
, exp
, pos
, noside
);
7826 /* Evaluate the subexpression of EXP starting at *POS as for
7827 evaluate_type, updating *POS to point just past the evaluated
7830 static struct value
*
7831 evaluate_subexp_type (struct expression
*exp
, int *pos
)
7833 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7834 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
7837 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7840 static struct value
*
7841 unwrap_value (struct value
*val
)
7843 struct type
*type
= ada_check_typedef (value_type (val
));
7844 if (ada_is_aligner_type (type
))
7846 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
7847 struct type
*val_type
= ada_check_typedef (value_type (v
));
7848 if (ada_type_name (val_type
) == NULL
)
7849 TYPE_NAME (val_type
) = ada_type_name (type
);
7851 return unwrap_value (v
);
7855 struct type
*raw_real_type
=
7856 ada_check_typedef (ada_get_base_type (type
));
7858 if (type
== raw_real_type
)
7862 coerce_unspec_val_to_type
7863 (val
, ada_to_fixed_type (raw_real_type
, 0,
7864 VALUE_ADDRESS (val
) + value_offset (val
),
7869 static struct value
*
7870 cast_to_fixed (struct type
*type
, struct value
*arg
)
7874 if (type
== value_type (arg
))
7876 else if (ada_is_fixed_point_type (value_type (arg
)))
7877 val
= ada_float_to_fixed (type
,
7878 ada_fixed_to_float (value_type (arg
),
7879 value_as_long (arg
)));
7882 DOUBLEST argd
= value_as_double (arg
);
7883 val
= ada_float_to_fixed (type
, argd
);
7886 return value_from_longest (type
, val
);
7889 static struct value
*
7890 cast_from_fixed (struct type
*type
, struct value
*arg
)
7892 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
7893 value_as_long (arg
));
7894 return value_from_double (type
, val
);
7897 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7898 return the converted value. */
7900 static struct value
*
7901 coerce_for_assign (struct type
*type
, struct value
*val
)
7903 struct type
*type2
= value_type (val
);
7907 type2
= ada_check_typedef (type2
);
7908 type
= ada_check_typedef (type
);
7910 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
7911 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7913 val
= ada_value_ind (val
);
7914 type2
= value_type (val
);
7917 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
7918 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7920 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
7921 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
7922 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
7923 error (_("Incompatible types in assignment"));
7924 deprecated_set_value_type (val
, type
);
7929 static struct value
*
7930 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
7933 struct type
*type1
, *type2
;
7936 arg1
= coerce_ref (arg1
);
7937 arg2
= coerce_ref (arg2
);
7938 type1
= base_type (ada_check_typedef (value_type (arg1
)));
7939 type2
= base_type (ada_check_typedef (value_type (arg2
)));
7941 if (TYPE_CODE (type1
) != TYPE_CODE_INT
7942 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
7943 return value_binop (arg1
, arg2
, op
);
7952 return value_binop (arg1
, arg2
, op
);
7955 v2
= value_as_long (arg2
);
7957 error (_("second operand of %s must not be zero."), op_string (op
));
7959 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7960 return value_binop (arg1
, arg2
, op
);
7962 v1
= value_as_long (arg1
);
7967 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7968 v
+= v
> 0 ? -1 : 1;
7976 /* Should not reach this point. */
7980 val
= allocate_value (type1
);
7981 store_unsigned_integer (value_contents_raw (val
),
7982 TYPE_LENGTH (value_type (val
)), v
);
7987 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7989 if (ada_is_direct_array_type (value_type (arg1
))
7990 || ada_is_direct_array_type (value_type (arg2
)))
7992 /* Automatically dereference any array reference before
7993 we attempt to perform the comparison. */
7994 arg1
= ada_coerce_ref (arg1
);
7995 arg2
= ada_coerce_ref (arg2
);
7997 arg1
= ada_coerce_to_simple_array (arg1
);
7998 arg2
= ada_coerce_to_simple_array (arg2
);
7999 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
8000 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
8001 error (_("Attempt to compare array with non-array"));
8002 /* FIXME: The following works only for types whose
8003 representations use all bits (no padding or undefined bits)
8004 and do not have user-defined equality. */
8006 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
8007 && memcmp (value_contents (arg1
), value_contents (arg2
),
8008 TYPE_LENGTH (value_type (arg1
))) == 0;
8010 return value_equal (arg1
, arg2
);
8013 /* Total number of component associations in the aggregate starting at
8014 index PC in EXP. Assumes that index PC is the start of an
8018 num_component_specs (struct expression
*exp
, int pc
)
8021 m
= exp
->elts
[pc
+ 1].longconst
;
8024 for (i
= 0; i
< m
; i
+= 1)
8026 switch (exp
->elts
[pc
].opcode
)
8032 n
+= exp
->elts
[pc
+ 1].longconst
;
8035 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
8040 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
8041 component of LHS (a simple array or a record), updating *POS past
8042 the expression, assuming that LHS is contained in CONTAINER. Does
8043 not modify the inferior's memory, nor does it modify LHS (unless
8044 LHS == CONTAINER). */
8047 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
8048 struct expression
*exp
, int *pos
)
8050 struct value
*mark
= value_mark ();
8052 if (TYPE_CODE (value_type (lhs
)) == TYPE_CODE_ARRAY
)
8054 struct value
*index_val
= value_from_longest (builtin_type_int32
, index
);
8055 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
8059 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
8060 elt
= ada_to_fixed_value (unwrap_value (elt
));
8063 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8064 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
8066 value_assign_to_component (container
, elt
,
8067 ada_evaluate_subexp (NULL
, exp
, pos
,
8070 value_free_to_mark (mark
);
8073 /* Assuming that LHS represents an lvalue having a record or array
8074 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8075 of that aggregate's value to LHS, advancing *POS past the
8076 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8077 lvalue containing LHS (possibly LHS itself). Does not modify
8078 the inferior's memory, nor does it modify the contents of
8079 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
8081 static struct value
*
8082 assign_aggregate (struct value
*container
,
8083 struct value
*lhs
, struct expression
*exp
,
8084 int *pos
, enum noside noside
)
8086 struct type
*lhs_type
;
8087 int n
= exp
->elts
[*pos
+1].longconst
;
8088 LONGEST low_index
, high_index
;
8091 int max_indices
, num_indices
;
8092 int is_array_aggregate
;
8094 struct value
*mark
= value_mark ();
8097 if (noside
!= EVAL_NORMAL
)
8100 for (i
= 0; i
< n
; i
+= 1)
8101 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
8105 container
= ada_coerce_ref (container
);
8106 if (ada_is_direct_array_type (value_type (container
)))
8107 container
= ada_coerce_to_simple_array (container
);
8108 lhs
= ada_coerce_ref (lhs
);
8109 if (!deprecated_value_modifiable (lhs
))
8110 error (_("Left operand of assignment is not a modifiable lvalue."));
8112 lhs_type
= value_type (lhs
);
8113 if (ada_is_direct_array_type (lhs_type
))
8115 lhs
= ada_coerce_to_simple_array (lhs
);
8116 lhs_type
= value_type (lhs
);
8117 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
8118 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
8119 is_array_aggregate
= 1;
8121 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
8124 high_index
= num_visible_fields (lhs_type
) - 1;
8125 is_array_aggregate
= 0;
8128 error (_("Left-hand side must be array or record."));
8130 num_specs
= num_component_specs (exp
, *pos
- 3);
8131 max_indices
= 4 * num_specs
+ 4;
8132 indices
= alloca (max_indices
* sizeof (indices
[0]));
8133 indices
[0] = indices
[1] = low_index
- 1;
8134 indices
[2] = indices
[3] = high_index
+ 1;
8137 for (i
= 0; i
< n
; i
+= 1)
8139 switch (exp
->elts
[*pos
].opcode
)
8142 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
8143 &num_indices
, max_indices
,
8144 low_index
, high_index
);
8147 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
8148 &num_indices
, max_indices
,
8149 low_index
, high_index
);
8153 error (_("Misplaced 'others' clause"));
8154 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
8155 num_indices
, low_index
, high_index
);
8158 error (_("Internal error: bad aggregate clause"));
8165 /* Assign into the component of LHS indexed by the OP_POSITIONAL
8166 construct at *POS, updating *POS past the construct, given that
8167 the positions are relative to lower bound LOW, where HIGH is the
8168 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8169 updating *NUM_INDICES as needed. CONTAINER is as for
8170 assign_aggregate. */
8172 aggregate_assign_positional (struct value
*container
,
8173 struct value
*lhs
, struct expression
*exp
,
8174 int *pos
, LONGEST
*indices
, int *num_indices
,
8175 int max_indices
, LONGEST low
, LONGEST high
)
8177 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
8179 if (ind
- 1 == high
)
8180 warning (_("Extra components in aggregate ignored."));
8183 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
8185 assign_component (container
, lhs
, ind
, exp
, pos
);
8188 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8191 /* Assign into the components of LHS indexed by the OP_CHOICES
8192 construct at *POS, updating *POS past the construct, given that
8193 the allowable indices are LOW..HIGH. Record the indices assigned
8194 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8195 needed. CONTAINER is as for assign_aggregate. */
8197 aggregate_assign_from_choices (struct value
*container
,
8198 struct value
*lhs
, struct expression
*exp
,
8199 int *pos
, LONGEST
*indices
, int *num_indices
,
8200 int max_indices
, LONGEST low
, LONGEST high
)
8203 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
8204 int choice_pos
, expr_pc
;
8205 int is_array
= ada_is_direct_array_type (value_type (lhs
));
8207 choice_pos
= *pos
+= 3;
8209 for (j
= 0; j
< n_choices
; j
+= 1)
8210 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8212 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8214 for (j
= 0; j
< n_choices
; j
+= 1)
8216 LONGEST lower
, upper
;
8217 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
8218 if (op
== OP_DISCRETE_RANGE
)
8221 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8223 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8228 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
8239 name
= &exp
->elts
[choice_pos
+ 2].string
;
8242 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
8245 error (_("Invalid record component association."));
8247 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
8249 if (! find_struct_field (name
, value_type (lhs
), 0,
8250 NULL
, NULL
, NULL
, NULL
, &ind
))
8251 error (_("Unknown component name: %s."), name
);
8252 lower
= upper
= ind
;
8255 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
8256 error (_("Index in component association out of bounds."));
8258 add_component_interval (lower
, upper
, indices
, num_indices
,
8260 while (lower
<= upper
)
8264 assign_component (container
, lhs
, lower
, exp
, &pos1
);
8270 /* Assign the value of the expression in the OP_OTHERS construct in
8271 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8272 have not been previously assigned. The index intervals already assigned
8273 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8274 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
8276 aggregate_assign_others (struct value
*container
,
8277 struct value
*lhs
, struct expression
*exp
,
8278 int *pos
, LONGEST
*indices
, int num_indices
,
8279 LONGEST low
, LONGEST high
)
8282 int expr_pc
= *pos
+1;
8284 for (i
= 0; i
< num_indices
- 2; i
+= 2)
8287 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
8291 assign_component (container
, lhs
, ind
, exp
, &pos
);
8294 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8297 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
8298 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8299 modifying *SIZE as needed. It is an error if *SIZE exceeds
8300 MAX_SIZE. The resulting intervals do not overlap. */
8302 add_component_interval (LONGEST low
, LONGEST high
,
8303 LONGEST
* indices
, int *size
, int max_size
)
8306 for (i
= 0; i
< *size
; i
+= 2) {
8307 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
8310 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
8311 if (high
< indices
[kh
])
8313 if (low
< indices
[i
])
8315 indices
[i
+ 1] = indices
[kh
- 1];
8316 if (high
> indices
[i
+ 1])
8317 indices
[i
+ 1] = high
;
8318 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
8319 *size
-= kh
- i
- 2;
8322 else if (high
< indices
[i
])
8326 if (*size
== max_size
)
8327 error (_("Internal error: miscounted aggregate components."));
8329 for (j
= *size
-1; j
>= i
+2; j
-= 1)
8330 indices
[j
] = indices
[j
- 2];
8332 indices
[i
+ 1] = high
;
8335 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8338 static struct value
*
8339 ada_value_cast (struct type
*type
, struct value
*arg2
, enum noside noside
)
8341 if (type
== ada_check_typedef (value_type (arg2
)))
8344 if (ada_is_fixed_point_type (type
))
8345 return (cast_to_fixed (type
, arg2
));
8347 if (ada_is_fixed_point_type (value_type (arg2
)))
8348 return cast_from_fixed (type
, arg2
);
8350 return value_cast (type
, arg2
);
8353 static struct value
*
8354 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
8355 int *pos
, enum noside noside
)
8358 int tem
, tem2
, tem3
;
8360 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
8363 struct value
**argvec
;
8367 op
= exp
->elts
[pc
].opcode
;
8373 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8374 arg1
= unwrap_value (arg1
);
8376 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8377 then we need to perform the conversion manually, because
8378 evaluate_subexp_standard doesn't do it. This conversion is
8379 necessary in Ada because the different kinds of float/fixed
8380 types in Ada have different representations.
8382 Similarly, we need to perform the conversion from OP_LONG
8384 if ((op
== OP_DOUBLE
|| op
== OP_LONG
) && expect_type
!= NULL
)
8385 arg1
= ada_value_cast (expect_type
, arg1
, noside
);
8391 struct value
*result
;
8393 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8394 /* The result type will have code OP_STRING, bashed there from
8395 OP_ARRAY. Bash it back. */
8396 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
8397 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
8403 type
= exp
->elts
[pc
+ 1].type
;
8404 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
8405 if (noside
== EVAL_SKIP
)
8407 arg1
= ada_value_cast (type
, arg1
, noside
);
8412 type
= exp
->elts
[pc
+ 1].type
;
8413 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
8416 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8417 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8419 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
8420 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8422 return ada_value_assign (arg1
, arg1
);
8424 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8425 except if the lhs of our assignment is a convenience variable.
8426 In the case of assigning to a convenience variable, the lhs
8427 should be exactly the result of the evaluation of the rhs. */
8428 type
= value_type (arg1
);
8429 if (VALUE_LVAL (arg1
) == lval_internalvar
)
8431 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
8432 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8434 if (ada_is_fixed_point_type (value_type (arg1
)))
8435 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
8436 else if (ada_is_fixed_point_type (value_type (arg2
)))
8438 (_("Fixed-point values must be assigned to fixed-point variables"));
8440 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
8441 return ada_value_assign (arg1
, arg2
);
8444 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8445 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8446 if (noside
== EVAL_SKIP
)
8448 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8449 return (value_from_longest
8451 value_as_long (arg1
) + value_as_long (arg2
)));
8452 if ((ada_is_fixed_point_type (value_type (arg1
))
8453 || ada_is_fixed_point_type (value_type (arg2
)))
8454 && value_type (arg1
) != value_type (arg2
))
8455 error (_("Operands of fixed-point addition must have the same type"));
8456 /* Do the addition, and cast the result to the type of the first
8457 argument. We cannot cast the result to a reference type, so if
8458 ARG1 is a reference type, find its underlying type. */
8459 type
= value_type (arg1
);
8460 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8461 type
= TYPE_TARGET_TYPE (type
);
8462 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8463 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
8466 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8467 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8468 if (noside
== EVAL_SKIP
)
8470 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8471 return (value_from_longest
8473 value_as_long (arg1
) - value_as_long (arg2
)));
8474 if ((ada_is_fixed_point_type (value_type (arg1
))
8475 || ada_is_fixed_point_type (value_type (arg2
)))
8476 && value_type (arg1
) != value_type (arg2
))
8477 error (_("Operands of fixed-point subtraction must have the same type"));
8478 /* Do the substraction, and cast the result to the type of the first
8479 argument. We cannot cast the result to a reference type, so if
8480 ARG1 is a reference type, find its underlying type. */
8481 type
= value_type (arg1
);
8482 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8483 type
= TYPE_TARGET_TYPE (type
);
8484 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8485 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
8489 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8490 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8491 if (noside
== EVAL_SKIP
)
8493 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8494 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8495 return value_zero (value_type (arg1
), not_lval
);
8498 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
8499 if (ada_is_fixed_point_type (value_type (arg1
)))
8500 arg1
= cast_from_fixed (type
, arg1
);
8501 if (ada_is_fixed_point_type (value_type (arg2
)))
8502 arg2
= cast_from_fixed (type
, arg2
);
8503 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8504 return ada_value_binop (arg1
, arg2
, op
);
8509 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8510 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8511 if (noside
== EVAL_SKIP
)
8513 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8514 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8515 return value_zero (value_type (arg1
), not_lval
);
8518 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8519 return ada_value_binop (arg1
, arg2
, op
);
8523 case BINOP_NOTEQUAL
:
8524 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8525 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
8526 if (noside
== EVAL_SKIP
)
8528 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8532 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8533 tem
= ada_value_equal (arg1
, arg2
);
8535 if (op
== BINOP_NOTEQUAL
)
8537 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8538 return value_from_longest (type
, (LONGEST
) tem
);
8541 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8542 if (noside
== EVAL_SKIP
)
8544 else if (ada_is_fixed_point_type (value_type (arg1
)))
8545 return value_cast (value_type (arg1
), value_neg (arg1
));
8548 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
8549 return value_neg (arg1
);
8552 case BINOP_LOGICAL_AND
:
8553 case BINOP_LOGICAL_OR
:
8554 case UNOP_LOGICAL_NOT
:
8559 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8560 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8561 return value_cast (type
, val
);
8564 case BINOP_BITWISE_AND
:
8565 case BINOP_BITWISE_IOR
:
8566 case BINOP_BITWISE_XOR
:
8570 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8572 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8574 return value_cast (value_type (arg1
), val
);
8580 if (noside
== EVAL_SKIP
)
8585 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
8586 /* Only encountered when an unresolved symbol occurs in a
8587 context other than a function call, in which case, it is
8589 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8590 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
8591 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8593 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
8594 if (ada_is_tagged_type (type
, 0))
8596 /* Tagged types are a little special in the fact that the real
8597 type is dynamic and can only be determined by inspecting the
8598 object's tag. This means that we need to get the object's
8599 value first (EVAL_NORMAL) and then extract the actual object
8602 Note that we cannot skip the final step where we extract
8603 the object type from its tag, because the EVAL_NORMAL phase
8604 results in dynamic components being resolved into fixed ones.
8605 This can cause problems when trying to print the type
8606 description of tagged types whose parent has a dynamic size:
8607 We use the type name of the "_parent" component in order
8608 to print the name of the ancestor type in the type description.
8609 If that component had a dynamic size, the resolution into
8610 a fixed type would result in the loss of that type name,
8611 thus preventing us from printing the name of the ancestor
8612 type in the type description. */
8613 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
8614 return value_zero (type_from_tag (ada_value_tag (arg1
)), not_lval
);
8619 (to_static_fixed_type
8620 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
8626 unwrap_value (evaluate_subexp_standard
8627 (expect_type
, exp
, pos
, noside
));
8628 return ada_to_fixed_value (arg1
);
8634 /* Allocate arg vector, including space for the function to be
8635 called in argvec[0] and a terminating NULL. */
8636 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8638 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
8640 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
8641 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
8642 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8643 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
8646 for (tem
= 0; tem
<= nargs
; tem
+= 1)
8647 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8650 if (noside
== EVAL_SKIP
)
8654 if (ada_is_packed_array_type (desc_base_type (value_type (argvec
[0]))))
8655 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
8656 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
8657 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
8658 && VALUE_LVAL (argvec
[0]) == lval_memory
))
8659 argvec
[0] = value_addr (argvec
[0]);
8661 type
= ada_check_typedef (value_type (argvec
[0]));
8662 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
8664 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
8666 case TYPE_CODE_FUNC
:
8667 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8669 case TYPE_CODE_ARRAY
:
8671 case TYPE_CODE_STRUCT
:
8672 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
8673 argvec
[0] = ada_value_ind (argvec
[0]);
8674 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8677 error (_("cannot subscript or call something of type `%s'"),
8678 ada_type_name (value_type (argvec
[0])));
8683 switch (TYPE_CODE (type
))
8685 case TYPE_CODE_FUNC
:
8686 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8687 return allocate_value (TYPE_TARGET_TYPE (type
));
8688 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
8689 case TYPE_CODE_STRUCT
:
8693 arity
= ada_array_arity (type
);
8694 type
= ada_array_element_type (type
, nargs
);
8696 error (_("cannot subscript or call a record"));
8698 error (_("wrong number of subscripts; expecting %d"), arity
);
8699 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8700 return value_zero (ada_aligned_type (type
), lval_memory
);
8702 unwrap_value (ada_value_subscript
8703 (argvec
[0], nargs
, argvec
+ 1));
8705 case TYPE_CODE_ARRAY
:
8706 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8708 type
= ada_array_element_type (type
, nargs
);
8710 error (_("element type of array unknown"));
8712 return value_zero (ada_aligned_type (type
), lval_memory
);
8715 unwrap_value (ada_value_subscript
8716 (ada_coerce_to_simple_array (argvec
[0]),
8717 nargs
, argvec
+ 1));
8718 case TYPE_CODE_PTR
: /* Pointer to array */
8719 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
8720 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8722 type
= ada_array_element_type (type
, nargs
);
8724 error (_("element type of array unknown"));
8726 return value_zero (ada_aligned_type (type
), lval_memory
);
8729 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
8730 nargs
, argvec
+ 1));
8733 error (_("Attempt to index or call something other than an "
8734 "array or function"));
8739 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8740 struct value
*low_bound_val
=
8741 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8742 struct value
*high_bound_val
=
8743 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8746 low_bound_val
= coerce_ref (low_bound_val
);
8747 high_bound_val
= coerce_ref (high_bound_val
);
8748 low_bound
= pos_atr (low_bound_val
);
8749 high_bound
= pos_atr (high_bound_val
);
8751 if (noside
== EVAL_SKIP
)
8754 /* If this is a reference to an aligner type, then remove all
8756 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8757 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
8758 TYPE_TARGET_TYPE (value_type (array
)) =
8759 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
8761 if (ada_is_packed_array_type (value_type (array
)))
8762 error (_("cannot slice a packed array"));
8764 /* If this is a reference to an array or an array lvalue,
8765 convert to a pointer. */
8766 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8767 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
8768 && VALUE_LVAL (array
) == lval_memory
))
8769 array
= value_addr (array
);
8771 if (noside
== EVAL_AVOID_SIDE_EFFECTS
8772 && ada_is_array_descriptor_type (ada_check_typedef
8773 (value_type (array
))))
8774 return empty_array (ada_type_of_array (array
, 0), low_bound
);
8776 array
= ada_coerce_to_simple_array_ptr (array
);
8778 /* If we have more than one level of pointer indirection,
8779 dereference the value until we get only one level. */
8780 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
8781 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
8783 array
= value_ind (array
);
8785 /* Make sure we really do have an array type before going further,
8786 to avoid a SEGV when trying to get the index type or the target
8787 type later down the road if the debug info generated by
8788 the compiler is incorrect or incomplete. */
8789 if (!ada_is_simple_array_type (value_type (array
)))
8790 error (_("cannot take slice of non-array"));
8792 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
8794 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8795 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
8799 struct type
*arr_type0
=
8800 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
8802 return ada_value_slice_from_ptr (array
, arr_type0
,
8803 longest_to_int (low_bound
),
8804 longest_to_int (high_bound
));
8807 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8809 else if (high_bound
< low_bound
)
8810 return empty_array (value_type (array
), low_bound
);
8812 return ada_value_slice (array
, longest_to_int (low_bound
),
8813 longest_to_int (high_bound
));
8818 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8819 type
= exp
->elts
[pc
+ 1].type
;
8821 if (noside
== EVAL_SKIP
)
8824 switch (TYPE_CODE (type
))
8827 lim_warning (_("Membership test incompletely implemented; "
8828 "always returns true"));
8829 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8830 return value_from_longest (type
, (LONGEST
) 1);
8832 case TYPE_CODE_RANGE
:
8833 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
8834 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
8835 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8836 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8837 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8839 value_from_longest (type
,
8840 (value_less (arg1
, arg3
)
8841 || value_equal (arg1
, arg3
))
8842 && (value_less (arg2
, arg1
)
8843 || value_equal (arg2
, arg1
)));
8846 case BINOP_IN_BOUNDS
:
8848 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8849 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8851 if (noside
== EVAL_SKIP
)
8854 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8856 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8857 return value_zero (type
, not_lval
);
8860 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8862 if (tem
< 1 || tem
> ada_array_arity (value_type (arg2
)))
8863 error (_("invalid dimension number to 'range"));
8865 arg3
= ada_array_bound (arg2
, tem
, 1);
8866 arg2
= ada_array_bound (arg2
, tem
, 0);
8868 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8869 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8870 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8872 value_from_longest (type
,
8873 (value_less (arg1
, arg3
)
8874 || value_equal (arg1
, arg3
))
8875 && (value_less (arg2
, arg1
)
8876 || value_equal (arg2
, arg1
)));
8878 case TERNOP_IN_RANGE
:
8879 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8880 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8881 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8883 if (noside
== EVAL_SKIP
)
8886 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8887 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8888 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8890 value_from_longest (type
,
8891 (value_less (arg1
, arg3
)
8892 || value_equal (arg1
, arg3
))
8893 && (value_less (arg2
, arg1
)
8894 || value_equal (arg2
, arg1
)));
8900 struct type
*type_arg
;
8901 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8903 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8905 type_arg
= exp
->elts
[pc
+ 2].type
;
8909 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8913 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
8914 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
8915 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
8918 if (noside
== EVAL_SKIP
)
8921 if (type_arg
== NULL
)
8923 arg1
= ada_coerce_ref (arg1
);
8925 if (ada_is_packed_array_type (value_type (arg1
)))
8926 arg1
= ada_coerce_to_simple_array (arg1
);
8928 if (tem
< 1 || tem
> ada_array_arity (value_type (arg1
)))
8929 error (_("invalid dimension number to '%s"),
8930 ada_attribute_name (op
));
8932 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8934 type
= ada_index_type (value_type (arg1
), tem
);
8937 (_("attempt to take bound of something that is not an array"));
8938 return allocate_value (type
);
8943 default: /* Should never happen. */
8944 error (_("unexpected attribute encountered"));
8946 return ada_array_bound (arg1
, tem
, 0);
8948 return ada_array_bound (arg1
, tem
, 1);
8950 return ada_array_length (arg1
, tem
);
8953 else if (discrete_type_p (type_arg
))
8955 struct type
*range_type
;
8956 char *name
= ada_type_name (type_arg
);
8958 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
8960 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
8961 if (range_type
== NULL
)
8962 range_type
= type_arg
;
8966 error (_("unexpected attribute encountered"));
8968 return value_from_longest
8969 (range_type
, discrete_type_low_bound (range_type
));
8971 return value_from_longest
8972 (range_type
, discrete_type_high_bound (range_type
));
8974 error (_("the 'length attribute applies only to array types"));
8977 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
8978 error (_("unimplemented type attribute"));
8983 if (ada_is_packed_array_type (type_arg
))
8984 type_arg
= decode_packed_array_type (type_arg
);
8986 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
8987 error (_("invalid dimension number to '%s"),
8988 ada_attribute_name (op
));
8990 type
= ada_index_type (type_arg
, tem
);
8993 (_("attempt to take bound of something that is not an array"));
8994 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8995 return allocate_value (type
);
9000 error (_("unexpected attribute encountered"));
9002 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9003 return value_from_longest (type
, low
);
9005 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
9006 return value_from_longest (type
, high
);
9008 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9009 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
9010 return value_from_longest (type
, high
- low
+ 1);
9016 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9017 if (noside
== EVAL_SKIP
)
9020 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9021 return value_zero (ada_tag_type (arg1
), not_lval
);
9023 return ada_value_tag (arg1
);
9027 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9028 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9029 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9030 if (noside
== EVAL_SKIP
)
9032 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9033 return value_zero (value_type (arg1
), not_lval
);
9036 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9037 return value_binop (arg1
, arg2
,
9038 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
9041 case OP_ATR_MODULUS
:
9043 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
9044 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9046 if (noside
== EVAL_SKIP
)
9049 if (!ada_is_modular_type (type_arg
))
9050 error (_("'modulus must be applied to modular type"));
9052 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
9053 ada_modulus (type_arg
));
9058 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9059 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9060 if (noside
== EVAL_SKIP
)
9062 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9063 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9064 return value_zero (type
, not_lval
);
9066 return value_pos_atr (type
, arg1
);
9069 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9070 type
= value_type (arg1
);
9072 /* If the argument is a reference, then dereference its type, since
9073 the user is really asking for the size of the actual object,
9074 not the size of the pointer. */
9075 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
9076 type
= TYPE_TARGET_TYPE (type
);
9078 if (noside
== EVAL_SKIP
)
9080 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9081 return value_zero (builtin_type_int32
, not_lval
);
9083 return value_from_longest (builtin_type_int32
,
9084 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
9087 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9088 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9089 type
= exp
->elts
[pc
+ 2].type
;
9090 if (noside
== EVAL_SKIP
)
9092 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9093 return value_zero (type
, not_lval
);
9095 return value_val_atr (type
, arg1
);
9098 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9099 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9100 if (noside
== EVAL_SKIP
)
9102 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9103 return value_zero (value_type (arg1
), not_lval
);
9106 /* For integer exponentiation operations,
9107 only promote the first argument. */
9108 if (is_integral_type (value_type (arg2
)))
9109 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9111 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9113 return value_binop (arg1
, arg2
, op
);
9117 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9118 if (noside
== EVAL_SKIP
)
9124 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9125 if (noside
== EVAL_SKIP
)
9127 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9128 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
9129 return value_neg (arg1
);
9134 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9135 if (noside
== EVAL_SKIP
)
9137 type
= ada_check_typedef (value_type (arg1
));
9138 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9140 if (ada_is_array_descriptor_type (type
))
9141 /* GDB allows dereferencing GNAT array descriptors. */
9143 struct type
*arrType
= ada_type_of_array (arg1
, 0);
9144 if (arrType
== NULL
)
9145 error (_("Attempt to dereference null array pointer."));
9146 return value_at_lazy (arrType
, 0);
9148 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
9149 || TYPE_CODE (type
) == TYPE_CODE_REF
9150 /* In C you can dereference an array to get the 1st elt. */
9151 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9153 type
= to_static_fixed_type
9155 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
9157 return value_zero (type
, lval_memory
);
9159 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9161 /* GDB allows dereferencing an int. */
9162 if (expect_type
== NULL
)
9163 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
9168 to_static_fixed_type (ada_aligned_type (expect_type
));
9169 return value_zero (expect_type
, lval_memory
);
9173 error (_("Attempt to take contents of a non-pointer value."));
9175 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
9176 type
= ada_check_typedef (value_type (arg1
));
9178 if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9179 /* GDB allows dereferencing an int. If we were given
9180 the expect_type, then use that as the target type.
9181 Otherwise, assume that the target type is an int. */
9183 if (expect_type
!= NULL
)
9184 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
9187 return value_at_lazy (builtin_type (exp
->gdbarch
)->builtin_int
,
9188 (CORE_ADDR
) value_as_address (arg1
));
9191 if (ada_is_array_descriptor_type (type
))
9192 /* GDB allows dereferencing GNAT array descriptors. */
9193 return ada_coerce_to_simple_array (arg1
);
9195 return ada_value_ind (arg1
);
9197 case STRUCTOP_STRUCT
:
9198 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9199 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
9200 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9201 if (noside
== EVAL_SKIP
)
9203 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9205 struct type
*type1
= value_type (arg1
);
9206 if (ada_is_tagged_type (type1
, 1))
9208 type
= ada_lookup_struct_elt_type (type1
,
9209 &exp
->elts
[pc
+ 2].string
,
9212 /* In this case, we assume that the field COULD exist
9213 in some extension of the type. Return an object of
9214 "type" void, which will match any formal
9215 (see ada_type_match). */
9216 return value_zero (builtin_type_void
, lval_memory
);
9220 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
9223 return value_zero (ada_aligned_type (type
), lval_memory
);
9227 ada_to_fixed_value (unwrap_value
9228 (ada_value_struct_elt
9229 (arg1
, &exp
->elts
[pc
+ 2].string
, 0)));
9231 /* The value is not supposed to be used. This is here to make it
9232 easier to accommodate expressions that contain types. */
9234 if (noside
== EVAL_SKIP
)
9236 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9237 return allocate_value (exp
->elts
[pc
+ 1].type
);
9239 error (_("Attempt to use a type name as an expression"));
9244 case OP_DISCRETE_RANGE
:
9247 if (noside
== EVAL_NORMAL
)
9251 error (_("Undefined name, ambiguous name, or renaming used in "
9252 "component association: %s."), &exp
->elts
[pc
+2].string
);
9254 error (_("Aggregates only allowed on the right of an assignment"));
9256 internal_error (__FILE__
, __LINE__
, _("aggregate apparently mangled"));
9259 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
9261 for (tem
= 0; tem
< nargs
; tem
+= 1)
9262 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9267 return value_from_longest (builtin_type_int8
, (LONGEST
) 1);
9273 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9274 type name that encodes the 'small and 'delta information.
9275 Otherwise, return NULL. */
9278 fixed_type_info (struct type
*type
)
9280 const char *name
= ada_type_name (type
);
9281 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
9283 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
9285 const char *tail
= strstr (name
, "___XF_");
9291 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
9292 return fixed_type_info (TYPE_TARGET_TYPE (type
));
9297 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9300 ada_is_fixed_point_type (struct type
*type
)
9302 return fixed_type_info (type
) != NULL
;
9305 /* Return non-zero iff TYPE represents a System.Address type. */
9308 ada_is_system_address_type (struct type
*type
)
9310 return (TYPE_NAME (type
)
9311 && strcmp (TYPE_NAME (type
), "system__address") == 0);
9314 /* Assuming that TYPE is the representation of an Ada fixed-point
9315 type, return its delta, or -1 if the type is malformed and the
9316 delta cannot be determined. */
9319 ada_delta (struct type
*type
)
9321 const char *encoding
= fixed_type_info (type
);
9324 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
9327 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
9330 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9331 factor ('SMALL value) associated with the type. */
9334 scaling_factor (struct type
*type
)
9336 const char *encoding
= fixed_type_info (type
);
9337 unsigned long num0
, den0
, num1
, den1
;
9340 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
9345 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
9347 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
9351 /* Assuming that X is the representation of a value of fixed-point
9352 type TYPE, return its floating-point equivalent. */
9355 ada_fixed_to_float (struct type
*type
, LONGEST x
)
9357 return (DOUBLEST
) x
*scaling_factor (type
);
9360 /* The representation of a fixed-point value of type TYPE
9361 corresponding to the value X. */
9364 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
9366 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
9370 /* VAX floating formats */
9372 /* Non-zero iff TYPE represents one of the special VAX floating-point
9376 ada_is_vax_floating_type (struct type
*type
)
9379 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
9382 && (TYPE_CODE (type
) == TYPE_CODE_INT
9383 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
9384 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
9387 /* The type of special VAX floating-point type this is, assuming
9388 ada_is_vax_floating_point. */
9391 ada_vax_float_type_suffix (struct type
*type
)
9393 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
9396 /* A value representing the special debugging function that outputs
9397 VAX floating-point values of the type represented by TYPE. Assumes
9398 ada_is_vax_floating_type (TYPE). */
9401 ada_vax_float_print_function (struct type
*type
)
9403 switch (ada_vax_float_type_suffix (type
))
9406 return get_var_value ("DEBUG_STRING_F", 0);
9408 return get_var_value ("DEBUG_STRING_D", 0);
9410 return get_var_value ("DEBUG_STRING_G", 0);
9412 error (_("invalid VAX floating-point type"));
9419 /* Scan STR beginning at position K for a discriminant name, and
9420 return the value of that discriminant field of DVAL in *PX. If
9421 PNEW_K is not null, put the position of the character beyond the
9422 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9423 not alter *PX and *PNEW_K if unsuccessful. */
9426 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
9429 static char *bound_buffer
= NULL
;
9430 static size_t bound_buffer_len
= 0;
9433 struct value
*bound_val
;
9435 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9438 pend
= strstr (str
+ k
, "__");
9442 k
+= strlen (bound
);
9446 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9447 bound
= bound_buffer
;
9448 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9449 bound
[pend
- (str
+ k
)] = '\0';
9453 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
9454 if (bound_val
== NULL
)
9457 *px
= value_as_long (bound_val
);
9463 /* Value of variable named NAME in the current environment. If
9464 no such variable found, then if ERR_MSG is null, returns 0, and
9465 otherwise causes an error with message ERR_MSG. */
9467 static struct value
*
9468 get_var_value (char *name
, char *err_msg
)
9470 struct ada_symbol_info
*syms
;
9473 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9478 if (err_msg
== NULL
)
9481 error (("%s"), err_msg
);
9484 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9487 /* Value of integer variable named NAME in the current environment. If
9488 no such variable found, returns 0, and sets *FLAG to 0. If
9489 successful, sets *FLAG to 1. */
9492 get_int_var_value (char *name
, int *flag
)
9494 struct value
*var_val
= get_var_value (name
, 0);
9506 return value_as_long (var_val
);
9511 /* Return a range type whose base type is that of the range type named
9512 NAME in the current environment, and whose bounds are calculated
9513 from NAME according to the GNAT range encoding conventions.
9514 Extract discriminant values, if needed, from DVAL. If a new type
9515 must be created, allocate in OBJFILE's space. The bounds
9516 information, in general, is encoded in NAME, the base type given in
9517 the named range type. */
9519 static struct type
*
9520 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
9522 struct type
*raw_type
= ada_find_any_type (name
);
9523 struct type
*base_type
;
9526 if (raw_type
== NULL
)
9527 base_type
= builtin_type_int32
;
9528 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9529 base_type
= TYPE_TARGET_TYPE (raw_type
);
9531 base_type
= raw_type
;
9533 subtype_info
= strstr (name
, "___XD");
9534 if (subtype_info
== NULL
)
9536 LONGEST L
= discrete_type_low_bound (raw_type
);
9537 LONGEST U
= discrete_type_high_bound (raw_type
);
9538 if (L
< INT_MIN
|| U
> INT_MAX
)
9541 return create_range_type (alloc_type (objfile
), raw_type
,
9542 discrete_type_low_bound (raw_type
),
9543 discrete_type_high_bound (raw_type
));
9547 static char *name_buf
= NULL
;
9548 static size_t name_len
= 0;
9549 int prefix_len
= subtype_info
- name
;
9555 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
9556 strncpy (name_buf
, name
, prefix_len
);
9557 name_buf
[prefix_len
] = '\0';
9560 bounds_str
= strchr (subtype_info
, '_');
9563 if (*subtype_info
== 'L')
9565 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
9566 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
9568 if (bounds_str
[n
] == '_')
9570 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
9577 strcpy (name_buf
+ prefix_len
, "___L");
9578 L
= get_int_var_value (name_buf
, &ok
);
9581 lim_warning (_("Unknown lower bound, using 1."));
9586 if (*subtype_info
== 'U')
9588 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
9589 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
9595 strcpy (name_buf
+ prefix_len
, "___U");
9596 U
= get_int_var_value (name_buf
, &ok
);
9599 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
9604 if (objfile
== NULL
)
9605 objfile
= TYPE_OBJFILE (base_type
);
9606 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
9607 TYPE_NAME (type
) = name
;
9612 /* True iff NAME is the name of a range type. */
9615 ada_is_range_type_name (const char *name
)
9617 return (name
!= NULL
&& strstr (name
, "___XD"));
9623 /* True iff TYPE is an Ada modular type. */
9626 ada_is_modular_type (struct type
*type
)
9628 struct type
*subranged_type
= base_type (type
);
9630 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
9631 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
9632 && TYPE_UNSIGNED (subranged_type
));
9635 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9638 ada_modulus (struct type
* type
)
9640 return (ULONGEST
) (unsigned int) TYPE_HIGH_BOUND (type
) + 1;
9644 /* Ada exception catchpoint support:
9645 ---------------------------------
9647 We support 3 kinds of exception catchpoints:
9648 . catchpoints on Ada exceptions
9649 . catchpoints on unhandled Ada exceptions
9650 . catchpoints on failed assertions
9652 Exceptions raised during failed assertions, or unhandled exceptions
9653 could perfectly be caught with the general catchpoint on Ada exceptions.
9654 However, we can easily differentiate these two special cases, and having
9655 the option to distinguish these two cases from the rest can be useful
9656 to zero-in on certain situations.
9658 Exception catchpoints are a specialized form of breakpoint,
9659 since they rely on inserting breakpoints inside known routines
9660 of the GNAT runtime. The implementation therefore uses a standard
9661 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9664 Support in the runtime for exception catchpoints have been changed
9665 a few times already, and these changes affect the implementation
9666 of these catchpoints. In order to be able to support several
9667 variants of the runtime, we use a sniffer that will determine
9668 the runtime variant used by the program being debugged.
9670 At this time, we do not support the use of conditions on Ada exception
9671 catchpoints. The COND and COND_STRING fields are therefore set
9672 to NULL (most of the time, see below).
9674 Conditions where EXP_STRING, COND, and COND_STRING are used:
9676 When a user specifies the name of a specific exception in the case
9677 of catchpoints on Ada exceptions, we store the name of that exception
9678 in the EXP_STRING. We then translate this request into an actual
9679 condition stored in COND_STRING, and then parse it into an expression
9682 /* The different types of catchpoints that we introduced for catching
9685 enum exception_catchpoint_kind
9688 ex_catch_exception_unhandled
,
9692 /* Ada's standard exceptions. */
9694 static char *standard_exc
[] = {
9701 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
9703 /* A structure that describes how to support exception catchpoints
9704 for a given executable. */
9706 struct exception_support_info
9708 /* The name of the symbol to break on in order to insert
9709 a catchpoint on exceptions. */
9710 const char *catch_exception_sym
;
9712 /* The name of the symbol to break on in order to insert
9713 a catchpoint on unhandled exceptions. */
9714 const char *catch_exception_unhandled_sym
;
9716 /* The name of the symbol to break on in order to insert
9717 a catchpoint on failed assertions. */
9718 const char *catch_assert_sym
;
9720 /* Assuming that the inferior just triggered an unhandled exception
9721 catchpoint, this function is responsible for returning the address
9722 in inferior memory where the name of that exception is stored.
9723 Return zero if the address could not be computed. */
9724 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
9727 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
9728 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
9730 /* The following exception support info structure describes how to
9731 implement exception catchpoints with the latest version of the
9732 Ada runtime (as of 2007-03-06). */
9734 static const struct exception_support_info default_exception_support_info
=
9736 "__gnat_debug_raise_exception", /* catch_exception_sym */
9737 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9738 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9739 ada_unhandled_exception_name_addr
9742 /* The following exception support info structure describes how to
9743 implement exception catchpoints with a slightly older version
9744 of the Ada runtime. */
9746 static const struct exception_support_info exception_support_info_fallback
=
9748 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9749 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9750 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9751 ada_unhandled_exception_name_addr_from_raise
9754 /* For each executable, we sniff which exception info structure to use
9755 and cache it in the following global variable. */
9757 static const struct exception_support_info
*exception_info
= NULL
;
9759 /* Inspect the Ada runtime and determine which exception info structure
9760 should be used to provide support for exception catchpoints.
9762 This function will always set exception_info, or raise an error. */
9765 ada_exception_support_info_sniffer (void)
9769 /* If the exception info is already known, then no need to recompute it. */
9770 if (exception_info
!= NULL
)
9773 /* Check the latest (default) exception support info. */
9774 sym
= standard_lookup (default_exception_support_info
.catch_exception_sym
,
9778 exception_info
= &default_exception_support_info
;
9782 /* Try our fallback exception suport info. */
9783 sym
= standard_lookup (exception_support_info_fallback
.catch_exception_sym
,
9787 exception_info
= &exception_support_info_fallback
;
9791 /* Sometimes, it is normal for us to not be able to find the routine
9792 we are looking for. This happens when the program is linked with
9793 the shared version of the GNAT runtime, and the program has not been
9794 started yet. Inform the user of these two possible causes if
9797 if (ada_update_initial_language (language_unknown
, NULL
) != language_ada
)
9798 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9800 /* If the symbol does not exist, then check that the program is
9801 already started, to make sure that shared libraries have been
9802 loaded. If it is not started, this may mean that the symbol is
9803 in a shared library. */
9805 if (ptid_get_pid (inferior_ptid
) == 0)
9806 error (_("Unable to insert catchpoint. Try to start the program first."));
9808 /* At this point, we know that we are debugging an Ada program and
9809 that the inferior has been started, but we still are not able to
9810 find the run-time symbols. That can mean that we are in
9811 configurable run time mode, or that a-except as been optimized
9812 out by the linker... In any case, at this point it is not worth
9813 supporting this feature. */
9815 error (_("Cannot insert catchpoints in this configuration."));
9818 /* An observer of "executable_changed" events.
9819 Its role is to clear certain cached values that need to be recomputed
9820 each time a new executable is loaded by GDB. */
9823 ada_executable_changed_observer (void)
9825 /* If the executable changed, then it is possible that the Ada runtime
9826 is different. So we need to invalidate the exception support info
9828 exception_info
= NULL
;
9831 /* Return the name of the function at PC, NULL if could not find it.
9832 This function only checks the debugging information, not the symbol
9836 function_name_from_pc (CORE_ADDR pc
)
9840 if (!find_pc_partial_function (pc
, &func_name
, NULL
, NULL
))
9846 /* True iff FRAME is very likely to be that of a function that is
9847 part of the runtime system. This is all very heuristic, but is
9848 intended to be used as advice as to what frames are uninteresting
9852 is_known_support_routine (struct frame_info
*frame
)
9854 struct symtab_and_line sal
;
9858 /* If this code does not have any debugging information (no symtab),
9859 This cannot be any user code. */
9861 find_frame_sal (frame
, &sal
);
9862 if (sal
.symtab
== NULL
)
9865 /* If there is a symtab, but the associated source file cannot be
9866 located, then assume this is not user code: Selecting a frame
9867 for which we cannot display the code would not be very helpful
9868 for the user. This should also take care of case such as VxWorks
9869 where the kernel has some debugging info provided for a few units. */
9871 if (symtab_to_fullname (sal
.symtab
) == NULL
)
9874 /* Check the unit filename againt the Ada runtime file naming.
9875 We also check the name of the objfile against the name of some
9876 known system libraries that sometimes come with debugging info
9879 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
9881 re_comp (known_runtime_file_name_patterns
[i
]);
9882 if (re_exec (sal
.symtab
->filename
))
9884 if (sal
.symtab
->objfile
!= NULL
9885 && re_exec (sal
.symtab
->objfile
->name
))
9889 /* Check whether the function is a GNAT-generated entity. */
9891 func_name
= function_name_from_pc (get_frame_address_in_block (frame
));
9892 if (func_name
== NULL
)
9895 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
9897 re_comp (known_auxiliary_function_name_patterns
[i
]);
9898 if (re_exec (func_name
))
9905 /* Find the first frame that contains debugging information and that is not
9906 part of the Ada run-time, starting from FI and moving upward. */
9909 ada_find_printable_frame (struct frame_info
*fi
)
9911 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
9913 if (!is_known_support_routine (fi
))
9922 /* Assuming that the inferior just triggered an unhandled exception
9923 catchpoint, return the address in inferior memory where the name
9924 of the exception is stored.
9926 Return zero if the address could not be computed. */
9929 ada_unhandled_exception_name_addr (void)
9931 return parse_and_eval_address ("e.full_name");
9934 /* Same as ada_unhandled_exception_name_addr, except that this function
9935 should be used when the inferior uses an older version of the runtime,
9936 where the exception name needs to be extracted from a specific frame
9937 several frames up in the callstack. */
9940 ada_unhandled_exception_name_addr_from_raise (void)
9943 struct frame_info
*fi
;
9945 /* To determine the name of this exception, we need to select
9946 the frame corresponding to RAISE_SYM_NAME. This frame is
9947 at least 3 levels up, so we simply skip the first 3 frames
9948 without checking the name of their associated function. */
9949 fi
= get_current_frame ();
9950 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
9952 fi
= get_prev_frame (fi
);
9956 const char *func_name
=
9957 function_name_from_pc (get_frame_address_in_block (fi
));
9958 if (func_name
!= NULL
9959 && strcmp (func_name
, exception_info
->catch_exception_sym
) == 0)
9960 break; /* We found the frame we were looking for... */
9961 fi
= get_prev_frame (fi
);
9968 return parse_and_eval_address ("id.full_name");
9971 /* Assuming the inferior just triggered an Ada exception catchpoint
9972 (of any type), return the address in inferior memory where the name
9973 of the exception is stored, if applicable.
9975 Return zero if the address could not be computed, or if not relevant. */
9978 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex
,
9979 struct breakpoint
*b
)
9983 case ex_catch_exception
:
9984 return (parse_and_eval_address ("e.full_name"));
9987 case ex_catch_exception_unhandled
:
9988 return exception_info
->unhandled_exception_name_addr ();
9991 case ex_catch_assert
:
9992 return 0; /* Exception name is not relevant in this case. */
9996 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10000 return 0; /* Should never be reached. */
10003 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
10004 any error that ada_exception_name_addr_1 might cause to be thrown.
10005 When an error is intercepted, a warning with the error message is printed,
10006 and zero is returned. */
10009 ada_exception_name_addr (enum exception_catchpoint_kind ex
,
10010 struct breakpoint
*b
)
10012 struct gdb_exception e
;
10013 CORE_ADDR result
= 0;
10015 TRY_CATCH (e
, RETURN_MASK_ERROR
)
10017 result
= ada_exception_name_addr_1 (ex
, b
);
10022 warning (_("failed to get exception name: %s"), e
.message
);
10029 /* Implement the PRINT_IT method in the breakpoint_ops structure
10030 for all exception catchpoint kinds. */
10032 static enum print_stop_action
10033 print_it_exception (enum exception_catchpoint_kind ex
, struct breakpoint
*b
)
10035 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
10036 char exception_name
[256];
10040 read_memory (addr
, exception_name
, sizeof (exception_name
) - 1);
10041 exception_name
[sizeof (exception_name
) - 1] = '\0';
10044 ada_find_printable_frame (get_current_frame ());
10046 annotate_catchpoint (b
->number
);
10049 case ex_catch_exception
:
10051 printf_filtered (_("\nCatchpoint %d, %s at "),
10052 b
->number
, exception_name
);
10054 printf_filtered (_("\nCatchpoint %d, exception at "), b
->number
);
10056 case ex_catch_exception_unhandled
:
10058 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10059 b
->number
, exception_name
);
10061 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10064 case ex_catch_assert
:
10065 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10070 return PRINT_SRC_AND_LOC
;
10073 /* Implement the PRINT_ONE method in the breakpoint_ops structure
10074 for all exception catchpoint kinds. */
10077 print_one_exception (enum exception_catchpoint_kind ex
,
10078 struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10080 struct value_print_options opts
;
10082 get_user_print_options (&opts
);
10083 if (opts
.addressprint
)
10085 annotate_field (4);
10086 ui_out_field_core_addr (uiout
, "addr", b
->loc
->address
);
10089 annotate_field (5);
10090 *last_addr
= b
->loc
->address
;
10093 case ex_catch_exception
:
10094 if (b
->exp_string
!= NULL
)
10096 char *msg
= xstrprintf (_("`%s' Ada exception"), b
->exp_string
);
10098 ui_out_field_string (uiout
, "what", msg
);
10102 ui_out_field_string (uiout
, "what", "all Ada exceptions");
10106 case ex_catch_exception_unhandled
:
10107 ui_out_field_string (uiout
, "what", "unhandled Ada exceptions");
10110 case ex_catch_assert
:
10111 ui_out_field_string (uiout
, "what", "failed Ada assertions");
10115 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10120 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
10121 for all exception catchpoint kinds. */
10124 print_mention_exception (enum exception_catchpoint_kind ex
,
10125 struct breakpoint
*b
)
10129 case ex_catch_exception
:
10130 if (b
->exp_string
!= NULL
)
10131 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10132 b
->number
, b
->exp_string
);
10134 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b
->number
);
10138 case ex_catch_exception_unhandled
:
10139 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10143 case ex_catch_assert
:
10144 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b
->number
);
10148 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10153 /* Virtual table for "catch exception" breakpoints. */
10155 static enum print_stop_action
10156 print_it_catch_exception (struct breakpoint
*b
)
10158 return print_it_exception (ex_catch_exception
, b
);
10162 print_one_catch_exception (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10164 print_one_exception (ex_catch_exception
, b
, last_addr
);
10168 print_mention_catch_exception (struct breakpoint
*b
)
10170 print_mention_exception (ex_catch_exception
, b
);
10173 static struct breakpoint_ops catch_exception_breakpoint_ops
=
10177 NULL
, /* breakpoint_hit */
10178 print_it_catch_exception
,
10179 print_one_catch_exception
,
10180 print_mention_catch_exception
10183 /* Virtual table for "catch exception unhandled" breakpoints. */
10185 static enum print_stop_action
10186 print_it_catch_exception_unhandled (struct breakpoint
*b
)
10188 return print_it_exception (ex_catch_exception_unhandled
, b
);
10192 print_one_catch_exception_unhandled (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10194 print_one_exception (ex_catch_exception_unhandled
, b
, last_addr
);
10198 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
10200 print_mention_exception (ex_catch_exception_unhandled
, b
);
10203 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
= {
10206 NULL
, /* breakpoint_hit */
10207 print_it_catch_exception_unhandled
,
10208 print_one_catch_exception_unhandled
,
10209 print_mention_catch_exception_unhandled
10212 /* Virtual table for "catch assert" breakpoints. */
10214 static enum print_stop_action
10215 print_it_catch_assert (struct breakpoint
*b
)
10217 return print_it_exception (ex_catch_assert
, b
);
10221 print_one_catch_assert (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10223 print_one_exception (ex_catch_assert
, b
, last_addr
);
10227 print_mention_catch_assert (struct breakpoint
*b
)
10229 print_mention_exception (ex_catch_assert
, b
);
10232 static struct breakpoint_ops catch_assert_breakpoint_ops
= {
10235 NULL
, /* breakpoint_hit */
10236 print_it_catch_assert
,
10237 print_one_catch_assert
,
10238 print_mention_catch_assert
10241 /* Return non-zero if B is an Ada exception catchpoint. */
10244 ada_exception_catchpoint_p (struct breakpoint
*b
)
10246 return (b
->ops
== &catch_exception_breakpoint_ops
10247 || b
->ops
== &catch_exception_unhandled_breakpoint_ops
10248 || b
->ops
== &catch_assert_breakpoint_ops
);
10251 /* Return a newly allocated copy of the first space-separated token
10252 in ARGSP, and then adjust ARGSP to point immediately after that
10255 Return NULL if ARGPS does not contain any more tokens. */
10258 ada_get_next_arg (char **argsp
)
10260 char *args
= *argsp
;
10264 /* Skip any leading white space. */
10266 while (isspace (*args
))
10269 if (args
[0] == '\0')
10270 return NULL
; /* No more arguments. */
10272 /* Find the end of the current argument. */
10275 while (*end
!= '\0' && !isspace (*end
))
10278 /* Adjust ARGSP to point to the start of the next argument. */
10282 /* Make a copy of the current argument and return it. */
10284 result
= xmalloc (end
- args
+ 1);
10285 strncpy (result
, args
, end
- args
);
10286 result
[end
- args
] = '\0';
10291 /* Split the arguments specified in a "catch exception" command.
10292 Set EX to the appropriate catchpoint type.
10293 Set EXP_STRING to the name of the specific exception if
10294 specified by the user. */
10297 catch_ada_exception_command_split (char *args
,
10298 enum exception_catchpoint_kind
*ex
,
10301 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
10302 char *exception_name
;
10304 exception_name
= ada_get_next_arg (&args
);
10305 make_cleanup (xfree
, exception_name
);
10307 /* Check that we do not have any more arguments. Anything else
10310 while (isspace (*args
))
10313 if (args
[0] != '\0')
10314 error (_("Junk at end of expression"));
10316 discard_cleanups (old_chain
);
10318 if (exception_name
== NULL
)
10320 /* Catch all exceptions. */
10321 *ex
= ex_catch_exception
;
10322 *exp_string
= NULL
;
10324 else if (strcmp (exception_name
, "unhandled") == 0)
10326 /* Catch unhandled exceptions. */
10327 *ex
= ex_catch_exception_unhandled
;
10328 *exp_string
= NULL
;
10332 /* Catch a specific exception. */
10333 *ex
= ex_catch_exception
;
10334 *exp_string
= exception_name
;
10338 /* Return the name of the symbol on which we should break in order to
10339 implement a catchpoint of the EX kind. */
10341 static const char *
10342 ada_exception_sym_name (enum exception_catchpoint_kind ex
)
10344 gdb_assert (exception_info
!= NULL
);
10348 case ex_catch_exception
:
10349 return (exception_info
->catch_exception_sym
);
10351 case ex_catch_exception_unhandled
:
10352 return (exception_info
->catch_exception_unhandled_sym
);
10354 case ex_catch_assert
:
10355 return (exception_info
->catch_assert_sym
);
10358 internal_error (__FILE__
, __LINE__
,
10359 _("unexpected catchpoint kind (%d)"), ex
);
10363 /* Return the breakpoint ops "virtual table" used for catchpoints
10366 static struct breakpoint_ops
*
10367 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex
)
10371 case ex_catch_exception
:
10372 return (&catch_exception_breakpoint_ops
);
10374 case ex_catch_exception_unhandled
:
10375 return (&catch_exception_unhandled_breakpoint_ops
);
10377 case ex_catch_assert
:
10378 return (&catch_assert_breakpoint_ops
);
10381 internal_error (__FILE__
, __LINE__
,
10382 _("unexpected catchpoint kind (%d)"), ex
);
10386 /* Return the condition that will be used to match the current exception
10387 being raised with the exception that the user wants to catch. This
10388 assumes that this condition is used when the inferior just triggered
10389 an exception catchpoint.
10391 The string returned is a newly allocated string that needs to be
10392 deallocated later. */
10395 ada_exception_catchpoint_cond_string (const char *exp_string
)
10399 /* The standard exceptions are a special case. They are defined in
10400 runtime units that have been compiled without debugging info; if
10401 EXP_STRING is the not-fully-qualified name of a standard
10402 exception (e.g. "constraint_error") then, during the evaluation
10403 of the condition expression, the symbol lookup on this name would
10404 *not* return this standard exception. The catchpoint condition
10405 may then be set only on user-defined exceptions which have the
10406 same not-fully-qualified name (e.g. my_package.constraint_error).
10408 To avoid this unexcepted behavior, these standard exceptions are
10409 systematically prefixed by "standard". This means that "catch
10410 exception constraint_error" is rewritten into "catch exception
10411 standard.constraint_error".
10413 If an exception named contraint_error is defined in another package of
10414 the inferior program, then the only way to specify this exception as a
10415 breakpoint condition is to use its fully-qualified named:
10416 e.g. my_package.constraint_error. */
10418 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
10420 if (strcmp (standard_exc
[i
], exp_string
) == 0)
10422 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
10426 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string
);
10429 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
10431 static struct expression
*
10432 ada_parse_catchpoint_condition (char *cond_string
,
10433 struct symtab_and_line sal
)
10435 return (parse_exp_1 (&cond_string
, block_for_pc (sal
.pc
), 0));
10438 /* Return the symtab_and_line that should be used to insert an exception
10439 catchpoint of the TYPE kind.
10441 EX_STRING should contain the name of a specific exception
10442 that the catchpoint should catch, or NULL otherwise.
10444 The idea behind all the remaining parameters is that their names match
10445 the name of certain fields in the breakpoint structure that are used to
10446 handle exception catchpoints. This function returns the value to which
10447 these fields should be set, depending on the type of catchpoint we need
10450 If COND and COND_STRING are both non-NULL, any value they might
10451 hold will be free'ed, and then replaced by newly allocated ones.
10452 These parameters are left untouched otherwise. */
10454 static struct symtab_and_line
10455 ada_exception_sal (enum exception_catchpoint_kind ex
, char *exp_string
,
10456 char **addr_string
, char **cond_string
,
10457 struct expression
**cond
, struct breakpoint_ops
**ops
)
10459 const char *sym_name
;
10460 struct symbol
*sym
;
10461 struct symtab_and_line sal
;
10463 /* First, find out which exception support info to use. */
10464 ada_exception_support_info_sniffer ();
10466 /* Then lookup the function on which we will break in order to catch
10467 the Ada exceptions requested by the user. */
10469 sym_name
= ada_exception_sym_name (ex
);
10470 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
10472 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10473 that should be compiled with debugging information. As a result, we
10474 expect to find that symbol in the symtabs. If we don't find it, then
10475 the target most likely does not support Ada exceptions, or we cannot
10476 insert exception breakpoints yet, because the GNAT runtime hasn't been
10479 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10480 in such a way that no debugging information is produced for the symbol
10481 we are looking for. In this case, we could search the minimal symbols
10482 as a fall-back mechanism. This would still be operating in degraded
10483 mode, however, as we would still be missing the debugging information
10484 that is needed in order to extract the name of the exception being
10485 raised (this name is printed in the catchpoint message, and is also
10486 used when trying to catch a specific exception). We do not handle
10487 this case for now. */
10490 error (_("Unable to break on '%s' in this configuration."), sym_name
);
10492 /* Make sure that the symbol we found corresponds to a function. */
10493 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
10494 error (_("Symbol \"%s\" is not a function (class = %d)"),
10495 sym_name
, SYMBOL_CLASS (sym
));
10497 sal
= find_function_start_sal (sym
, 1);
10499 /* Set ADDR_STRING. */
10501 *addr_string
= xstrdup (sym_name
);
10503 /* Set the COND and COND_STRING (if not NULL). */
10505 if (cond_string
!= NULL
&& cond
!= NULL
)
10507 if (*cond_string
!= NULL
)
10509 xfree (*cond_string
);
10510 *cond_string
= NULL
;
10517 if (exp_string
!= NULL
)
10519 *cond_string
= ada_exception_catchpoint_cond_string (exp_string
);
10520 *cond
= ada_parse_catchpoint_condition (*cond_string
, sal
);
10525 *ops
= ada_exception_breakpoint_ops (ex
);
10530 /* Parse the arguments (ARGS) of the "catch exception" command.
10532 Set TYPE to the appropriate exception catchpoint type.
10533 If the user asked the catchpoint to catch only a specific
10534 exception, then save the exception name in ADDR_STRING.
10536 See ada_exception_sal for a description of all the remaining
10537 function arguments of this function. */
10539 struct symtab_and_line
10540 ada_decode_exception_location (char *args
, char **addr_string
,
10541 char **exp_string
, char **cond_string
,
10542 struct expression
**cond
,
10543 struct breakpoint_ops
**ops
)
10545 enum exception_catchpoint_kind ex
;
10547 catch_ada_exception_command_split (args
, &ex
, exp_string
);
10548 return ada_exception_sal (ex
, *exp_string
, addr_string
, cond_string
,
10552 struct symtab_and_line
10553 ada_decode_assert_location (char *args
, char **addr_string
,
10554 struct breakpoint_ops
**ops
)
10556 /* Check that no argument where provided at the end of the command. */
10560 while (isspace (*args
))
10563 error (_("Junk at end of arguments."));
10566 return ada_exception_sal (ex_catch_assert
, NULL
, addr_string
, NULL
, NULL
,
10571 /* Information about operators given special treatment in functions
10573 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10575 #define ADA_OPERATORS \
10576 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10577 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10578 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10579 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10580 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10581 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10582 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10583 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10584 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10585 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10586 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10587 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10588 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10589 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10590 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
10591 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10592 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10593 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10594 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
10597 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
10599 switch (exp
->elts
[pc
- 1].opcode
)
10602 operator_length_standard (exp
, pc
, oplenp
, argsp
);
10605 #define OP_DEFN(op, len, args, binop) \
10606 case op: *oplenp = len; *argsp = args; break;
10612 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
10617 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
10623 ada_op_name (enum exp_opcode opcode
)
10628 return op_name_standard (opcode
);
10630 #define OP_DEFN(op, len, args, binop) case op: return #op;
10635 return "OP_AGGREGATE";
10637 return "OP_CHOICES";
10643 /* As for operator_length, but assumes PC is pointing at the first
10644 element of the operator, and gives meaningful results only for the
10645 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
10648 ada_forward_operator_length (struct expression
*exp
, int pc
,
10649 int *oplenp
, int *argsp
)
10651 switch (exp
->elts
[pc
].opcode
)
10654 *oplenp
= *argsp
= 0;
10657 #define OP_DEFN(op, len, args, binop) \
10658 case op: *oplenp = len; *argsp = args; break;
10664 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10669 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
10675 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10676 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
10684 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
10686 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
10691 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
10695 /* Ada attributes ('Foo). */
10698 case OP_ATR_LENGTH
:
10702 case OP_ATR_MODULUS
:
10709 case UNOP_IN_RANGE
:
10711 /* XXX: gdb_sprint_host_address, type_sprint */
10712 fprintf_filtered (stream
, _("Type @"));
10713 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
10714 fprintf_filtered (stream
, " (");
10715 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
10716 fprintf_filtered (stream
, ")");
10718 case BINOP_IN_BOUNDS
:
10719 fprintf_filtered (stream
, " (%d)",
10720 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
10722 case TERNOP_IN_RANGE
:
10727 case OP_DISCRETE_RANGE
:
10728 case OP_POSITIONAL
:
10735 char *name
= &exp
->elts
[elt
+ 2].string
;
10736 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
10737 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
10742 return dump_subexp_body_standard (exp
, stream
, elt
);
10746 for (i
= 0; i
< nargs
; i
+= 1)
10747 elt
= dump_subexp (exp
, stream
, elt
);
10752 /* The Ada extension of print_subexp (q.v.). */
10755 ada_print_subexp (struct expression
*exp
, int *pos
,
10756 struct ui_file
*stream
, enum precedence prec
)
10758 int oplen
, nargs
, i
;
10760 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
10762 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
10769 print_subexp_standard (exp
, pos
, stream
, prec
);
10773 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
10776 case BINOP_IN_BOUNDS
:
10777 /* XXX: sprint_subexp */
10778 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10779 fputs_filtered (" in ", stream
);
10780 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10781 fputs_filtered ("'range", stream
);
10782 if (exp
->elts
[pc
+ 1].longconst
> 1)
10783 fprintf_filtered (stream
, "(%ld)",
10784 (long) exp
->elts
[pc
+ 1].longconst
);
10787 case TERNOP_IN_RANGE
:
10788 if (prec
>= PREC_EQUAL
)
10789 fputs_filtered ("(", stream
);
10790 /* XXX: sprint_subexp */
10791 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10792 fputs_filtered (" in ", stream
);
10793 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10794 fputs_filtered (" .. ", stream
);
10795 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10796 if (prec
>= PREC_EQUAL
)
10797 fputs_filtered (")", stream
);
10802 case OP_ATR_LENGTH
:
10806 case OP_ATR_MODULUS
:
10811 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10813 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
10814 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
10818 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10819 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
10823 for (tem
= 1; tem
< nargs
; tem
+= 1)
10825 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
10826 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
10828 fputs_filtered (")", stream
);
10833 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
10834 fputs_filtered ("'(", stream
);
10835 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
10836 fputs_filtered (")", stream
);
10839 case UNOP_IN_RANGE
:
10840 /* XXX: sprint_subexp */
10841 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10842 fputs_filtered (" in ", stream
);
10843 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
10846 case OP_DISCRETE_RANGE
:
10847 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10848 fputs_filtered ("..", stream
);
10849 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10853 fputs_filtered ("others => ", stream
);
10854 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10858 for (i
= 0; i
< nargs
-1; i
+= 1)
10861 fputs_filtered ("|", stream
);
10862 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10864 fputs_filtered (" => ", stream
);
10865 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10868 case OP_POSITIONAL
:
10869 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10873 fputs_filtered ("(", stream
);
10874 for (i
= 0; i
< nargs
; i
+= 1)
10877 fputs_filtered (", ", stream
);
10878 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10880 fputs_filtered (")", stream
);
10885 /* Table mapping opcodes into strings for printing operators
10886 and precedences of the operators. */
10888 static const struct op_print ada_op_print_tab
[] = {
10889 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
10890 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
10891 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
10892 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
10893 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
10894 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
10895 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
10896 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
10897 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
10898 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
10899 {">", BINOP_GTR
, PREC_ORDER
, 0},
10900 {"<", BINOP_LESS
, PREC_ORDER
, 0},
10901 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
10902 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
10903 {"+", BINOP_ADD
, PREC_ADD
, 0},
10904 {"-", BINOP_SUB
, PREC_ADD
, 0},
10905 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
10906 {"*", BINOP_MUL
, PREC_MUL
, 0},
10907 {"/", BINOP_DIV
, PREC_MUL
, 0},
10908 {"rem", BINOP_REM
, PREC_MUL
, 0},
10909 {"mod", BINOP_MOD
, PREC_MUL
, 0},
10910 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
10911 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
10912 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
10913 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
10914 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
10915 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
10916 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
10917 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
10918 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
10919 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
10923 enum ada_primitive_types
{
10924 ada_primitive_type_int
,
10925 ada_primitive_type_long
,
10926 ada_primitive_type_short
,
10927 ada_primitive_type_char
,
10928 ada_primitive_type_float
,
10929 ada_primitive_type_double
,
10930 ada_primitive_type_void
,
10931 ada_primitive_type_long_long
,
10932 ada_primitive_type_long_double
,
10933 ada_primitive_type_natural
,
10934 ada_primitive_type_positive
,
10935 ada_primitive_type_system_address
,
10936 nr_ada_primitive_types
10940 ada_language_arch_info (struct gdbarch
*gdbarch
,
10941 struct language_arch_info
*lai
)
10943 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
10944 lai
->primitive_type_vector
10945 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
10947 lai
->primitive_type_vector
[ada_primitive_type_int
] =
10948 init_type (TYPE_CODE_INT
,
10949 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10950 0, "integer", (struct objfile
*) NULL
);
10951 lai
->primitive_type_vector
[ada_primitive_type_long
] =
10952 init_type (TYPE_CODE_INT
,
10953 gdbarch_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10954 0, "long_integer", (struct objfile
*) NULL
);
10955 lai
->primitive_type_vector
[ada_primitive_type_short
] =
10956 init_type (TYPE_CODE_INT
,
10957 gdbarch_short_bit (gdbarch
) / TARGET_CHAR_BIT
,
10958 0, "short_integer", (struct objfile
*) NULL
);
10959 lai
->string_char_type
=
10960 lai
->primitive_type_vector
[ada_primitive_type_char
] =
10961 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10962 0, "character", (struct objfile
*) NULL
);
10963 lai
->primitive_type_vector
[ada_primitive_type_float
] =
10964 init_type (TYPE_CODE_FLT
,
10965 gdbarch_float_bit (gdbarch
)/ TARGET_CHAR_BIT
,
10966 0, "float", (struct objfile
*) NULL
);
10967 lai
->primitive_type_vector
[ada_primitive_type_double
] =
10968 init_type (TYPE_CODE_FLT
,
10969 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10970 0, "long_float", (struct objfile
*) NULL
);
10971 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
10972 init_type (TYPE_CODE_INT
,
10973 gdbarch_long_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10974 0, "long_long_integer", (struct objfile
*) NULL
);
10975 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
10976 init_type (TYPE_CODE_FLT
,
10977 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10978 0, "long_long_float", (struct objfile
*) NULL
);
10979 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
10980 init_type (TYPE_CODE_INT
,
10981 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10982 0, "natural", (struct objfile
*) NULL
);
10983 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
10984 init_type (TYPE_CODE_INT
,
10985 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10986 0, "positive", (struct objfile
*) NULL
);
10987 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
10989 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
10990 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
10991 (struct objfile
*) NULL
));
10992 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
10993 = "system__address";
10995 lai
->bool_type_symbol
= "boolean";
10996 lai
->bool_type_default
= builtin
->builtin_bool
;
10999 /* Language vector */
11001 /* Not really used, but needed in the ada_language_defn. */
11004 emit_char (int c
, struct ui_file
*stream
, int quoter
)
11006 ada_emit_char (c
, stream
, quoter
, 1);
11012 warnings_issued
= 0;
11013 return ada_parse ();
11016 static const struct exp_descriptor ada_exp_descriptor
= {
11018 ada_operator_length
,
11020 ada_dump_subexp_body
,
11021 ada_evaluate_subexp
11024 const struct language_defn ada_language_defn
= {
11025 "ada", /* Language name */
11029 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
11030 that's not quite what this means. */
11032 macro_expansion_no
,
11033 &ada_exp_descriptor
,
11037 ada_printchar
, /* Print a character constant */
11038 ada_printstr
, /* Function to print string constant */
11039 emit_char
, /* Function to print single char (not used) */
11040 ada_print_type
, /* Print a type using appropriate syntax */
11041 default_print_typedef
, /* Print a typedef using appropriate syntax */
11042 ada_val_print
, /* Print a value using appropriate syntax */
11043 ada_value_print
, /* Print a top-level value */
11044 NULL
, /* Language specific skip_trampoline */
11045 NULL
, /* name_of_this */
11046 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
11047 basic_lookup_transparent_type
, /* lookup_transparent_type */
11048 ada_la_decode
, /* Language specific symbol demangler */
11049 NULL
, /* Language specific class_name_from_physname */
11050 ada_op_print_tab
, /* expression operators for printing */
11051 0, /* c-style arrays */
11052 1, /* String lower bound */
11053 ada_get_gdb_completer_word_break_characters
,
11054 ada_make_symbol_completion_list
,
11055 ada_language_arch_info
,
11056 ada_print_array_index
,
11057 default_pass_by_reference
,
11062 _initialize_ada_language (void)
11064 add_language (&ada_language_defn
);
11066 varsize_limit
= 65536;
11068 obstack_init (&symbol_list_obstack
);
11070 decoded_names_store
= htab_create_alloc
11071 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
11072 NULL
, xcalloc
, xfree
);
11074 observer_attach_executable_changed (ada_executable_changed_observer
);