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 int format
, enum val_prettyprint pretty
)
358 LA_VALUE_PRINT (index_value
, stream
, format
, pretty
);
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 /* Create a value of type TYPE whose contents come from VALADDR, if it
469 is non-null, and whose memory address (in the inferior) is
473 value_from_contents_and_address (struct type
*type
,
474 const gdb_byte
*valaddr
,
477 struct value
*v
= allocate_value (type
);
479 set_value_lazy (v
, 1);
481 memcpy (value_contents_raw (v
), valaddr
, TYPE_LENGTH (type
));
482 VALUE_ADDRESS (v
) = address
;
484 VALUE_LVAL (v
) = lval_memory
;
488 /* The contents of value VAL, treated as a value of type TYPE. The
489 result is an lval in memory if VAL is. */
491 static struct value
*
492 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
494 type
= ada_check_typedef (type
);
495 if (value_type (val
) == type
)
499 struct value
*result
;
501 /* Make sure that the object size is not unreasonable before
502 trying to allocate some memory for it. */
505 result
= allocate_value (type
);
506 VALUE_LVAL (result
) = VALUE_LVAL (val
);
507 set_value_bitsize (result
, value_bitsize (val
));
508 set_value_bitpos (result
, value_bitpos (val
));
509 VALUE_ADDRESS (result
) = VALUE_ADDRESS (val
) + value_offset (val
);
511 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
512 set_value_lazy (result
, 1);
514 memcpy (value_contents_raw (result
), value_contents (val
),
520 static const gdb_byte
*
521 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
526 return valaddr
+ offset
;
530 cond_offset_target (CORE_ADDR address
, long offset
)
535 return address
+ offset
;
538 /* Issue a warning (as for the definition of warning in utils.c, but
539 with exactly one argument rather than ...), unless the limit on the
540 number of warnings has passed during the evaluation of the current
543 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
544 provided by "complaint". */
545 static void lim_warning (const char *format
, ...) ATTR_FORMAT (printf
, 1, 2);
548 lim_warning (const char *format
, ...)
551 va_start (args
, format
);
553 warnings_issued
+= 1;
554 if (warnings_issued
<= warning_limit
)
555 vwarning (format
, args
);
560 /* Issue an error if the size of an object of type T is unreasonable,
561 i.e. if it would be a bad idea to allocate a value of this type in
565 check_size (const struct type
*type
)
567 if (TYPE_LENGTH (type
) > varsize_limit
)
568 error (_("object size is larger than varsize-limit"));
572 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
573 gdbtypes.h, but some of the necessary definitions in that file
574 seem to have gone missing. */
576 /* Maximum value of a SIZE-byte signed integer type. */
578 max_of_size (int size
)
580 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
581 return top_bit
| (top_bit
- 1);
584 /* Minimum value of a SIZE-byte signed integer type. */
586 min_of_size (int size
)
588 return -max_of_size (size
) - 1;
591 /* Maximum value of a SIZE-byte unsigned integer type. */
593 umax_of_size (int size
)
595 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
596 return top_bit
| (top_bit
- 1);
599 /* Maximum value of integral type T, as a signed quantity. */
601 max_of_type (struct type
*t
)
603 if (TYPE_UNSIGNED (t
))
604 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
606 return max_of_size (TYPE_LENGTH (t
));
609 /* Minimum value of integral type T, as a signed quantity. */
611 min_of_type (struct type
*t
)
613 if (TYPE_UNSIGNED (t
))
616 return min_of_size (TYPE_LENGTH (t
));
619 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
621 discrete_type_high_bound (struct type
*type
)
623 switch (TYPE_CODE (type
))
625 case TYPE_CODE_RANGE
:
626 return TYPE_HIGH_BOUND (type
);
628 return TYPE_FIELD_BITPOS (type
, TYPE_NFIELDS (type
) - 1);
633 return max_of_type (type
);
635 error (_("Unexpected type in discrete_type_high_bound."));
639 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
641 discrete_type_low_bound (struct type
*type
)
643 switch (TYPE_CODE (type
))
645 case TYPE_CODE_RANGE
:
646 return TYPE_LOW_BOUND (type
);
648 return TYPE_FIELD_BITPOS (type
, 0);
653 return min_of_type (type
);
655 error (_("Unexpected type in discrete_type_low_bound."));
659 /* The identity on non-range types. For range types, the underlying
660 non-range scalar type. */
663 base_type (struct type
*type
)
665 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
667 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
669 type
= TYPE_TARGET_TYPE (type
);
675 /* Language Selection */
677 /* If the main program is in Ada, return language_ada, otherwise return LANG
678 (the main program is in Ada iif the adainit symbol is found).
680 MAIN_PST is not used. */
683 ada_update_initial_language (enum language lang
,
684 struct partial_symtab
*main_pst
)
686 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
687 (struct objfile
*) NULL
) != NULL
)
693 /* If the main procedure is written in Ada, then return its name.
694 The result is good until the next call. Return NULL if the main
695 procedure doesn't appear to be in Ada. */
700 struct minimal_symbol
*msym
;
701 CORE_ADDR main_program_name_addr
;
702 static char main_program_name
[1024];
704 /* For Ada, the name of the main procedure is stored in a specific
705 string constant, generated by the binder. Look for that symbol,
706 extract its address, and then read that string. If we didn't find
707 that string, then most probably the main procedure is not written
709 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
713 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
714 if (main_program_name_addr
== 0)
715 error (_("Invalid address for Ada main program name."));
717 extract_string (main_program_name_addr
, main_program_name
);
718 return main_program_name
;
721 /* The main procedure doesn't seem to be in Ada. */
727 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
730 const struct ada_opname_map ada_opname_table
[] = {
731 {"Oadd", "\"+\"", BINOP_ADD
},
732 {"Osubtract", "\"-\"", BINOP_SUB
},
733 {"Omultiply", "\"*\"", BINOP_MUL
},
734 {"Odivide", "\"/\"", BINOP_DIV
},
735 {"Omod", "\"mod\"", BINOP_MOD
},
736 {"Orem", "\"rem\"", BINOP_REM
},
737 {"Oexpon", "\"**\"", BINOP_EXP
},
738 {"Olt", "\"<\"", BINOP_LESS
},
739 {"Ole", "\"<=\"", BINOP_LEQ
},
740 {"Ogt", "\">\"", BINOP_GTR
},
741 {"Oge", "\">=\"", BINOP_GEQ
},
742 {"Oeq", "\"=\"", BINOP_EQUAL
},
743 {"One", "\"/=\"", BINOP_NOTEQUAL
},
744 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
745 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
746 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
747 {"Oconcat", "\"&\"", BINOP_CONCAT
},
748 {"Oabs", "\"abs\"", UNOP_ABS
},
749 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
750 {"Oadd", "\"+\"", UNOP_PLUS
},
751 {"Osubtract", "\"-\"", UNOP_NEG
},
755 /* Return non-zero if STR should be suppressed in info listings. */
758 is_suppressed_name (const char *str
)
760 if (strncmp (str
, "_ada_", 5) == 0)
762 if (str
[0] == '_' || str
[0] == '\000')
767 const char *suffix
= strstr (str
, "___");
768 if (suffix
!= NULL
&& suffix
[3] != 'X')
771 suffix
= str
+ strlen (str
);
772 for (p
= suffix
- 1; p
!= str
; p
-= 1)
776 if (p
[0] == 'X' && p
[-1] != '_')
780 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
781 if (strncmp (ada_opname_table
[i
].encoded
, p
,
782 strlen (ada_opname_table
[i
].encoded
)) == 0)
791 /* The "encoded" form of DECODED, according to GNAT conventions.
792 The result is valid until the next call to ada_encode. */
795 ada_encode (const char *decoded
)
797 static char *encoding_buffer
= NULL
;
798 static size_t encoding_buffer_size
= 0;
805 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
806 2 * strlen (decoded
) + 10);
809 for (p
= decoded
; *p
!= '\0'; p
+= 1)
813 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
818 const struct ada_opname_map
*mapping
;
820 for (mapping
= ada_opname_table
;
821 mapping
->encoded
!= NULL
822 && strncmp (mapping
->decoded
, p
,
823 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
825 if (mapping
->encoded
== NULL
)
826 error (_("invalid Ada operator name: %s"), p
);
827 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
828 k
+= strlen (mapping
->encoded
);
833 encoding_buffer
[k
] = *p
;
838 encoding_buffer
[k
] = '\0';
839 return encoding_buffer
;
842 /* Return NAME folded to lower case, or, if surrounded by single
843 quotes, unfolded, but with the quotes stripped away. Result good
847 ada_fold_name (const char *name
)
849 static char *fold_buffer
= NULL
;
850 static size_t fold_buffer_size
= 0;
852 int len
= strlen (name
);
853 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
857 strncpy (fold_buffer
, name
+ 1, len
- 2);
858 fold_buffer
[len
- 2] = '\000';
863 for (i
= 0; i
<= len
; i
+= 1)
864 fold_buffer
[i
] = tolower (name
[i
]);
870 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
873 is_lower_alphanum (const char c
)
875 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
878 /* Remove either of these suffixes:
883 These are suffixes introduced by the compiler for entities such as
884 nested subprogram for instance, in order to avoid name clashes.
885 They do not serve any purpose for the debugger. */
888 ada_remove_trailing_digits (const char *encoded
, int *len
)
890 if (*len
> 1 && isdigit (encoded
[*len
- 1]))
893 while (i
> 0 && isdigit (encoded
[i
]))
895 if (i
>= 0 && encoded
[i
] == '.')
897 else if (i
>= 0 && encoded
[i
] == '$')
899 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
901 else if (i
>= 1 && strncmp (encoded
+ i
- 1, "__", 2) == 0)
906 /* Remove the suffix introduced by the compiler for protected object
910 ada_remove_po_subprogram_suffix (const char *encoded
, int *len
)
912 /* Remove trailing N. */
914 /* Protected entry subprograms are broken into two
915 separate subprograms: The first one is unprotected, and has
916 a 'N' suffix; the second is the protected version, and has
917 the 'P' suffix. The second calls the first one after handling
918 the protection. Since the P subprograms are internally generated,
919 we leave these names undecoded, giving the user a clue that this
920 entity is internal. */
923 && encoded
[*len
- 1] == 'N'
924 && (isdigit (encoded
[*len
- 2]) || islower (encoded
[*len
- 2])))
928 /* If ENCODED follows the GNAT entity encoding conventions, then return
929 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
932 The resulting string is valid until the next call of ada_decode.
933 If the string is unchanged by decoding, the original string pointer
937 ada_decode (const char *encoded
)
944 static char *decoding_buffer
= NULL
;
945 static size_t decoding_buffer_size
= 0;
947 /* The name of the Ada main procedure starts with "_ada_".
948 This prefix is not part of the decoded name, so skip this part
949 if we see this prefix. */
950 if (strncmp (encoded
, "_ada_", 5) == 0)
953 /* If the name starts with '_', then it is not a properly encoded
954 name, so do not attempt to decode it. Similarly, if the name
955 starts with '<', the name should not be decoded. */
956 if (encoded
[0] == '_' || encoded
[0] == '<')
959 len0
= strlen (encoded
);
961 ada_remove_trailing_digits (encoded
, &len0
);
962 ada_remove_po_subprogram_suffix (encoded
, &len0
);
964 /* Remove the ___X.* suffix if present. Do not forget to verify that
965 the suffix is located before the current "end" of ENCODED. We want
966 to avoid re-matching parts of ENCODED that have previously been
967 marked as discarded (by decrementing LEN0). */
968 p
= strstr (encoded
, "___");
969 if (p
!= NULL
&& p
- encoded
< len0
- 3)
977 /* Remove any trailing TKB suffix. It tells us that this symbol
978 is for the body of a task, but that information does not actually
979 appear in the decoded name. */
981 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
984 /* Remove trailing "B" suffixes. */
985 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
987 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
990 /* Make decoded big enough for possible expansion by operator name. */
992 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
993 decoded
= decoding_buffer
;
995 /* Remove trailing __{digit}+ or trailing ${digit}+. */
997 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1000 while ((i
>= 0 && isdigit (encoded
[i
]))
1001 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1003 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1005 else if (encoded
[i
] == '$')
1009 /* The first few characters that are not alphabetic are not part
1010 of any encoding we use, so we can copy them over verbatim. */
1012 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1013 decoded
[j
] = encoded
[i
];
1018 /* Is this a symbol function? */
1019 if (at_start_name
&& encoded
[i
] == 'O')
1022 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1024 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1025 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1027 && !isalnum (encoded
[i
+ op_len
]))
1029 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1032 j
+= strlen (ada_opname_table
[k
].decoded
);
1036 if (ada_opname_table
[k
].encoded
!= NULL
)
1041 /* Replace "TK__" with "__", which will eventually be translated
1042 into "." (just below). */
1044 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
1047 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1048 be translated into "." (just below). These are internal names
1049 generated for anonymous blocks inside which our symbol is nested. */
1051 if (len0
- i
> 5 && encoded
[i
] == '_' && encoded
[i
+1] == '_'
1052 && encoded
[i
+2] == 'B' && encoded
[i
+3] == '_'
1053 && isdigit (encoded
[i
+4]))
1057 while (k
< len0
&& isdigit (encoded
[k
]))
1058 k
++; /* Skip any extra digit. */
1060 /* Double-check that the "__B_{DIGITS}+" sequence we found
1061 is indeed followed by "__". */
1062 if (len0
- k
> 2 && encoded
[k
] == '_' && encoded
[k
+1] == '_')
1066 /* Remove _E{DIGITS}+[sb] */
1068 /* Just as for protected object subprograms, there are 2 categories
1069 of subprograms created by the compiler for each entry. The first
1070 one implements the actual entry code, and has a suffix following
1071 the convention above; the second one implements the barrier and
1072 uses the same convention as above, except that the 'E' is replaced
1075 Just as above, we do not decode the name of barrier functions
1076 to give the user a clue that the code he is debugging has been
1077 internally generated. */
1079 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
1080 && isdigit (encoded
[i
+2]))
1084 while (k
< len0
&& isdigit (encoded
[k
]))
1088 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
1091 /* Just as an extra precaution, make sure that if this
1092 suffix is followed by anything else, it is a '_'.
1093 Otherwise, we matched this sequence by accident. */
1095 || (k
< len0
&& encoded
[k
] == '_'))
1100 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1101 the GNAT front-end in protected object subprograms. */
1104 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1106 /* Backtrack a bit up until we reach either the begining of
1107 the encoded name, or "__". Make sure that we only find
1108 digits or lowercase characters. */
1109 const char *ptr
= encoded
+ i
- 1;
1111 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1114 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1118 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1120 /* This is a X[bn]* sequence not separated from the previous
1121 part of the name with a non-alpha-numeric character (in other
1122 words, immediately following an alpha-numeric character), then
1123 verify that it is placed at the end of the encoded name. If
1124 not, then the encoding is not valid and we should abort the
1125 decoding. Otherwise, just skip it, it is used in body-nested
1129 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1133 else if (i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1135 /* Replace '__' by '.'. */
1143 /* It's a character part of the decoded name, so just copy it
1145 decoded
[j
] = encoded
[i
];
1150 decoded
[j
] = '\000';
1152 /* Decoded names should never contain any uppercase character.
1153 Double-check this, and abort the decoding if we find one. */
1155 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1156 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1159 if (strcmp (decoded
, encoded
) == 0)
1165 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1166 decoded
= decoding_buffer
;
1167 if (encoded
[0] == '<')
1168 strcpy (decoded
, encoded
);
1170 sprintf (decoded
, "<%s>", encoded
);
1175 /* Table for keeping permanent unique copies of decoded names. Once
1176 allocated, names in this table are never released. While this is a
1177 storage leak, it should not be significant unless there are massive
1178 changes in the set of decoded names in successive versions of a
1179 symbol table loaded during a single session. */
1180 static struct htab
*decoded_names_store
;
1182 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1183 in the language-specific part of GSYMBOL, if it has not been
1184 previously computed. Tries to save the decoded name in the same
1185 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1186 in any case, the decoded symbol has a lifetime at least that of
1188 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1189 const, but nevertheless modified to a semantically equivalent form
1190 when a decoded name is cached in it.
1194 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1197 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
1198 if (*resultp
== NULL
)
1200 const char *decoded
= ada_decode (gsymbol
->name
);
1201 if (gsymbol
->obj_section
!= NULL
)
1203 struct objfile
*objf
= gsymbol
->obj_section
->objfile
;
1204 *resultp
= obsavestring (decoded
, strlen (decoded
),
1205 &objf
->objfile_obstack
);
1207 /* Sometimes, we can't find a corresponding objfile, in which
1208 case, we put the result on the heap. Since we only decode
1209 when needed, we hope this usually does not cause a
1210 significant memory leak (FIXME). */
1211 if (*resultp
== NULL
)
1213 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1216 *slot
= xstrdup (decoded
);
1225 ada_la_decode (const char *encoded
, int options
)
1227 return xstrdup (ada_decode (encoded
));
1230 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1231 suffixes that encode debugging information or leading _ada_ on
1232 SYM_NAME (see is_name_suffix commentary for the debugging
1233 information that is ignored). If WILD, then NAME need only match a
1234 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1235 either argument is NULL. */
1238 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1240 if (sym_name
== NULL
|| name
== NULL
)
1243 return wild_match (name
, strlen (name
), sym_name
);
1246 int len_name
= strlen (name
);
1247 return (strncmp (sym_name
, name
, len_name
) == 0
1248 && is_name_suffix (sym_name
+ len_name
))
1249 || (strncmp (sym_name
, "_ada_", 5) == 0
1250 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1251 && is_name_suffix (sym_name
+ len_name
+ 5));
1255 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1256 suppressed in info listings. */
1259 ada_suppress_symbol_printing (struct symbol
*sym
)
1261 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1264 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1270 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1272 static char *bound_name
[] = {
1273 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1274 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1277 /* Maximum number of array dimensions we are prepared to handle. */
1279 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1281 /* Like modify_field, but allows bitpos > wordlength. */
1284 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1286 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1290 /* The desc_* routines return primitive portions of array descriptors
1293 /* The descriptor or array type, if any, indicated by TYPE; removes
1294 level of indirection, if needed. */
1296 static struct type
*
1297 desc_base_type (struct type
*type
)
1301 type
= ada_check_typedef (type
);
1303 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1304 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1305 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1310 /* True iff TYPE indicates a "thin" array pointer type. */
1313 is_thin_pntr (struct type
*type
)
1316 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1317 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1320 /* The descriptor type for thin pointer type TYPE. */
1322 static struct type
*
1323 thin_descriptor_type (struct type
*type
)
1325 struct type
*base_type
= desc_base_type (type
);
1326 if (base_type
== NULL
)
1328 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1332 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1333 if (alt_type
== NULL
)
1340 /* A pointer to the array data for thin-pointer value VAL. */
1342 static struct value
*
1343 thin_data_pntr (struct value
*val
)
1345 struct type
*type
= value_type (val
);
1346 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1347 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1350 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1351 VALUE_ADDRESS (val
) + value_offset (val
));
1354 /* True iff TYPE indicates a "thick" array pointer type. */
1357 is_thick_pntr (struct type
*type
)
1359 type
= desc_base_type (type
);
1360 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1361 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1364 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1365 pointer to one, the type of its bounds data; otherwise, NULL. */
1367 static struct type
*
1368 desc_bounds_type (struct type
*type
)
1372 type
= desc_base_type (type
);
1376 else if (is_thin_pntr (type
))
1378 type
= thin_descriptor_type (type
);
1381 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1383 return ada_check_typedef (r
);
1385 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1387 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1389 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1394 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1395 one, a pointer to its bounds data. Otherwise NULL. */
1397 static struct value
*
1398 desc_bounds (struct value
*arr
)
1400 struct type
*type
= ada_check_typedef (value_type (arr
));
1401 if (is_thin_pntr (type
))
1403 struct type
*bounds_type
=
1404 desc_bounds_type (thin_descriptor_type (type
));
1407 if (bounds_type
== NULL
)
1408 error (_("Bad GNAT array descriptor"));
1410 /* NOTE: The following calculation is not really kosher, but
1411 since desc_type is an XVE-encoded type (and shouldn't be),
1412 the correct calculation is a real pain. FIXME (and fix GCC). */
1413 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1414 addr
= value_as_long (arr
);
1416 addr
= VALUE_ADDRESS (arr
) + value_offset (arr
);
1419 value_from_longest (lookup_pointer_type (bounds_type
),
1420 addr
- TYPE_LENGTH (bounds_type
));
1423 else if (is_thick_pntr (type
))
1424 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1425 _("Bad GNAT array descriptor"));
1430 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1431 position of the field containing the address of the bounds data. */
1434 fat_pntr_bounds_bitpos (struct type
*type
)
1436 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1439 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1440 size of the field containing the address of the bounds data. */
1443 fat_pntr_bounds_bitsize (struct type
*type
)
1445 type
= desc_base_type (type
);
1447 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1448 return TYPE_FIELD_BITSIZE (type
, 1);
1450 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1453 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1454 pointer to one, the type of its array data (a
1455 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1456 ada_type_of_array to get an array type with bounds data. */
1458 static struct type
*
1459 desc_data_type (struct type
*type
)
1461 type
= desc_base_type (type
);
1463 /* NOTE: The following is bogus; see comment in desc_bounds. */
1464 if (is_thin_pntr (type
))
1465 return lookup_pointer_type
1466 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1467 else if (is_thick_pntr (type
))
1468 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1473 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1476 static struct value
*
1477 desc_data (struct value
*arr
)
1479 struct type
*type
= value_type (arr
);
1480 if (is_thin_pntr (type
))
1481 return thin_data_pntr (arr
);
1482 else if (is_thick_pntr (type
))
1483 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1484 _("Bad GNAT array descriptor"));
1490 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1491 position of the field containing the address of the data. */
1494 fat_pntr_data_bitpos (struct type
*type
)
1496 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1499 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1500 size of the field containing the address of the data. */
1503 fat_pntr_data_bitsize (struct type
*type
)
1505 type
= desc_base_type (type
);
1507 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1508 return TYPE_FIELD_BITSIZE (type
, 0);
1510 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1513 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1514 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1515 bound, if WHICH is 1. The first bound is I=1. */
1517 static struct value
*
1518 desc_one_bound (struct value
*bounds
, int i
, int which
)
1520 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1521 _("Bad GNAT array descriptor bounds"));
1524 /* If BOUNDS is an array-bounds structure type, return the bit position
1525 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1526 bound, if WHICH is 1. The first bound is I=1. */
1529 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1531 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1534 /* If BOUNDS is an array-bounds structure type, return the bit field size
1535 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1536 bound, if WHICH is 1. The first bound is I=1. */
1539 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1541 type
= desc_base_type (type
);
1543 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1544 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1546 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1549 /* If TYPE is the type of an array-bounds structure, the type of its
1550 Ith bound (numbering from 1). Otherwise, NULL. */
1552 static struct type
*
1553 desc_index_type (struct type
*type
, int i
)
1555 type
= desc_base_type (type
);
1557 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1558 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1563 /* The number of index positions in the array-bounds type TYPE.
1564 Return 0 if TYPE is NULL. */
1567 desc_arity (struct type
*type
)
1569 type
= desc_base_type (type
);
1572 return TYPE_NFIELDS (type
) / 2;
1576 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1577 an array descriptor type (representing an unconstrained array
1581 ada_is_direct_array_type (struct type
*type
)
1585 type
= ada_check_typedef (type
);
1586 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1587 || ada_is_array_descriptor_type (type
));
1590 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1594 ada_is_array_type (struct type
*type
)
1597 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1598 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1599 type
= TYPE_TARGET_TYPE (type
);
1600 return ada_is_direct_array_type (type
);
1603 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1606 ada_is_simple_array_type (struct type
*type
)
1610 type
= ada_check_typedef (type
);
1611 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1612 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1613 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1616 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1619 ada_is_array_descriptor_type (struct type
*type
)
1621 struct type
*data_type
= desc_data_type (type
);
1625 type
= ada_check_typedef (type
);
1628 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1629 && TYPE_TARGET_TYPE (data_type
) != NULL
1630 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1631 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1632 && desc_arity (desc_bounds_type (type
)) > 0;
1635 /* Non-zero iff type is a partially mal-formed GNAT array
1636 descriptor. FIXME: This is to compensate for some problems with
1637 debugging output from GNAT. Re-examine periodically to see if it
1641 ada_is_bogus_array_descriptor (struct type
*type
)
1645 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1646 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1647 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1648 && !ada_is_array_descriptor_type (type
);
1652 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1653 (fat pointer) returns the type of the array data described---specifically,
1654 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1655 in from the descriptor; otherwise, they are left unspecified. If
1656 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1657 returns NULL. The result is simply the type of ARR if ARR is not
1660 ada_type_of_array (struct value
*arr
, int bounds
)
1662 if (ada_is_packed_array_type (value_type (arr
)))
1663 return decode_packed_array_type (value_type (arr
));
1665 if (!ada_is_array_descriptor_type (value_type (arr
)))
1666 return value_type (arr
);
1670 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr
))));
1673 struct type
*elt_type
;
1675 struct value
*descriptor
;
1676 struct objfile
*objf
= TYPE_OBJFILE (value_type (arr
));
1678 elt_type
= ada_array_element_type (value_type (arr
), -1);
1679 arity
= ada_array_arity (value_type (arr
));
1681 if (elt_type
== NULL
|| arity
== 0)
1682 return ada_check_typedef (value_type (arr
));
1684 descriptor
= desc_bounds (arr
);
1685 if (value_as_long (descriptor
) == 0)
1689 struct type
*range_type
= alloc_type (objf
);
1690 struct type
*array_type
= alloc_type (objf
);
1691 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1692 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1695 create_range_type (range_type
, value_type (low
),
1696 longest_to_int (value_as_long (low
)),
1697 longest_to_int (value_as_long (high
)));
1698 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1701 return lookup_pointer_type (elt_type
);
1705 /* If ARR does not represent an array, returns ARR unchanged.
1706 Otherwise, returns either a standard GDB array with bounds set
1707 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1708 GDB array. Returns NULL if ARR is a null fat pointer. */
1711 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1713 if (ada_is_array_descriptor_type (value_type (arr
)))
1715 struct type
*arrType
= ada_type_of_array (arr
, 1);
1716 if (arrType
== NULL
)
1718 return value_cast (arrType
, value_copy (desc_data (arr
)));
1720 else if (ada_is_packed_array_type (value_type (arr
)))
1721 return decode_packed_array (arr
);
1726 /* If ARR does not represent an array, returns ARR unchanged.
1727 Otherwise, returns a standard GDB array describing ARR (which may
1728 be ARR itself if it already is in the proper form). */
1730 static struct value
*
1731 ada_coerce_to_simple_array (struct value
*arr
)
1733 if (ada_is_array_descriptor_type (value_type (arr
)))
1735 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1737 error (_("Bounds unavailable for null array pointer."));
1738 check_size (TYPE_TARGET_TYPE (value_type (arrVal
)));
1739 return value_ind (arrVal
);
1741 else if (ada_is_packed_array_type (value_type (arr
)))
1742 return decode_packed_array (arr
);
1747 /* If TYPE represents a GNAT array type, return it translated to an
1748 ordinary GDB array type (possibly with BITSIZE fields indicating
1749 packing). For other types, is the identity. */
1752 ada_coerce_to_simple_array_type (struct type
*type
)
1754 struct value
*mark
= value_mark ();
1755 struct value
*dummy
= value_from_longest (builtin_type_int32
, 0);
1756 struct type
*result
;
1757 deprecated_set_value_type (dummy
, type
);
1758 result
= ada_type_of_array (dummy
, 0);
1759 value_free_to_mark (mark
);
1763 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1766 ada_is_packed_array_type (struct type
*type
)
1770 type
= desc_base_type (type
);
1771 type
= ada_check_typedef (type
);
1773 ada_type_name (type
) != NULL
1774 && strstr (ada_type_name (type
), "___XP") != NULL
;
1777 /* Given that TYPE is a standard GDB array type with all bounds filled
1778 in, and that the element size of its ultimate scalar constituents
1779 (that is, either its elements, or, if it is an array of arrays, its
1780 elements' elements, etc.) is *ELT_BITS, return an identical type,
1781 but with the bit sizes of its elements (and those of any
1782 constituent arrays) recorded in the BITSIZE components of its
1783 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1786 static struct type
*
1787 packed_array_type (struct type
*type
, long *elt_bits
)
1789 struct type
*new_elt_type
;
1790 struct type
*new_type
;
1791 LONGEST low_bound
, high_bound
;
1793 type
= ada_check_typedef (type
);
1794 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1797 new_type
= alloc_type (TYPE_OBJFILE (type
));
1798 new_elt_type
= packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1800 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1801 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1802 TYPE_NAME (new_type
) = ada_type_name (type
);
1804 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1805 &low_bound
, &high_bound
) < 0)
1806 low_bound
= high_bound
= 0;
1807 if (high_bound
< low_bound
)
1808 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1811 *elt_bits
*= (high_bound
- low_bound
+ 1);
1812 TYPE_LENGTH (new_type
) =
1813 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1816 TYPE_FIXED_INSTANCE (new_type
) = 1;
1820 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1822 static struct type
*
1823 decode_packed_array_type (struct type
*type
)
1826 struct block
**blocks
;
1827 char *raw_name
= ada_type_name (ada_check_typedef (type
));
1830 struct type
*shadow_type
;
1835 raw_name
= ada_type_name (desc_base_type (type
));
1840 name
= (char *) alloca (strlen (raw_name
) + 1);
1841 tail
= strstr (raw_name
, "___XP");
1842 type
= desc_base_type (type
);
1844 memcpy (name
, raw_name
, tail
- raw_name
);
1845 name
[tail
- raw_name
] = '\000';
1847 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1848 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1850 lim_warning (_("could not find bounds information on packed array"));
1853 shadow_type
= SYMBOL_TYPE (sym
);
1855 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1857 lim_warning (_("could not understand bounds information on packed array"));
1861 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1864 (_("could not understand bit size information on packed array"));
1868 return packed_array_type (shadow_type
, &bits
);
1871 /* Given that ARR is a struct value *indicating a GNAT packed array,
1872 returns a simple array that denotes that array. Its type is a
1873 standard GDB array type except that the BITSIZEs of the array
1874 target types are set to the number of bits in each element, and the
1875 type length is set appropriately. */
1877 static struct value
*
1878 decode_packed_array (struct value
*arr
)
1882 arr
= ada_coerce_ref (arr
);
1883 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
1884 arr
= ada_value_ind (arr
);
1886 type
= decode_packed_array_type (value_type (arr
));
1889 error (_("can't unpack array"));
1893 if (gdbarch_bits_big_endian (current_gdbarch
)
1894 && ada_is_modular_type (value_type (arr
)))
1896 /* This is a (right-justified) modular type representing a packed
1897 array with no wrapper. In order to interpret the value through
1898 the (left-justified) packed array type we just built, we must
1899 first left-justify it. */
1900 int bit_size
, bit_pos
;
1903 mod
= ada_modulus (value_type (arr
)) - 1;
1910 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
1911 arr
= ada_value_primitive_packed_val (arr
, NULL
,
1912 bit_pos
/ HOST_CHAR_BIT
,
1913 bit_pos
% HOST_CHAR_BIT
,
1918 return coerce_unspec_val_to_type (arr
, type
);
1922 /* The value of the element of packed array ARR at the ARITY indices
1923 given in IND. ARR must be a simple array. */
1925 static struct value
*
1926 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1929 int bits
, elt_off
, bit_off
;
1930 long elt_total_bit_offset
;
1931 struct type
*elt_type
;
1935 elt_total_bit_offset
= 0;
1936 elt_type
= ada_check_typedef (value_type (arr
));
1937 for (i
= 0; i
< arity
; i
+= 1)
1939 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1940 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1942 (_("attempt to do packed indexing of something other than a packed array"));
1945 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1946 LONGEST lowerbound
, upperbound
;
1949 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1951 lim_warning (_("don't know bounds of array"));
1952 lowerbound
= upperbound
= 0;
1955 idx
= pos_atr (ind
[i
]);
1956 if (idx
< lowerbound
|| idx
> upperbound
)
1957 lim_warning (_("packed array index %ld out of bounds"), (long) idx
);
1958 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1959 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1960 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
1963 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1964 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1966 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1971 /* Non-zero iff TYPE includes negative integer values. */
1974 has_negatives (struct type
*type
)
1976 switch (TYPE_CODE (type
))
1981 return !TYPE_UNSIGNED (type
);
1982 case TYPE_CODE_RANGE
:
1983 return TYPE_LOW_BOUND (type
) < 0;
1988 /* Create a new value of type TYPE from the contents of OBJ starting
1989 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1990 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1991 assigning through the result will set the field fetched from.
1992 VALADDR is ignored unless OBJ is NULL, in which case,
1993 VALADDR+OFFSET must address the start of storage containing the
1994 packed value. The value returned in this case is never an lval.
1995 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1998 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
1999 long offset
, int bit_offset
, int bit_size
,
2003 int src
, /* Index into the source area */
2004 targ
, /* Index into the target area */
2005 srcBitsLeft
, /* Number of source bits left to move */
2006 nsrc
, ntarg
, /* Number of source and target bytes */
2007 unusedLS
, /* Number of bits in next significant
2008 byte of source that are unused */
2009 accumSize
; /* Number of meaningful bits in accum */
2010 unsigned char *bytes
; /* First byte containing data to unpack */
2011 unsigned char *unpacked
;
2012 unsigned long accum
; /* Staging area for bits being transferred */
2014 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
2015 /* Transmit bytes from least to most significant; delta is the direction
2016 the indices move. */
2017 int delta
= gdbarch_bits_big_endian (current_gdbarch
) ? -1 : 1;
2019 type
= ada_check_typedef (type
);
2023 v
= allocate_value (type
);
2024 bytes
= (unsigned char *) (valaddr
+ offset
);
2026 else if (VALUE_LVAL (obj
) == lval_memory
&& value_lazy (obj
))
2029 VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
);
2030 bytes
= (unsigned char *) alloca (len
);
2031 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
2035 v
= allocate_value (type
);
2036 bytes
= (unsigned char *) value_contents (obj
) + offset
;
2041 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
2042 if (VALUE_LVAL (obj
) == lval_internalvar
)
2043 VALUE_LVAL (v
) = lval_internalvar_component
;
2044 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
;
2045 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
2046 set_value_bitsize (v
, bit_size
);
2047 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
2049 VALUE_ADDRESS (v
) += 1;
2050 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
2054 set_value_bitsize (v
, bit_size
);
2055 unpacked
= (unsigned char *) value_contents (v
);
2057 srcBitsLeft
= bit_size
;
2059 ntarg
= TYPE_LENGTH (type
);
2063 memset (unpacked
, 0, TYPE_LENGTH (type
));
2066 else if (gdbarch_bits_big_endian (current_gdbarch
))
2069 if (has_negatives (type
)
2070 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
2074 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
2077 switch (TYPE_CODE (type
))
2079 case TYPE_CODE_ARRAY
:
2080 case TYPE_CODE_UNION
:
2081 case TYPE_CODE_STRUCT
:
2082 /* Non-scalar values must be aligned at a byte boundary... */
2084 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
2085 /* ... And are placed at the beginning (most-significant) bytes
2087 targ
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
2091 targ
= TYPE_LENGTH (type
) - 1;
2097 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
2100 unusedLS
= bit_offset
;
2103 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
2110 /* Mask for removing bits of the next source byte that are not
2111 part of the value. */
2112 unsigned int unusedMSMask
=
2113 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
2115 /* Sign-extend bits for this byte. */
2116 unsigned int signMask
= sign
& ~unusedMSMask
;
2118 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
2119 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2120 if (accumSize
>= HOST_CHAR_BIT
)
2122 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2123 accumSize
-= HOST_CHAR_BIT
;
2124 accum
>>= HOST_CHAR_BIT
;
2128 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2135 accum
|= sign
<< accumSize
;
2136 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2137 accumSize
-= HOST_CHAR_BIT
;
2138 accum
>>= HOST_CHAR_BIT
;
2146 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2147 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2150 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
2151 int src_offset
, int n
)
2153 unsigned int accum
, mask
;
2154 int accum_bits
, chunk_size
;
2156 target
+= targ_offset
/ HOST_CHAR_BIT
;
2157 targ_offset
%= HOST_CHAR_BIT
;
2158 source
+= src_offset
/ HOST_CHAR_BIT
;
2159 src_offset
%= HOST_CHAR_BIT
;
2160 if (gdbarch_bits_big_endian (current_gdbarch
))
2162 accum
= (unsigned char) *source
;
2164 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2169 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2170 accum_bits
+= HOST_CHAR_BIT
;
2172 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2175 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2176 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2179 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2181 accum_bits
-= chunk_size
;
2188 accum
= (unsigned char) *source
>> src_offset
;
2190 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2194 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2195 accum_bits
+= HOST_CHAR_BIT
;
2197 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2200 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2201 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2203 accum_bits
-= chunk_size
;
2204 accum
>>= chunk_size
;
2211 /* Store the contents of FROMVAL into the location of TOVAL.
2212 Return a new value with the location of TOVAL and contents of
2213 FROMVAL. Handles assignment into packed fields that have
2214 floating-point or non-scalar types. */
2216 static struct value
*
2217 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2219 struct type
*type
= value_type (toval
);
2220 int bits
= value_bitsize (toval
);
2222 toval
= ada_coerce_ref (toval
);
2223 fromval
= ada_coerce_ref (fromval
);
2225 if (ada_is_direct_array_type (value_type (toval
)))
2226 toval
= ada_coerce_to_simple_array (toval
);
2227 if (ada_is_direct_array_type (value_type (fromval
)))
2228 fromval
= ada_coerce_to_simple_array (fromval
);
2230 if (!deprecated_value_modifiable (toval
))
2231 error (_("Left operand of assignment is not a modifiable lvalue."));
2233 if (VALUE_LVAL (toval
) == lval_memory
2235 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2236 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2238 int len
= (value_bitpos (toval
)
2239 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2241 char *buffer
= (char *) alloca (len
);
2243 CORE_ADDR to_addr
= VALUE_ADDRESS (toval
) + value_offset (toval
);
2245 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2246 fromval
= value_cast (type
, fromval
);
2248 read_memory (to_addr
, buffer
, len
);
2249 from_size
= value_bitsize (fromval
);
2251 from_size
= TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
;
2252 if (gdbarch_bits_big_endian (current_gdbarch
))
2253 move_bits (buffer
, value_bitpos (toval
),
2254 value_contents (fromval
), from_size
- bits
, bits
);
2256 move_bits (buffer
, value_bitpos (toval
), value_contents (fromval
),
2258 write_memory (to_addr
, buffer
, len
);
2259 if (deprecated_memory_changed_hook
)
2260 deprecated_memory_changed_hook (to_addr
, len
);
2262 val
= value_copy (toval
);
2263 memcpy (value_contents_raw (val
), value_contents (fromval
),
2264 TYPE_LENGTH (type
));
2265 deprecated_set_value_type (val
, type
);
2270 return value_assign (toval
, fromval
);
2274 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2275 * CONTAINER, assign the contents of VAL to COMPONENTS's place in
2276 * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2277 * COMPONENT, and not the inferior's memory. The current contents
2278 * of COMPONENT are ignored. */
2280 value_assign_to_component (struct value
*container
, struct value
*component
,
2283 LONGEST offset_in_container
=
2284 (LONGEST
) (VALUE_ADDRESS (component
) + value_offset (component
)
2285 - VALUE_ADDRESS (container
) - value_offset (container
));
2286 int bit_offset_in_container
=
2287 value_bitpos (component
) - value_bitpos (container
);
2290 val
= value_cast (value_type (component
), val
);
2292 if (value_bitsize (component
) == 0)
2293 bits
= TARGET_CHAR_BIT
* TYPE_LENGTH (value_type (component
));
2295 bits
= value_bitsize (component
);
2297 if (gdbarch_bits_big_endian (current_gdbarch
))
2298 move_bits (value_contents_writeable (container
) + offset_in_container
,
2299 value_bitpos (container
) + bit_offset_in_container
,
2300 value_contents (val
),
2301 TYPE_LENGTH (value_type (component
)) * TARGET_CHAR_BIT
- bits
,
2304 move_bits (value_contents_writeable (container
) + offset_in_container
,
2305 value_bitpos (container
) + bit_offset_in_container
,
2306 value_contents (val
), 0, bits
);
2309 /* The value of the element of array ARR at the ARITY indices given in IND.
2310 ARR may be either a simple array, GNAT array descriptor, or pointer
2314 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2318 struct type
*elt_type
;
2320 elt
= ada_coerce_to_simple_array (arr
);
2322 elt_type
= ada_check_typedef (value_type (elt
));
2323 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2324 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2325 return value_subscript_packed (elt
, arity
, ind
);
2327 for (k
= 0; k
< arity
; k
+= 1)
2329 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2330 error (_("too many subscripts (%d expected)"), k
);
2331 elt
= value_subscript (elt
, value_pos_atr (builtin_type_int32
, ind
[k
]));
2336 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2337 value of the element of *ARR at the ARITY indices given in
2338 IND. Does not read the entire array into memory. */
2341 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2346 for (k
= 0; k
< arity
; k
+= 1)
2351 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2352 error (_("too many subscripts (%d expected)"), k
);
2353 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2355 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2356 idx
= value_pos_atr (builtin_type_int32
, ind
[k
]);
2358 idx
= value_binop (idx
, value_from_longest (value_type (idx
), lwb
),
2361 arr
= value_ptradd (arr
, idx
);
2362 type
= TYPE_TARGET_TYPE (type
);
2365 return value_ind (arr
);
2368 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2369 actual type of ARRAY_PTR is ignored), returns a reference to
2370 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2371 bound of this array is LOW, as per Ada rules. */
2372 static struct value
*
2373 ada_value_slice_ptr (struct value
*array_ptr
, struct type
*type
,
2376 CORE_ADDR base
= value_as_address (array_ptr
)
2377 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2378 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2379 struct type
*index_type
=
2380 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2382 struct type
*slice_type
=
2383 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2384 return value_from_pointer (lookup_reference_type (slice_type
), base
);
2388 static struct value
*
2389 ada_value_slice (struct value
*array
, int low
, int high
)
2391 struct type
*type
= value_type (array
);
2392 struct type
*index_type
=
2393 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2394 struct type
*slice_type
=
2395 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2396 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2399 /* If type is a record type in the form of a standard GNAT array
2400 descriptor, returns the number of dimensions for type. If arr is a
2401 simple array, returns the number of "array of"s that prefix its
2402 type designation. Otherwise, returns 0. */
2405 ada_array_arity (struct type
*type
)
2412 type
= desc_base_type (type
);
2415 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2416 return desc_arity (desc_bounds_type (type
));
2418 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2421 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2427 /* If TYPE is a record type in the form of a standard GNAT array
2428 descriptor or a simple array type, returns the element type for
2429 TYPE after indexing by NINDICES indices, or by all indices if
2430 NINDICES is -1. Otherwise, returns NULL. */
2433 ada_array_element_type (struct type
*type
, int nindices
)
2435 type
= desc_base_type (type
);
2437 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2440 struct type
*p_array_type
;
2442 p_array_type
= desc_data_type (type
);
2444 k
= ada_array_arity (type
);
2448 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2449 if (nindices
>= 0 && k
> nindices
)
2451 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2452 while (k
> 0 && p_array_type
!= NULL
)
2454 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2457 return p_array_type
;
2459 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2461 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2463 type
= TYPE_TARGET_TYPE (type
);
2472 /* The type of nth index in arrays of given type (n numbering from 1).
2473 Does not examine memory. */
2476 ada_index_type (struct type
*type
, int n
)
2478 struct type
*result_type
;
2480 type
= desc_base_type (type
);
2482 if (n
> ada_array_arity (type
))
2485 if (ada_is_simple_array_type (type
))
2489 for (i
= 1; i
< n
; i
+= 1)
2490 type
= TYPE_TARGET_TYPE (type
);
2491 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2492 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2493 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2494 perhaps stabsread.c would make more sense. */
2495 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2496 result_type
= builtin_type_int32
;
2501 return desc_index_type (desc_bounds_type (type
), n
);
2504 /* Given that arr is an array type, returns the lower bound of the
2505 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2506 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2507 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2508 bounds type. It works for other arrays with bounds supplied by
2509 run-time quantities other than discriminants. */
2512 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2513 struct type
** typep
)
2516 struct type
*index_type_desc
;
2518 if (ada_is_packed_array_type (arr_type
))
2519 arr_type
= decode_packed_array_type (arr_type
);
2521 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2524 *typep
= builtin_type_int32
;
2525 return (LONGEST
) - which
;
2528 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2529 type
= TYPE_TARGET_TYPE (arr_type
);
2533 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2534 if (index_type_desc
== NULL
)
2536 struct type
*index_type
;
2540 type
= TYPE_TARGET_TYPE (type
);
2544 index_type
= TYPE_INDEX_TYPE (type
);
2546 *typep
= index_type
;
2548 /* The index type is either a range type or an enumerated type.
2549 For the range type, we have some macros that allow us to
2550 extract the value of the low and high bounds. But they
2551 do now work for enumerated types. The expressions used
2552 below work for both range and enum types. */
2554 (LONGEST
) (which
== 0
2555 ? TYPE_FIELD_BITPOS (index_type
, 0)
2556 : TYPE_FIELD_BITPOS (index_type
,
2557 TYPE_NFIELDS (index_type
) - 1));
2561 struct type
*index_type
=
2562 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2563 NULL
, TYPE_OBJFILE (arr_type
));
2566 *typep
= index_type
;
2569 (LONGEST
) (which
== 0
2570 ? TYPE_LOW_BOUND (index_type
)
2571 : TYPE_HIGH_BOUND (index_type
));
2575 /* Given that arr is an array value, returns the lower bound of the
2576 nth index (numbering from 1) if WHICH is 0, and the upper bound if
2577 WHICH is 1. This routine will also work for arrays with bounds
2578 supplied by run-time quantities other than discriminants. */
2581 ada_array_bound (struct value
*arr
, int n
, int which
)
2583 struct type
*arr_type
= value_type (arr
);
2585 if (ada_is_packed_array_type (arr_type
))
2586 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2587 else if (ada_is_simple_array_type (arr_type
))
2590 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2591 return value_from_longest (type
, v
);
2594 return desc_one_bound (desc_bounds (arr
), n
, which
);
2597 /* Given that arr is an array value, returns the length of the
2598 nth index. This routine will also work for arrays with bounds
2599 supplied by run-time quantities other than discriminants.
2600 Does not work for arrays indexed by enumeration types with representation
2601 clauses at the moment. */
2604 ada_array_length (struct value
*arr
, int n
)
2606 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2608 if (ada_is_packed_array_type (arr_type
))
2609 return ada_array_length (decode_packed_array (arr
), n
);
2611 if (ada_is_simple_array_type (arr_type
))
2615 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2616 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2617 return value_from_longest (type
, v
);
2621 value_from_longest (builtin_type_int32
,
2622 value_as_long (desc_one_bound (desc_bounds (arr
),
2624 - value_as_long (desc_one_bound (desc_bounds (arr
),
2628 /* An empty array whose type is that of ARR_TYPE (an array type),
2629 with bounds LOW to LOW-1. */
2631 static struct value
*
2632 empty_array (struct type
*arr_type
, int low
)
2634 struct type
*index_type
=
2635 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2637 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2638 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2642 /* Name resolution */
2644 /* The "decoded" name for the user-definable Ada operator corresponding
2648 ada_decoded_op_name (enum exp_opcode op
)
2652 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2654 if (ada_opname_table
[i
].op
== op
)
2655 return ada_opname_table
[i
].decoded
;
2657 error (_("Could not find operator name for opcode"));
2661 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2662 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2663 undefined namespace) and converts operators that are
2664 user-defined into appropriate function calls. If CONTEXT_TYPE is
2665 non-null, it provides a preferred result type [at the moment, only
2666 type void has any effect---causing procedures to be preferred over
2667 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2668 return type is preferred. May change (expand) *EXP. */
2671 resolve (struct expression
**expp
, int void_context_p
)
2675 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2678 /* Resolve the operator of the subexpression beginning at
2679 position *POS of *EXPP. "Resolving" consists of replacing
2680 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2681 with their resolutions, replacing built-in operators with
2682 function calls to user-defined operators, where appropriate, and,
2683 when DEPROCEDURE_P is non-zero, converting function-valued variables
2684 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2685 are as in ada_resolve, above. */
2687 static struct value
*
2688 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2689 struct type
*context_type
)
2693 struct expression
*exp
; /* Convenience: == *expp. */
2694 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2695 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2696 int nargs
; /* Number of operands. */
2703 /* Pass one: resolve operands, saving their types and updating *pos,
2708 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2709 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2714 resolve_subexp (expp
, pos
, 0, NULL
);
2716 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2721 resolve_subexp (expp
, pos
, 0, NULL
);
2726 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2729 case OP_ATR_MODULUS
:
2739 case TERNOP_IN_RANGE
:
2740 case BINOP_IN_BOUNDS
:
2746 case OP_DISCRETE_RANGE
:
2748 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
2757 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2759 resolve_subexp (expp
, pos
, 1, NULL
);
2761 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2778 case BINOP_LOGICAL_AND
:
2779 case BINOP_LOGICAL_OR
:
2780 case BINOP_BITWISE_AND
:
2781 case BINOP_BITWISE_IOR
:
2782 case BINOP_BITWISE_XOR
:
2785 case BINOP_NOTEQUAL
:
2792 case BINOP_SUBSCRIPT
:
2800 case UNOP_LOGICAL_NOT
:
2816 case OP_INTERNALVAR
:
2826 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2829 case STRUCTOP_STRUCT
:
2830 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2843 error (_("Unexpected operator during name resolution"));
2846 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2847 for (i
= 0; i
< nargs
; i
+= 1)
2848 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2852 /* Pass two: perform any resolution on principal operator. */
2859 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2861 struct ada_symbol_info
*candidates
;
2865 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2866 (exp
->elts
[pc
+ 2].symbol
),
2867 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2870 if (n_candidates
> 1)
2872 /* Types tend to get re-introduced locally, so if there
2873 are any local symbols that are not types, first filter
2876 for (j
= 0; j
< n_candidates
; j
+= 1)
2877 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2882 case LOC_REGPARM_ADDR
:
2890 if (j
< n_candidates
)
2893 while (j
< n_candidates
)
2895 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2897 candidates
[j
] = candidates
[n_candidates
- 1];
2906 if (n_candidates
== 0)
2907 error (_("No definition found for %s"),
2908 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2909 else if (n_candidates
== 1)
2911 else if (deprocedure_p
2912 && !is_nonfunction (candidates
, n_candidates
))
2914 i
= ada_resolve_function
2915 (candidates
, n_candidates
, NULL
, 0,
2916 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2919 error (_("Could not find a match for %s"),
2920 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2924 printf_filtered (_("Multiple matches for %s\n"),
2925 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2926 user_select_syms (candidates
, n_candidates
, 1);
2930 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2931 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2932 if (innermost_block
== NULL
2933 || contained_in (candidates
[i
].block
, innermost_block
))
2934 innermost_block
= candidates
[i
].block
;
2938 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2941 replace_operator_with_call (expp
, pc
, 0, 0,
2942 exp
->elts
[pc
+ 2].symbol
,
2943 exp
->elts
[pc
+ 1].block
);
2950 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2951 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2953 struct ada_symbol_info
*candidates
;
2957 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2958 (exp
->elts
[pc
+ 5].symbol
),
2959 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2961 if (n_candidates
== 1)
2965 i
= ada_resolve_function
2966 (candidates
, n_candidates
,
2968 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2971 error (_("Could not find a match for %s"),
2972 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2975 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2976 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2977 if (innermost_block
== NULL
2978 || contained_in (candidates
[i
].block
, innermost_block
))
2979 innermost_block
= candidates
[i
].block
;
2990 case BINOP_BITWISE_AND
:
2991 case BINOP_BITWISE_IOR
:
2992 case BINOP_BITWISE_XOR
:
2994 case BINOP_NOTEQUAL
:
3002 case UNOP_LOGICAL_NOT
:
3004 if (possible_user_operator_p (op
, argvec
))
3006 struct ada_symbol_info
*candidates
;
3010 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
3011 (struct block
*) NULL
, VAR_DOMAIN
,
3013 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
3014 ada_decoded_op_name (op
), NULL
);
3018 replace_operator_with_call (expp
, pc
, nargs
, 1,
3019 candidates
[i
].sym
, candidates
[i
].block
);
3030 return evaluate_subexp_type (exp
, pos
);
3033 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3034 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3035 a non-pointer. A type of 'void' (which is never a valid expression type)
3036 by convention matches anything. */
3037 /* The term "match" here is rather loose. The match is heuristic and
3038 liberal. FIXME: TOO liberal, in fact. */
3041 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
3043 ftype
= ada_check_typedef (ftype
);
3044 atype
= ada_check_typedef (atype
);
3046 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
3047 ftype
= TYPE_TARGET_TYPE (ftype
);
3048 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
3049 atype
= TYPE_TARGET_TYPE (atype
);
3051 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
3052 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
3055 switch (TYPE_CODE (ftype
))
3060 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
3061 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
3062 TYPE_TARGET_TYPE (atype
), 0);
3065 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
3067 case TYPE_CODE_ENUM
:
3068 case TYPE_CODE_RANGE
:
3069 switch (TYPE_CODE (atype
))
3072 case TYPE_CODE_ENUM
:
3073 case TYPE_CODE_RANGE
:
3079 case TYPE_CODE_ARRAY
:
3080 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3081 || ada_is_array_descriptor_type (atype
));
3083 case TYPE_CODE_STRUCT
:
3084 if (ada_is_array_descriptor_type (ftype
))
3085 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
3086 || ada_is_array_descriptor_type (atype
));
3088 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
3089 && !ada_is_array_descriptor_type (atype
));
3091 case TYPE_CODE_UNION
:
3093 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
3097 /* Return non-zero if the formals of FUNC "sufficiently match" the
3098 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3099 may also be an enumeral, in which case it is treated as a 0-
3100 argument function. */
3103 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
3106 struct type
*func_type
= SYMBOL_TYPE (func
);
3108 if (SYMBOL_CLASS (func
) == LOC_CONST
3109 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
3110 return (n_actuals
== 0);
3111 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
3114 if (TYPE_NFIELDS (func_type
) != n_actuals
)
3117 for (i
= 0; i
< n_actuals
; i
+= 1)
3119 if (actuals
[i
] == NULL
)
3123 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
3124 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
3126 if (!ada_type_match (ftype
, atype
, 1))
3133 /* False iff function type FUNC_TYPE definitely does not produce a value
3134 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3135 FUNC_TYPE is not a valid function type with a non-null return type
3136 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3139 return_match (struct type
*func_type
, struct type
*context_type
)
3141 struct type
*return_type
;
3143 if (func_type
== NULL
)
3146 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
3147 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
3149 return_type
= base_type (func_type
);
3150 if (return_type
== NULL
)
3153 context_type
= base_type (context_type
);
3155 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
3156 return context_type
== NULL
|| return_type
== context_type
;
3157 else if (context_type
== NULL
)
3158 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
3160 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3164 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3165 function (if any) that matches the types of the NARGS arguments in
3166 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3167 that returns that type, then eliminate matches that don't. If
3168 CONTEXT_TYPE is void and there is at least one match that does not
3169 return void, eliminate all matches that do.
3171 Asks the user if there is more than one match remaining. Returns -1
3172 if there is no such symbol or none is selected. NAME is used
3173 solely for messages. May re-arrange and modify SYMS in
3174 the process; the index returned is for the modified vector. */
3177 ada_resolve_function (struct ada_symbol_info syms
[],
3178 int nsyms
, struct value
**args
, int nargs
,
3179 const char *name
, struct type
*context_type
)
3182 int m
; /* Number of hits */
3183 struct type
*fallback
;
3184 struct type
*return_type
;
3186 return_type
= context_type
;
3187 if (context_type
== NULL
)
3188 fallback
= builtin_type_void
;
3195 for (k
= 0; k
< nsyms
; k
+= 1)
3197 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3199 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3200 && return_match (type
, return_type
))
3206 if (m
> 0 || return_type
== fallback
)
3209 return_type
= fallback
;
3216 printf_filtered (_("Multiple matches for %s\n"), name
);
3217 user_select_syms (syms
, m
, 1);
3223 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3224 in a listing of choices during disambiguation (see sort_choices, below).
3225 The idea is that overloadings of a subprogram name from the
3226 same package should sort in their source order. We settle for ordering
3227 such symbols by their trailing number (__N or $N). */
3230 encoded_ordered_before (char *N0
, char *N1
)
3234 else if (N0
== NULL
)
3239 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3241 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3243 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3244 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3248 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3251 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3253 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3254 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3256 return (strcmp (N0
, N1
) < 0);
3260 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3264 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3267 for (i
= 1; i
< nsyms
; i
+= 1)
3269 struct ada_symbol_info sym
= syms
[i
];
3272 for (j
= i
- 1; j
>= 0; j
-= 1)
3274 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3275 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3277 syms
[j
+ 1] = syms
[j
];
3283 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3284 by asking the user (if necessary), returning the number selected,
3285 and setting the first elements of SYMS items. Error if no symbols
3288 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3289 to be re-integrated one of these days. */
3292 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3295 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3297 int first_choice
= (max_results
== 1) ? 1 : 2;
3298 const char *select_mode
= multiple_symbols_select_mode ();
3300 if (max_results
< 1)
3301 error (_("Request to select 0 symbols!"));
3305 if (select_mode
== multiple_symbols_cancel
)
3307 canceled because the command is ambiguous\n\
3308 See set/show multiple-symbol."));
3310 /* If select_mode is "all", then return all possible symbols.
3311 Only do that if more than one symbol can be selected, of course.
3312 Otherwise, display the menu as usual. */
3313 if (select_mode
== multiple_symbols_all
&& max_results
> 1)
3316 printf_unfiltered (_("[0] cancel\n"));
3317 if (max_results
> 1)
3318 printf_unfiltered (_("[1] all\n"));
3320 sort_choices (syms
, nsyms
);
3322 for (i
= 0; i
< nsyms
; i
+= 1)
3324 if (syms
[i
].sym
== NULL
)
3327 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3329 struct symtab_and_line sal
=
3330 find_function_start_sal (syms
[i
].sym
, 1);
3331 if (sal
.symtab
== NULL
)
3332 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3334 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3337 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3338 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3339 sal
.symtab
->filename
, sal
.line
);
3345 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3346 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3347 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3348 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3350 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3351 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3353 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3354 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3355 else if (is_enumeral
3356 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3358 printf_unfiltered (("[%d] "), i
+ first_choice
);
3359 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3361 printf_unfiltered (_("'(%s) (enumeral)\n"),
3362 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3364 else if (symtab
!= NULL
)
3365 printf_unfiltered (is_enumeral
3366 ? _("[%d] %s in %s (enumeral)\n")
3367 : _("[%d] %s at %s:?\n"),
3369 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3372 printf_unfiltered (is_enumeral
3373 ? _("[%d] %s (enumeral)\n")
3374 : _("[%d] %s at ?\n"),
3376 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3380 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3383 for (i
= 0; i
< n_chosen
; i
+= 1)
3384 syms
[i
] = syms
[chosen
[i
]];
3389 /* Read and validate a set of numeric choices from the user in the
3390 range 0 .. N_CHOICES-1. Place the results in increasing
3391 order in CHOICES[0 .. N-1], and return N.
3393 The user types choices as a sequence of numbers on one line
3394 separated by blanks, encoding them as follows:
3396 + A choice of 0 means to cancel the selection, throwing an error.
3397 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3398 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3400 The user is not allowed to choose more than MAX_RESULTS values.
3402 ANNOTATION_SUFFIX, if present, is used to annotate the input
3403 prompts (for use with the -f switch). */
3406 get_selections (int *choices
, int n_choices
, int max_results
,
3407 int is_all_choice
, char *annotation_suffix
)
3412 int first_choice
= is_all_choice
? 2 : 1;
3414 prompt
= getenv ("PS2");
3418 args
= command_line_input (prompt
, 0, annotation_suffix
);
3421 error_no_arg (_("one or more choice numbers"));
3425 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3426 order, as given in args. Choices are validated. */
3432 while (isspace (*args
))
3434 if (*args
== '\0' && n_chosen
== 0)
3435 error_no_arg (_("one or more choice numbers"));
3436 else if (*args
== '\0')
3439 choice
= strtol (args
, &args2
, 10);
3440 if (args
== args2
|| choice
< 0
3441 || choice
> n_choices
+ first_choice
- 1)
3442 error (_("Argument must be choice number"));
3446 error (_("cancelled"));
3448 if (choice
< first_choice
)
3450 n_chosen
= n_choices
;
3451 for (j
= 0; j
< n_choices
; j
+= 1)
3455 choice
-= first_choice
;
3457 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3461 if (j
< 0 || choice
!= choices
[j
])
3464 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3465 choices
[k
+ 1] = choices
[k
];
3466 choices
[j
+ 1] = choice
;
3471 if (n_chosen
> max_results
)
3472 error (_("Select no more than %d of the above"), max_results
);
3477 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3478 on the function identified by SYM and BLOCK, and taking NARGS
3479 arguments. Update *EXPP as needed to hold more space. */
3482 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3483 int oplen
, struct symbol
*sym
,
3484 struct block
*block
)
3486 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3487 symbol, -oplen for operator being replaced). */
3488 struct expression
*newexp
= (struct expression
*)
3489 xmalloc (sizeof (struct expression
)
3490 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3491 struct expression
*exp
= *expp
;
3493 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3494 newexp
->language_defn
= exp
->language_defn
;
3495 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3496 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3497 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3499 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3500 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3502 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3503 newexp
->elts
[pc
+ 4].block
= block
;
3504 newexp
->elts
[pc
+ 5].symbol
= sym
;
3510 /* Type-class predicates */
3512 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3516 numeric_type_p (struct type
*type
)
3522 switch (TYPE_CODE (type
))
3527 case TYPE_CODE_RANGE
:
3528 return (type
== TYPE_TARGET_TYPE (type
)
3529 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3536 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3539 integer_type_p (struct type
*type
)
3545 switch (TYPE_CODE (type
))
3549 case TYPE_CODE_RANGE
:
3550 return (type
== TYPE_TARGET_TYPE (type
)
3551 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3558 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3561 scalar_type_p (struct type
*type
)
3567 switch (TYPE_CODE (type
))
3570 case TYPE_CODE_RANGE
:
3571 case TYPE_CODE_ENUM
:
3580 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3583 discrete_type_p (struct type
*type
)
3589 switch (TYPE_CODE (type
))
3592 case TYPE_CODE_RANGE
:
3593 case TYPE_CODE_ENUM
:
3601 /* Returns non-zero if OP with operands in the vector ARGS could be
3602 a user-defined function. Errs on the side of pre-defined operators
3603 (i.e., result 0). */
3606 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3608 struct type
*type0
=
3609 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3610 struct type
*type1
=
3611 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3625 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3629 case BINOP_BITWISE_AND
:
3630 case BINOP_BITWISE_IOR
:
3631 case BINOP_BITWISE_XOR
:
3632 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3635 case BINOP_NOTEQUAL
:
3640 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3643 return !ada_is_array_type (type0
) || !ada_is_array_type (type1
);
3646 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3650 case UNOP_LOGICAL_NOT
:
3652 return (!numeric_type_p (type0
));
3661 1. In the following, we assume that a renaming type's name may
3662 have an ___XD suffix. It would be nice if this went away at some
3664 2. We handle both the (old) purely type-based representation of
3665 renamings and the (new) variable-based encoding. At some point,
3666 it is devoutly to be hoped that the former goes away
3667 (FIXME: hilfinger-2007-07-09).
3668 3. Subprogram renamings are not implemented, although the XRS
3669 suffix is recognized (FIXME: hilfinger-2007-07-09). */
3671 /* If SYM encodes a renaming,
3673 <renaming> renames <renamed entity>,
3675 sets *LEN to the length of the renamed entity's name,
3676 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
3677 the string describing the subcomponent selected from the renamed
3678 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
3679 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
3680 are undefined). Otherwise, returns a value indicating the category
3681 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
3682 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
3683 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
3684 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
3685 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
3686 may be NULL, in which case they are not assigned.
3688 [Currently, however, GCC does not generate subprogram renamings.] */
3690 enum ada_renaming_category
3691 ada_parse_renaming (struct symbol
*sym
,
3692 const char **renamed_entity
, int *len
,
3693 const char **renaming_expr
)
3695 enum ada_renaming_category kind
;
3700 return ADA_NOT_RENAMING
;
3701 switch (SYMBOL_CLASS (sym
))
3704 return ADA_NOT_RENAMING
;
3706 return parse_old_style_renaming (SYMBOL_TYPE (sym
),
3707 renamed_entity
, len
, renaming_expr
);
3711 case LOC_OPTIMIZED_OUT
:
3712 info
= strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR");
3714 return ADA_NOT_RENAMING
;
3718 kind
= ADA_OBJECT_RENAMING
;
3722 kind
= ADA_EXCEPTION_RENAMING
;
3726 kind
= ADA_PACKAGE_RENAMING
;
3730 kind
= ADA_SUBPROGRAM_RENAMING
;
3734 return ADA_NOT_RENAMING
;
3738 if (renamed_entity
!= NULL
)
3739 *renamed_entity
= info
;
3740 suffix
= strstr (info
, "___XE");
3741 if (suffix
== NULL
|| suffix
== info
)
3742 return ADA_NOT_RENAMING
;
3744 *len
= strlen (info
) - strlen (suffix
);
3746 if (renaming_expr
!= NULL
)
3747 *renaming_expr
= suffix
;
3751 /* Assuming TYPE encodes a renaming according to the old encoding in
3752 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
3753 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
3754 ADA_NOT_RENAMING otherwise. */
3755 static enum ada_renaming_category
3756 parse_old_style_renaming (struct type
*type
,
3757 const char **renamed_entity
, int *len
,
3758 const char **renaming_expr
)
3760 enum ada_renaming_category kind
;
3765 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
3766 || TYPE_NFIELDS (type
) != 1)
3767 return ADA_NOT_RENAMING
;
3769 name
= type_name_no_tag (type
);
3771 return ADA_NOT_RENAMING
;
3773 name
= strstr (name
, "___XR");
3775 return ADA_NOT_RENAMING
;
3780 kind
= ADA_OBJECT_RENAMING
;
3783 kind
= ADA_EXCEPTION_RENAMING
;
3786 kind
= ADA_PACKAGE_RENAMING
;
3789 kind
= ADA_SUBPROGRAM_RENAMING
;
3792 return ADA_NOT_RENAMING
;
3795 info
= TYPE_FIELD_NAME (type
, 0);
3797 return ADA_NOT_RENAMING
;
3798 if (renamed_entity
!= NULL
)
3799 *renamed_entity
= info
;
3800 suffix
= strstr (info
, "___XE");
3801 if (renaming_expr
!= NULL
)
3802 *renaming_expr
= suffix
+ 5;
3803 if (suffix
== NULL
|| suffix
== info
)
3804 return ADA_NOT_RENAMING
;
3806 *len
= suffix
- info
;
3812 /* Evaluation: Function Calls */
3814 /* Return an lvalue containing the value VAL. This is the identity on
3815 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3816 on the stack, using and updating *SP as the stack pointer, and
3817 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3819 static struct value
*
3820 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3822 if (! VALUE_LVAL (val
))
3824 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3826 /* The following is taken from the structure-return code in
3827 call_function_by_hand. FIXME: Therefore, some refactoring seems
3829 if (gdbarch_inner_than (current_gdbarch
, 1, 2))
3831 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3832 reserving sufficient space. */
3834 if (gdbarch_frame_align_p (current_gdbarch
))
3835 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3836 VALUE_ADDRESS (val
) = *sp
;
3840 /* Stack grows upward. Align the frame, allocate space, and
3841 then again, re-align the frame. */
3842 if (gdbarch_frame_align_p (current_gdbarch
))
3843 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3844 VALUE_ADDRESS (val
) = *sp
;
3846 if (gdbarch_frame_align_p (current_gdbarch
))
3847 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3849 VALUE_LVAL (val
) = lval_memory
;
3851 write_memory (VALUE_ADDRESS (val
), value_contents_raw (val
), len
);
3857 /* Return the value ACTUAL, converted to be an appropriate value for a
3858 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3859 allocating any necessary descriptors (fat pointers), or copies of
3860 values not residing in memory, updating it as needed. */
3863 ada_convert_actual (struct value
*actual
, struct type
*formal_type0
,
3866 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3867 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3868 struct type
*formal_target
=
3869 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3870 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3871 struct type
*actual_target
=
3872 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3873 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3875 if (ada_is_array_descriptor_type (formal_target
)
3876 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3877 return make_array_descriptor (formal_type
, actual
, sp
);
3878 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3879 || TYPE_CODE (formal_type
) == TYPE_CODE_REF
)
3881 struct value
*result
;
3882 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3883 && ada_is_array_descriptor_type (actual_target
))
3884 result
= desc_data (actual
);
3885 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3887 if (VALUE_LVAL (actual
) != lval_memory
)
3890 actual_type
= ada_check_typedef (value_type (actual
));
3891 val
= allocate_value (actual_type
);
3892 memcpy ((char *) value_contents_raw (val
),
3893 (char *) value_contents (actual
),
3894 TYPE_LENGTH (actual_type
));
3895 actual
= ensure_lval (val
, sp
);
3897 result
= value_addr (actual
);
3901 return value_cast_pointers (formal_type
, result
);
3903 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3904 return ada_value_ind (actual
);
3910 /* Push a descriptor of type TYPE for array value ARR on the stack at
3911 *SP, updating *SP to reflect the new descriptor. Return either
3912 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3913 to-descriptor type rather than a descriptor type), a struct value *
3914 representing a pointer to this descriptor. */
3916 static struct value
*
3917 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3919 struct type
*bounds_type
= desc_bounds_type (type
);
3920 struct type
*desc_type
= desc_base_type (type
);
3921 struct value
*descriptor
= allocate_value (desc_type
);
3922 struct value
*bounds
= allocate_value (bounds_type
);
3925 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
3927 modify_general_field (value_contents_writeable (bounds
),
3928 value_as_long (ada_array_bound (arr
, i
, 0)),
3929 desc_bound_bitpos (bounds_type
, i
, 0),
3930 desc_bound_bitsize (bounds_type
, i
, 0));
3931 modify_general_field (value_contents_writeable (bounds
),
3932 value_as_long (ada_array_bound (arr
, i
, 1)),
3933 desc_bound_bitpos (bounds_type
, i
, 1),
3934 desc_bound_bitsize (bounds_type
, i
, 1));
3937 bounds
= ensure_lval (bounds
, sp
);
3939 modify_general_field (value_contents_writeable (descriptor
),
3940 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3941 fat_pntr_data_bitpos (desc_type
),
3942 fat_pntr_data_bitsize (desc_type
));
3944 modify_general_field (value_contents_writeable (descriptor
),
3945 VALUE_ADDRESS (bounds
),
3946 fat_pntr_bounds_bitpos (desc_type
),
3947 fat_pntr_bounds_bitsize (desc_type
));
3949 descriptor
= ensure_lval (descriptor
, sp
);
3951 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3952 return value_addr (descriptor
);
3957 /* Dummy definitions for an experimental caching module that is not
3958 * used in the public sources. */
3961 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3962 struct symbol
**sym
, struct block
**block
)
3968 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3969 struct block
*block
)
3975 /* Return the result of a standard (literal, C-like) lookup of NAME in
3976 given DOMAIN, visible from lexical block BLOCK. */
3978 static struct symbol
*
3979 standard_lookup (const char *name
, const struct block
*block
,
3984 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
))
3986 sym
= lookup_symbol_in_language (name
, block
, domain
, language_c
, 0);
3987 cache_symbol (name
, domain
, sym
, block_found
);
3992 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3993 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3994 since they contend in overloading in the same way. */
3996 is_nonfunction (struct ada_symbol_info syms
[], int n
)
4000 for (i
= 0; i
< n
; i
+= 1)
4001 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
4002 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
4003 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
4009 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4010 struct types. Otherwise, they may not. */
4013 equiv_types (struct type
*type0
, struct type
*type1
)
4017 if (type0
== NULL
|| type1
== NULL
4018 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
4020 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
4021 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
4022 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
4023 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
4029 /* True iff SYM0 represents the same entity as SYM1, or one that is
4030 no more defined than that of SYM1. */
4033 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
4037 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
4038 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
4041 switch (SYMBOL_CLASS (sym0
))
4047 struct type
*type0
= SYMBOL_TYPE (sym0
);
4048 struct type
*type1
= SYMBOL_TYPE (sym1
);
4049 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
4050 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
4051 int len0
= strlen (name0
);
4053 TYPE_CODE (type0
) == TYPE_CODE (type1
)
4054 && (equiv_types (type0
, type1
)
4055 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
4056 && strncmp (name1
+ len0
, "___XV", 5) == 0));
4059 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
4060 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
4066 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4067 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4070 add_defn_to_vec (struct obstack
*obstackp
,
4072 struct block
*block
)
4076 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
4078 /* Do not try to complete stub types, as the debugger is probably
4079 already scanning all symbols matching a certain name at the
4080 time when this function is called. Trying to replace the stub
4081 type by its associated full type will cause us to restart a scan
4082 which may lead to an infinite recursion. Instead, the client
4083 collecting the matching symbols will end up collecting several
4084 matches, with at least one of them complete. It can then filter
4085 out the stub ones if needed. */
4087 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
4089 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
4091 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
4093 prevDefns
[i
].sym
= sym
;
4094 prevDefns
[i
].block
= block
;
4100 struct ada_symbol_info info
;
4104 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
4108 /* Number of ada_symbol_info structures currently collected in
4109 current vector in *OBSTACKP. */
4112 num_defns_collected (struct obstack
*obstackp
)
4114 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
4117 /* Vector of ada_symbol_info structures currently collected in current
4118 vector in *OBSTACKP. If FINISH, close off the vector and return
4119 its final address. */
4121 static struct ada_symbol_info
*
4122 defns_collected (struct obstack
*obstackp
, int finish
)
4125 return obstack_finish (obstackp
);
4127 return (struct ada_symbol_info
*) obstack_base (obstackp
);
4130 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
4131 Check the global symbols if GLOBAL, the static symbols if not.
4132 Do wild-card match if WILD. */
4134 static struct partial_symbol
*
4135 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
4136 int global
, domain_enum
namespace, int wild
)
4138 struct partial_symbol
**start
;
4139 int name_len
= strlen (name
);
4140 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
4149 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
4150 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
4154 for (i
= 0; i
< length
; i
+= 1)
4156 struct partial_symbol
*psym
= start
[i
];
4158 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4159 SYMBOL_DOMAIN (psym
), namespace)
4160 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
4174 int M
= (U
+ i
) >> 1;
4175 struct partial_symbol
*psym
= start
[M
];
4176 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
4178 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
4180 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
4191 struct partial_symbol
*psym
= start
[i
];
4193 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4194 SYMBOL_DOMAIN (psym
), namespace))
4196 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
4204 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4218 int M
= (U
+ i
) >> 1;
4219 struct partial_symbol
*psym
= start
[M
];
4220 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
4222 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
4224 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
4235 struct partial_symbol
*psym
= start
[i
];
4237 if (symbol_matches_domain (SYMBOL_LANGUAGE (psym
),
4238 SYMBOL_DOMAIN (psym
), namespace))
4242 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
4245 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
4247 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
4257 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4267 /* Find a symbol table containing symbol SYM or NULL if none. */
4269 static struct symtab
*
4270 symtab_for_sym (struct symbol
*sym
)
4273 struct objfile
*objfile
;
4275 struct symbol
*tmp_sym
;
4276 struct dict_iterator iter
;
4279 ALL_PRIMARY_SYMTABS (objfile
, s
)
4281 switch (SYMBOL_CLASS (sym
))
4289 case LOC_CONST_BYTES
:
4290 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
4291 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4293 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
4294 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4300 switch (SYMBOL_CLASS (sym
))
4305 case LOC_REGPARM_ADDR
:
4309 for (j
= FIRST_LOCAL_BLOCK
;
4310 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
4312 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
4313 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4324 /* Return a minimal symbol matching NAME according to Ada decoding
4325 rules. Returns NULL if there is no such minimal symbol. Names
4326 prefixed with "standard__" are handled specially: "standard__" is
4327 first stripped off, and only static and global symbols are searched. */
4329 struct minimal_symbol
*
4330 ada_lookup_simple_minsym (const char *name
)
4332 struct objfile
*objfile
;
4333 struct minimal_symbol
*msymbol
;
4336 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4338 name
+= sizeof ("standard__") - 1;
4342 wild_match
= (strstr (name
, "__") == NULL
);
4344 ALL_MSYMBOLS (objfile
, msymbol
)
4346 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4347 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4354 /* For all subprograms that statically enclose the subprogram of the
4355 selected frame, add symbols matching identifier NAME in DOMAIN
4356 and their blocks to the list of data in OBSTACKP, as for
4357 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4361 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4362 const char *name
, domain_enum
namespace,
4367 /* True if TYPE is definitely an artificial type supplied to a symbol
4368 for which no debugging information was given in the symbol file. */
4371 is_nondebugging_type (struct type
*type
)
4373 char *name
= ada_type_name (type
);
4374 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4377 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4378 duplicate other symbols in the list (The only case I know of where
4379 this happens is when object files containing stabs-in-ecoff are
4380 linked with files containing ordinary ecoff debugging symbols (or no
4381 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4382 Returns the number of items in the modified list. */
4385 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4394 /* If two symbols have the same name and one of them is a stub type,
4395 the get rid of the stub. */
4397 if (TYPE_STUB (SYMBOL_TYPE (syms
[i
].sym
))
4398 && SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
)
4400 for (j
= 0; j
< nsyms
; j
++)
4403 && !TYPE_STUB (SYMBOL_TYPE (syms
[j
].sym
))
4404 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4405 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4406 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0)
4411 /* Two symbols with the same name, same class and same address
4412 should be identical. */
4414 else if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4415 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4416 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4418 for (j
= 0; j
< nsyms
; j
+= 1)
4421 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4422 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4423 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4424 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4425 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4426 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4433 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4434 syms
[j
- 1] = syms
[j
];
4443 /* Given a type that corresponds to a renaming entity, use the type name
4444 to extract the scope (package name or function name, fully qualified,
4445 and following the GNAT encoding convention) where this renaming has been
4446 defined. The string returned needs to be deallocated after use. */
4449 xget_renaming_scope (struct type
*renaming_type
)
4451 /* The renaming types adhere to the following convention:
4452 <scope>__<rename>___<XR extension>.
4453 So, to extract the scope, we search for the "___XR" extension,
4454 and then backtrack until we find the first "__". */
4456 const char *name
= type_name_no_tag (renaming_type
);
4457 char *suffix
= strstr (name
, "___XR");
4462 /* Now, backtrack a bit until we find the first "__". Start looking
4463 at suffix - 3, as the <rename> part is at least one character long. */
4465 for (last
= suffix
- 3; last
> name
; last
--)
4466 if (last
[0] == '_' && last
[1] == '_')
4469 /* Make a copy of scope and return it. */
4471 scope_len
= last
- name
;
4472 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4474 strncpy (scope
, name
, scope_len
);
4475 scope
[scope_len
] = '\0';
4480 /* Return nonzero if NAME corresponds to a package name. */
4483 is_package_name (const char *name
)
4485 /* Here, We take advantage of the fact that no symbols are generated
4486 for packages, while symbols are generated for each function.
4487 So the condition for NAME represent a package becomes equivalent
4488 to NAME not existing in our list of symbols. There is only one
4489 small complication with library-level functions (see below). */
4493 /* If it is a function that has not been defined at library level,
4494 then we should be able to look it up in the symbols. */
4495 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4498 /* Library-level function names start with "_ada_". See if function
4499 "_ada_" followed by NAME can be found. */
4501 /* Do a quick check that NAME does not contain "__", since library-level
4502 functions names cannot contain "__" in them. */
4503 if (strstr (name
, "__") != NULL
)
4506 fun_name
= xstrprintf ("_ada_%s", name
);
4508 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4511 /* Return nonzero if SYM corresponds to a renaming entity that is
4512 not visible from FUNCTION_NAME. */
4515 old_renaming_is_invisible (const struct symbol
*sym
, char *function_name
)
4519 if (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
)
4522 scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4524 make_cleanup (xfree
, scope
);
4526 /* If the rename has been defined in a package, then it is visible. */
4527 if (is_package_name (scope
))
4530 /* Check that the rename is in the current function scope by checking
4531 that its name starts with SCOPE. */
4533 /* If the function name starts with "_ada_", it means that it is
4534 a library-level function. Strip this prefix before doing the
4535 comparison, as the encoding for the renaming does not contain
4537 if (strncmp (function_name
, "_ada_", 5) == 0)
4540 return (strncmp (function_name
, scope
, strlen (scope
)) != 0);
4543 /* Remove entries from SYMS that corresponds to a renaming entity that
4544 is not visible from the function associated with CURRENT_BLOCK or
4545 that is superfluous due to the presence of more specific renaming
4546 information. Places surviving symbols in the initial entries of
4547 SYMS and returns the number of surviving symbols.
4550 First, in cases where an object renaming is implemented as a
4551 reference variable, GNAT may produce both the actual reference
4552 variable and the renaming encoding. In this case, we discard the
4555 Second, GNAT emits a type following a specified encoding for each renaming
4556 entity. Unfortunately, STABS currently does not support the definition
4557 of types that are local to a given lexical block, so all renamings types
4558 are emitted at library level. As a consequence, if an application
4559 contains two renaming entities using the same name, and a user tries to
4560 print the value of one of these entities, the result of the ada symbol
4561 lookup will also contain the wrong renaming type.
4563 This function partially covers for this limitation by attempting to
4564 remove from the SYMS list renaming symbols that should be visible
4565 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4566 method with the current information available. The implementation
4567 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4569 - When the user tries to print a rename in a function while there
4570 is another rename entity defined in a package: Normally, the
4571 rename in the function has precedence over the rename in the
4572 package, so the latter should be removed from the list. This is
4573 currently not the case.
4575 - This function will incorrectly remove valid renames if
4576 the CURRENT_BLOCK corresponds to a function which symbol name
4577 has been changed by an "Export" pragma. As a consequence,
4578 the user will be unable to print such rename entities. */
4581 remove_irrelevant_renamings (struct ada_symbol_info
*syms
,
4582 int nsyms
, const struct block
*current_block
)
4584 struct symbol
*current_function
;
4585 char *current_function_name
;
4587 int is_new_style_renaming
;
4589 /* If there is both a renaming foo___XR... encoded as a variable and
4590 a simple variable foo in the same block, discard the latter.
4591 First, zero out such symbols, then compress. */
4592 is_new_style_renaming
= 0;
4593 for (i
= 0; i
< nsyms
; i
+= 1)
4595 struct symbol
*sym
= syms
[i
].sym
;
4596 struct block
*block
= syms
[i
].block
;
4600 if (sym
== NULL
|| SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
4602 name
= SYMBOL_LINKAGE_NAME (sym
);
4603 suffix
= strstr (name
, "___XR");
4607 int name_len
= suffix
- name
;
4609 is_new_style_renaming
= 1;
4610 for (j
= 0; j
< nsyms
; j
+= 1)
4611 if (i
!= j
&& syms
[j
].sym
!= NULL
4612 && strncmp (name
, SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
4614 && block
== syms
[j
].block
)
4618 if (is_new_style_renaming
)
4622 for (j
= k
= 0; j
< nsyms
; j
+= 1)
4623 if (syms
[j
].sym
!= NULL
)
4631 /* Extract the function name associated to CURRENT_BLOCK.
4632 Abort if unable to do so. */
4634 if (current_block
== NULL
)
4637 current_function
= block_linkage_function (current_block
);
4638 if (current_function
== NULL
)
4641 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4642 if (current_function_name
== NULL
)
4645 /* Check each of the symbols, and remove it from the list if it is
4646 a type corresponding to a renaming that is out of the scope of
4647 the current block. */
4652 if (ada_parse_renaming (syms
[i
].sym
, NULL
, NULL
, NULL
)
4653 == ADA_OBJECT_RENAMING
4654 && old_renaming_is_invisible (syms
[i
].sym
, current_function_name
))
4657 for (j
= i
+ 1; j
< nsyms
; j
+= 1)
4658 syms
[j
- 1] = syms
[j
];
4668 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
4669 whose name and domain match NAME and DOMAIN respectively.
4670 If no match was found, then extend the search to "enclosing"
4671 routines (in other words, if we're inside a nested function,
4672 search the symbols defined inside the enclosing functions).
4674 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
4677 ada_add_local_symbols (struct obstack
*obstackp
, const char *name
,
4678 struct block
*block
, domain_enum domain
,
4681 int block_depth
= 0;
4683 while (block
!= NULL
)
4686 ada_add_block_symbols (obstackp
, block
, name
, domain
, NULL
, wild_match
);
4688 /* If we found a non-function match, assume that's the one. */
4689 if (is_nonfunction (defns_collected (obstackp
, 0),
4690 num_defns_collected (obstackp
)))
4693 block
= BLOCK_SUPERBLOCK (block
);
4696 /* If no luck so far, try to find NAME as a local symbol in some lexically
4697 enclosing subprogram. */
4698 if (num_defns_collected (obstackp
) == 0 && block_depth
> 2)
4699 add_symbols_from_enclosing_procs (obstackp
, name
, domain
, wild_match
);
4702 /* Add to OBSTACKP all non-local symbols whose name and domain match
4703 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
4704 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
4707 ada_add_non_local_symbols (struct obstack
*obstackp
, const char *name
,
4708 domain_enum domain
, int global
,
4711 struct objfile
*objfile
;
4712 struct partial_symtab
*ps
;
4714 ALL_PSYMTABS (objfile
, ps
)
4718 || ada_lookup_partial_symbol (ps
, name
, global
, domain
, wild_match
))
4720 struct symtab
*s
= PSYMTAB_TO_SYMTAB (ps
);
4721 const int block_kind
= global
? GLOBAL_BLOCK
: STATIC_BLOCK
;
4723 if (s
== NULL
|| !s
->primary
)
4725 ada_add_block_symbols (obstackp
,
4726 BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), block_kind
),
4727 name
, domain
, objfile
, wild_match
);
4732 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4733 scope and in global scopes, returning the number of matches. Sets
4734 *RESULTS to point to a vector of (SYM,BLOCK) tuples,
4735 indicating the symbols found and the blocks and symbol tables (if
4736 any) in which they were found. This vector are transient---good only to
4737 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4738 symbol match within the nest of blocks whose innermost member is BLOCK0,
4739 is the one match returned (no other matches in that or
4740 enclosing blocks is returned). If there are any matches in or
4741 surrounding BLOCK0, then these alone are returned. Otherwise, the
4742 search extends to global and file-scope (static) symbol tables.
4743 Names prefixed with "standard__" are handled specially: "standard__"
4744 is first stripped off, and only static and global symbols are searched. */
4747 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4748 domain_enum
namespace,
4749 struct ada_symbol_info
**results
)
4752 struct block
*block
;
4758 obstack_free (&symbol_list_obstack
, NULL
);
4759 obstack_init (&symbol_list_obstack
);
4763 /* Search specified block and its superiors. */
4765 wild_match
= (strstr (name0
, "__") == NULL
);
4767 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4768 needed, but adding const will
4769 have a cascade effect. */
4771 /* Special case: If the user specifies a symbol name inside package
4772 Standard, do a non-wild matching of the symbol name without
4773 the "standard__" prefix. This was primarily introduced in order
4774 to allow the user to specifically access the standard exceptions
4775 using, for instance, Standard.Constraint_Error when Constraint_Error
4776 is ambiguous (due to the user defining its own Constraint_Error
4777 entity inside its program). */
4778 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4782 name
= name0
+ sizeof ("standard__") - 1;
4785 /* Check the non-global symbols. If we have ANY match, then we're done. */
4787 ada_add_local_symbols (&symbol_list_obstack
, name
, block
, namespace,
4789 if (num_defns_collected (&symbol_list_obstack
) > 0)
4792 /* No non-global symbols found. Check our cache to see if we have
4793 already performed this search before. If we have, then return
4797 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
))
4800 add_defn_to_vec (&symbol_list_obstack
, sym
, block
);
4804 /* Search symbols from all global blocks. */
4806 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 1,
4809 /* Now add symbols from all per-file blocks if we've gotten no hits
4810 (not strictly correct, but perhaps better than an error). */
4812 if (num_defns_collected (&symbol_list_obstack
) == 0)
4813 ada_add_non_local_symbols (&symbol_list_obstack
, name
, namespace, 0,
4817 ndefns
= num_defns_collected (&symbol_list_obstack
);
4818 *results
= defns_collected (&symbol_list_obstack
, 1);
4820 ndefns
= remove_extra_symbols (*results
, ndefns
);
4823 cache_symbol (name0
, namespace, NULL
, NULL
);
4825 if (ndefns
== 1 && cacheIfUnique
)
4826 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
);
4828 ndefns
= remove_irrelevant_renamings (*results
, ndefns
, block0
);
4834 ada_lookup_encoded_symbol (const char *name
, const struct block
*block0
,
4835 domain_enum
namespace, struct block
**block_found
)
4837 struct ada_symbol_info
*candidates
;
4840 n_candidates
= ada_lookup_symbol_list (name
, block0
, namespace, &candidates
);
4842 if (n_candidates
== 0)
4845 if (block_found
!= NULL
)
4846 *block_found
= candidates
[0].block
;
4848 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4851 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4852 scope and in global scopes, or NULL if none. NAME is folded and
4853 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4854 choosing the first symbol if there are multiple choices.
4855 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4856 table in which the symbol was found (in both cases, these
4857 assignments occur only if the pointers are non-null). */
4859 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4860 domain_enum
namespace, int *is_a_field_of_this
)
4862 if (is_a_field_of_this
!= NULL
)
4863 *is_a_field_of_this
= 0;
4866 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name
)),
4867 block0
, namespace, NULL
);
4870 static struct symbol
*
4871 ada_lookup_symbol_nonlocal (const char *name
,
4872 const char *linkage_name
,
4873 const struct block
*block
,
4874 const domain_enum domain
)
4876 if (linkage_name
== NULL
)
4877 linkage_name
= name
;
4878 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4883 /* True iff STR is a possible encoded suffix of a normal Ada name
4884 that is to be ignored for matching purposes. Suffixes of parallel
4885 names (e.g., XVE) are not included here. Currently, the possible suffixes
4886 are given by any of the regular expressions:
4888 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
4889 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4890 _E[0-9]+[bs]$ [protected object entry suffixes]
4891 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4893 Also, any leading "__[0-9]+" sequence is skipped before the suffix
4894 match is performed. This sequence is used to differentiate homonyms,
4895 is an optional part of a valid name suffix. */
4898 is_name_suffix (const char *str
)
4901 const char *matching
;
4902 const int len
= strlen (str
);
4904 /* Skip optional leading __[0-9]+. */
4906 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4909 while (isdigit (str
[0]))
4915 if (str
[0] == '.' || str
[0] == '$')
4918 while (isdigit (matching
[0]))
4920 if (matching
[0] == '\0')
4926 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4929 while (isdigit (matching
[0]))
4931 if (matching
[0] == '\0')
4936 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4937 with a N at the end. Unfortunately, the compiler uses the same
4938 convention for other internal types it creates. So treating
4939 all entity names that end with an "N" as a name suffix causes
4940 some regressions. For instance, consider the case of an enumerated
4941 type. To support the 'Image attribute, it creates an array whose
4943 Having a single character like this as a suffix carrying some
4944 information is a bit risky. Perhaps we should change the encoding
4945 to be something like "_N" instead. In the meantime, do not do
4946 the following check. */
4947 /* Protected Object Subprograms */
4948 if (len
== 1 && str
[0] == 'N')
4953 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
4956 while (isdigit (matching
[0]))
4958 if ((matching
[0] == 'b' || matching
[0] == 's')
4959 && matching
[1] == '\0')
4963 /* ??? We should not modify STR directly, as we are doing below. This
4964 is fine in this case, but may become problematic later if we find
4965 that this alternative did not work, and want to try matching
4966 another one from the begining of STR. Since we modified it, we
4967 won't be able to find the begining of the string anymore! */
4971 while (str
[0] != '_' && str
[0] != '\0')
4973 if (str
[0] != 'n' && str
[0] != 'b')
4979 if (str
[0] == '\000')
4984 if (str
[1] != '_' || str
[2] == '\000')
4988 if (strcmp (str
+ 3, "JM") == 0)
4990 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4991 the LJM suffix in favor of the JM one. But we will
4992 still accept LJM as a valid suffix for a reasonable
4993 amount of time, just to allow ourselves to debug programs
4994 compiled using an older version of GNAT. */
4995 if (strcmp (str
+ 3, "LJM") == 0)
4999 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
5000 || str
[4] == 'U' || str
[4] == 'P')
5002 if (str
[4] == 'R' && str
[5] != 'T')
5006 if (!isdigit (str
[2]))
5008 for (k
= 3; str
[k
] != '\0'; k
+= 1)
5009 if (!isdigit (str
[k
]) && str
[k
] != '_')
5013 if (str
[0] == '$' && isdigit (str
[1]))
5015 for (k
= 2; str
[k
] != '\0'; k
+= 1)
5016 if (!isdigit (str
[k
]) && str
[k
] != '_')
5023 /* Return non-zero if the string starting at NAME and ending before
5024 NAME_END contains no capital letters. */
5027 is_valid_name_for_wild_match (const char *name0
)
5029 const char *decoded_name
= ada_decode (name0
);
5032 /* If the decoded name starts with an angle bracket, it means that
5033 NAME0 does not follow the GNAT encoding format. It should then
5034 not be allowed as a possible wild match. */
5035 if (decoded_name
[0] == '<')
5038 for (i
=0; decoded_name
[i
] != '\0'; i
++)
5039 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
5045 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
5046 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
5047 informational suffixes of NAME (i.e., for which is_name_suffix is
5051 wild_match (const char *patn0
, int patn_len
, const char *name0
)
5058 match
= strstr (start
, patn0
);
5063 || (match
> name0
+ 1 && match
[-1] == '_' && match
[-2] == '_')
5064 || (match
== name0
+ 5 && strncmp ("_ada_", name0
, 5) == 0))
5065 && is_name_suffix (match
+ patn_len
))
5066 return (match
== name0
|| is_valid_name_for_wild_match (name0
));
5072 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5073 vector *defn_symbols, updating the list of symbols in OBSTACKP
5074 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5075 OBJFILE is the section containing BLOCK.
5076 SYMTAB is recorded with each symbol added. */
5079 ada_add_block_symbols (struct obstack
*obstackp
,
5080 struct block
*block
, const char *name
,
5081 domain_enum domain
, struct objfile
*objfile
,
5084 struct dict_iterator iter
;
5085 int name_len
= strlen (name
);
5086 /* A matching argument symbol, if any. */
5087 struct symbol
*arg_sym
;
5088 /* Set true when we find a matching non-argument symbol. */
5097 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5099 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5100 SYMBOL_DOMAIN (sym
), domain
)
5101 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
5103 if (SYMBOL_CLASS (sym
) == LOC_UNRESOLVED
)
5105 else if (SYMBOL_IS_ARGUMENT (sym
))
5110 add_defn_to_vec (obstackp
,
5111 fixup_symbol_section (sym
, objfile
),
5119 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5121 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5122 SYMBOL_DOMAIN (sym
), domain
))
5124 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
5126 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5128 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5130 if (SYMBOL_IS_ARGUMENT (sym
))
5135 add_defn_to_vec (obstackp
,
5136 fixup_symbol_section (sym
, objfile
),
5145 if (!found_sym
&& arg_sym
!= NULL
)
5147 add_defn_to_vec (obstackp
,
5148 fixup_symbol_section (arg_sym
, objfile
),
5157 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5159 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym
),
5160 SYMBOL_DOMAIN (sym
), domain
))
5164 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5167 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5169 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5174 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5176 if (SYMBOL_CLASS (sym
) != LOC_UNRESOLVED
)
5178 if (SYMBOL_IS_ARGUMENT (sym
))
5183 add_defn_to_vec (obstackp
,
5184 fixup_symbol_section (sym
, objfile
),
5192 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5193 They aren't parameters, right? */
5194 if (!found_sym
&& arg_sym
!= NULL
)
5196 add_defn_to_vec (obstackp
,
5197 fixup_symbol_section (arg_sym
, objfile
),
5204 /* Symbol Completion */
5206 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5207 name in a form that's appropriate for the completion. The result
5208 does not need to be deallocated, but is only good until the next call.
5210 TEXT_LEN is equal to the length of TEXT.
5211 Perform a wild match if WILD_MATCH is set.
5212 ENCODED should be set if TEXT represents the start of a symbol name
5213 in its encoded form. */
5216 symbol_completion_match (const char *sym_name
,
5217 const char *text
, int text_len
,
5218 int wild_match
, int encoded
)
5221 const int verbatim_match
= (text
[0] == '<');
5226 /* Strip the leading angle bracket. */
5231 /* First, test against the fully qualified name of the symbol. */
5233 if (strncmp (sym_name
, text
, text_len
) == 0)
5236 if (match
&& !encoded
)
5238 /* One needed check before declaring a positive match is to verify
5239 that iff we are doing a verbatim match, the decoded version
5240 of the symbol name starts with '<'. Otherwise, this symbol name
5241 is not a suitable completion. */
5242 const char *sym_name_copy
= sym_name
;
5243 int has_angle_bracket
;
5245 sym_name
= ada_decode (sym_name
);
5246 has_angle_bracket
= (sym_name
[0] == '<');
5247 match
= (has_angle_bracket
== verbatim_match
);
5248 sym_name
= sym_name_copy
;
5251 if (match
&& !verbatim_match
)
5253 /* When doing non-verbatim match, another check that needs to
5254 be done is to verify that the potentially matching symbol name
5255 does not include capital letters, because the ada-mode would
5256 not be able to understand these symbol names without the
5257 angle bracket notation. */
5260 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
5265 /* Second: Try wild matching... */
5267 if (!match
&& wild_match
)
5269 /* Since we are doing wild matching, this means that TEXT
5270 may represent an unqualified symbol name. We therefore must
5271 also compare TEXT against the unqualified name of the symbol. */
5272 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
5274 if (strncmp (sym_name
, text
, text_len
) == 0)
5278 /* Finally: If we found a mach, prepare the result to return. */
5284 sym_name
= add_angle_brackets (sym_name
);
5287 sym_name
= ada_decode (sym_name
);
5292 typedef char *char_ptr
;
5293 DEF_VEC_P (char_ptr
);
5295 /* A companion function to ada_make_symbol_completion_list().
5296 Check if SYM_NAME represents a symbol which name would be suitable
5297 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5298 it is appended at the end of the given string vector SV.
5300 ORIG_TEXT is the string original string from the user command
5301 that needs to be completed. WORD is the entire command on which
5302 completion should be performed. These two parameters are used to
5303 determine which part of the symbol name should be added to the
5305 if WILD_MATCH is set, then wild matching is performed.
5306 ENCODED should be set if TEXT represents a symbol name in its
5307 encoded formed (in which case the completion should also be
5311 symbol_completion_add (VEC(char_ptr
) **sv
,
5312 const char *sym_name
,
5313 const char *text
, int text_len
,
5314 const char *orig_text
, const char *word
,
5315 int wild_match
, int encoded
)
5317 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
5318 wild_match
, encoded
);
5324 /* We found a match, so add the appropriate completion to the given
5327 if (word
== orig_text
)
5329 completion
= xmalloc (strlen (match
) + 5);
5330 strcpy (completion
, match
);
5332 else if (word
> orig_text
)
5334 /* Return some portion of sym_name. */
5335 completion
= xmalloc (strlen (match
) + 5);
5336 strcpy (completion
, match
+ (word
- orig_text
));
5340 /* Return some of ORIG_TEXT plus sym_name. */
5341 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
5342 strncpy (completion
, word
, orig_text
- word
);
5343 completion
[orig_text
- word
] = '\0';
5344 strcat (completion
, match
);
5347 VEC_safe_push (char_ptr
, *sv
, completion
);
5350 /* Return a list of possible symbol names completing TEXT0. The list
5351 is NULL terminated. WORD is the entire command on which completion
5355 ada_make_symbol_completion_list (char *text0
, char *word
)
5361 VEC(char_ptr
) *completions
= VEC_alloc (char_ptr
, 128);
5364 struct partial_symtab
*ps
;
5365 struct minimal_symbol
*msymbol
;
5366 struct objfile
*objfile
;
5367 struct block
*b
, *surrounding_static_block
= 0;
5369 struct dict_iterator iter
;
5371 if (text0
[0] == '<')
5373 text
= xstrdup (text0
);
5374 make_cleanup (xfree
, text
);
5375 text_len
= strlen (text
);
5381 text
= xstrdup (ada_encode (text0
));
5382 make_cleanup (xfree
, text
);
5383 text_len
= strlen (text
);
5384 for (i
= 0; i
< text_len
; i
++)
5385 text
[i
] = tolower (text
[i
]);
5387 encoded
= (strstr (text0
, "__") != NULL
);
5388 /* If the name contains a ".", then the user is entering a fully
5389 qualified entity name, and the match must not be done in wild
5390 mode. Similarly, if the user wants to complete what looks like
5391 an encoded name, the match must not be done in wild mode. */
5392 wild_match
= (strchr (text0
, '.') == NULL
&& !encoded
);
5395 /* First, look at the partial symtab symbols. */
5396 ALL_PSYMTABS (objfile
, ps
)
5398 struct partial_symbol
**psym
;
5400 /* If the psymtab's been read in we'll get it when we search
5401 through the blockvector. */
5405 for (psym
= objfile
->global_psymbols
.list
+ ps
->globals_offset
;
5406 psym
< (objfile
->global_psymbols
.list
+ ps
->globals_offset
5407 + ps
->n_global_syms
); psym
++)
5410 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (*psym
),
5411 text
, text_len
, text0
, word
,
5412 wild_match
, encoded
);
5415 for (psym
= objfile
->static_psymbols
.list
+ ps
->statics_offset
;
5416 psym
< (objfile
->static_psymbols
.list
+ ps
->statics_offset
5417 + ps
->n_static_syms
); psym
++)
5420 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (*psym
),
5421 text
, text_len
, text0
, word
,
5422 wild_match
, encoded
);
5426 /* At this point scan through the misc symbol vectors and add each
5427 symbol you find to the list. Eventually we want to ignore
5428 anything that isn't a text symbol (everything else will be
5429 handled by the psymtab code above). */
5431 ALL_MSYMBOLS (objfile
, msymbol
)
5434 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (msymbol
),
5435 text
, text_len
, text0
, word
, wild_match
, encoded
);
5438 /* Search upwards from currently selected frame (so that we can
5439 complete on local vars. */
5441 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
5443 if (!BLOCK_SUPERBLOCK (b
))
5444 surrounding_static_block
= b
; /* For elmin of dups */
5446 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5448 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5449 text
, text_len
, text0
, word
,
5450 wild_match
, encoded
);
5454 /* Go through the symtabs and check the externs and statics for
5455 symbols which match. */
5457 ALL_SYMTABS (objfile
, s
)
5460 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
5461 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5463 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5464 text
, text_len
, text0
, word
,
5465 wild_match
, encoded
);
5469 ALL_SYMTABS (objfile
, s
)
5472 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
5473 /* Don't do this block twice. */
5474 if (b
== surrounding_static_block
)
5476 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5478 symbol_completion_add (&completions
, SYMBOL_LINKAGE_NAME (sym
),
5479 text
, text_len
, text0
, word
,
5480 wild_match
, encoded
);
5484 /* Append the closing NULL entry. */
5485 VEC_safe_push (char_ptr
, completions
, NULL
);
5487 /* Make a copy of the COMPLETIONS VEC before we free it, and then
5488 return the copy. It's unfortunate that we have to make a copy
5489 of an array that we're about to destroy, but there is nothing much
5490 we can do about it. Fortunately, it's typically not a very large
5493 const size_t completions_size
=
5494 VEC_length (char_ptr
, completions
) * sizeof (char *);
5495 char **result
= malloc (completions_size
);
5497 memcpy (result
, VEC_address (char_ptr
, completions
), completions_size
);
5499 VEC_free (char_ptr
, completions
);
5506 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
5507 for tagged types. */
5510 ada_is_dispatch_table_ptr_type (struct type
*type
)
5514 if (TYPE_CODE (type
) != TYPE_CODE_PTR
)
5517 name
= TYPE_NAME (TYPE_TARGET_TYPE (type
));
5521 return (strcmp (name
, "ada__tags__dispatch_table") == 0);
5524 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5525 to be invisible to users. */
5528 ada_is_ignored_field (struct type
*type
, int field_num
)
5530 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5533 /* Check the name of that field. */
5535 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5537 /* Anonymous field names should not be printed.
5538 brobecker/2007-02-20: I don't think this can actually happen
5539 but we don't want to print the value of annonymous fields anyway. */
5543 /* A field named "_parent" is internally generated by GNAT for
5544 tagged types, and should not be printed either. */
5545 if (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0)
5549 /* If this is the dispatch table of a tagged type, then ignore. */
5550 if (ada_is_tagged_type (type
, 1)
5551 && ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type
, field_num
)))
5554 /* Not a special field, so it should not be ignored. */
5558 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5559 pointer or reference type whose ultimate target has a tag field. */
5562 ada_is_tagged_type (struct type
*type
, int refok
)
5564 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
5567 /* True iff TYPE represents the type of X'Tag */
5570 ada_is_tag_type (struct type
*type
)
5572 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
5576 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
5577 return (name
!= NULL
5578 && strcmp (name
, "ada__tags__dispatch_table") == 0);
5582 /* The type of the tag on VAL. */
5585 ada_tag_type (struct value
*val
)
5587 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
5590 /* The value of the tag on VAL. */
5593 ada_value_tag (struct value
*val
)
5595 return ada_value_struct_elt (val
, "_tag", 0);
5598 /* The value of the tag on the object of type TYPE whose contents are
5599 saved at VALADDR, if it is non-null, or is at memory address
5602 static struct value
*
5603 value_tag_from_contents_and_address (struct type
*type
,
5604 const gdb_byte
*valaddr
,
5607 int tag_byte_offset
, dummy1
, dummy2
;
5608 struct type
*tag_type
;
5609 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5612 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
5614 : valaddr
+ tag_byte_offset
);
5615 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5617 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5622 static struct type
*
5623 type_from_tag (struct value
*tag
)
5625 const char *type_name
= ada_tag_name (tag
);
5626 if (type_name
!= NULL
)
5627 return ada_find_any_type (ada_encode (type_name
));
5638 static int ada_tag_name_1 (void *);
5639 static int ada_tag_name_2 (struct tag_args
*);
5641 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5642 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5643 The value stored in ARGS->name is valid until the next call to
5647 ada_tag_name_1 (void *args0
)
5649 struct tag_args
*args
= (struct tag_args
*) args0
;
5650 static char name
[1024];
5654 val
= ada_value_struct_elt (args
->tag
, "tsd", 1);
5656 return ada_tag_name_2 (args
);
5657 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5660 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5661 for (p
= name
; *p
!= '\0'; p
+= 1)
5668 /* Utility function for ada_tag_name_1 that tries the second
5669 representation for the dispatch table (in which there is no
5670 explicit 'tsd' field in the referent of the tag pointer, and instead
5671 the tsd pointer is stored just before the dispatch table. */
5674 ada_tag_name_2 (struct tag_args
*args
)
5676 struct type
*info_type
;
5677 static char name
[1024];
5679 struct value
*val
, *valp
;
5682 info_type
= ada_find_any_type ("ada__tags__type_specific_data");
5683 if (info_type
== NULL
)
5685 info_type
= lookup_pointer_type (lookup_pointer_type (info_type
));
5686 valp
= value_cast (info_type
, args
->tag
);
5689 val
= value_ind (value_ptradd (valp
,
5690 value_from_longest (builtin_type_int8
, -1)));
5693 val
= ada_value_struct_elt (val
, "expanded_name", 1);
5696 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5697 for (p
= name
; *p
!= '\0'; p
+= 1)
5704 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5708 ada_tag_name (struct value
*tag
)
5710 struct tag_args args
;
5711 if (!ada_is_tag_type (value_type (tag
)))
5715 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5719 /* The parent type of TYPE, or NULL if none. */
5722 ada_parent_type (struct type
*type
)
5726 type
= ada_check_typedef (type
);
5728 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5731 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5732 if (ada_is_parent_field (type
, i
))
5734 struct type
*parent_type
= TYPE_FIELD_TYPE (type
, i
);
5736 /* If the _parent field is a pointer, then dereference it. */
5737 if (TYPE_CODE (parent_type
) == TYPE_CODE_PTR
)
5738 parent_type
= TYPE_TARGET_TYPE (parent_type
);
5739 /* If there is a parallel XVS type, get the actual base type. */
5740 parent_type
= ada_get_base_type (parent_type
);
5742 return ada_check_typedef (parent_type
);
5748 /* True iff field number FIELD_NUM of structure type TYPE contains the
5749 parent-type (inherited) fields of a derived type. Assumes TYPE is
5750 a structure type with at least FIELD_NUM+1 fields. */
5753 ada_is_parent_field (struct type
*type
, int field_num
)
5755 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5756 return (name
!= NULL
5757 && (strncmp (name
, "PARENT", 6) == 0
5758 || strncmp (name
, "_parent", 7) == 0));
5761 /* True iff field number FIELD_NUM of structure type TYPE is a
5762 transparent wrapper field (which should be silently traversed when doing
5763 field selection and flattened when printing). Assumes TYPE is a
5764 structure type with at least FIELD_NUM+1 fields. Such fields are always
5768 ada_is_wrapper_field (struct type
*type
, int field_num
)
5770 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5771 return (name
!= NULL
5772 && (strncmp (name
, "PARENT", 6) == 0
5773 || strcmp (name
, "REP") == 0
5774 || strncmp (name
, "_parent", 7) == 0
5775 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5778 /* True iff field number FIELD_NUM of structure or union type TYPE
5779 is a variant wrapper. Assumes TYPE is a structure type with at least
5780 FIELD_NUM+1 fields. */
5783 ada_is_variant_part (struct type
*type
, int field_num
)
5785 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5786 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5787 || (is_dynamic_field (type
, field_num
)
5788 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5789 == TYPE_CODE_UNION
)));
5792 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5793 whose discriminants are contained in the record type OUTER_TYPE,
5794 returns the type of the controlling discriminant for the variant. */
5797 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5799 char *name
= ada_variant_discrim_name (var_type
);
5801 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5803 return builtin_type_int32
;
5808 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5809 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5810 represents a 'when others' clause; otherwise 0. */
5813 ada_is_others_clause (struct type
*type
, int field_num
)
5815 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5816 return (name
!= NULL
&& name
[0] == 'O');
5819 /* Assuming that TYPE0 is the type of the variant part of a record,
5820 returns the name of the discriminant controlling the variant.
5821 The value is valid until the next call to ada_variant_discrim_name. */
5824 ada_variant_discrim_name (struct type
*type0
)
5826 static char *result
= NULL
;
5827 static size_t result_len
= 0;
5830 const char *discrim_end
;
5831 const char *discrim_start
;
5833 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5834 type
= TYPE_TARGET_TYPE (type0
);
5838 name
= ada_type_name (type
);
5840 if (name
== NULL
|| name
[0] == '\000')
5843 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5846 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5849 if (discrim_end
== name
)
5852 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5855 if (discrim_start
== name
+ 1)
5857 if ((discrim_start
> name
+ 3
5858 && strncmp (discrim_start
- 3, "___", 3) == 0)
5859 || discrim_start
[-1] == '.')
5863 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5864 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5865 result
[discrim_end
- discrim_start
] = '\0';
5869 /* Scan STR for a subtype-encoded number, beginning at position K.
5870 Put the position of the character just past the number scanned in
5871 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5872 Return 1 if there was a valid number at the given position, and 0
5873 otherwise. A "subtype-encoded" number consists of the absolute value
5874 in decimal, followed by the letter 'm' to indicate a negative number.
5875 Assumes 0m does not occur. */
5878 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5882 if (!isdigit (str
[k
]))
5885 /* Do it the hard way so as not to make any assumption about
5886 the relationship of unsigned long (%lu scan format code) and
5889 while (isdigit (str
[k
]))
5891 RU
= RU
* 10 + (str
[k
] - '0');
5898 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5904 /* NOTE on the above: Technically, C does not say what the results of
5905 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5906 number representable as a LONGEST (although either would probably work
5907 in most implementations). When RU>0, the locution in the then branch
5908 above is always equivalent to the negative of RU. */
5915 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5916 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5917 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5920 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5922 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5935 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5944 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5945 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5947 if (val
>= L
&& val
<= U
)
5959 /* FIXME: Lots of redundancy below. Try to consolidate. */
5961 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5962 ARG_TYPE, extract and return the value of one of its (non-static)
5963 fields. FIELDNO says which field. Differs from value_primitive_field
5964 only in that it can handle packed values of arbitrary type. */
5966 static struct value
*
5967 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5968 struct type
*arg_type
)
5972 arg_type
= ada_check_typedef (arg_type
);
5973 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5975 /* Handle packed fields. */
5977 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5979 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5980 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5982 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
5983 offset
+ bit_pos
/ 8,
5984 bit_pos
% 8, bit_size
, type
);
5987 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5990 /* Find field with name NAME in object of type TYPE. If found,
5991 set the following for each argument that is non-null:
5992 - *FIELD_TYPE_P to the field's type;
5993 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
5994 an object of that type;
5995 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
5996 - *BIT_SIZE_P to its size in bits if the field is packed, and
5998 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
5999 fields up to but not including the desired field, or by the total
6000 number of fields if not found. A NULL value of NAME never
6001 matches; the function just counts visible fields in this case.
6003 Returns 1 if found, 0 otherwise. */
6006 find_struct_field (char *name
, struct type
*type
, int offset
,
6007 struct type
**field_type_p
,
6008 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
,
6013 type
= ada_check_typedef (type
);
6015 if (field_type_p
!= NULL
)
6016 *field_type_p
= NULL
;
6017 if (byte_offset_p
!= NULL
)
6019 if (bit_offset_p
!= NULL
)
6021 if (bit_size_p
!= NULL
)
6024 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6026 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6027 int fld_offset
= offset
+ bit_pos
/ 8;
6028 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6030 if (t_field_name
== NULL
)
6033 else if (name
!= NULL
&& field_name_match (t_field_name
, name
))
6035 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6036 if (field_type_p
!= NULL
)
6037 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6038 if (byte_offset_p
!= NULL
)
6039 *byte_offset_p
= fld_offset
;
6040 if (bit_offset_p
!= NULL
)
6041 *bit_offset_p
= bit_pos
% 8;
6042 if (bit_size_p
!= NULL
)
6043 *bit_size_p
= bit_size
;
6046 else if (ada_is_wrapper_field (type
, i
))
6048 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6049 field_type_p
, byte_offset_p
, bit_offset_p
,
6050 bit_size_p
, index_p
))
6053 else if (ada_is_variant_part (type
, i
))
6055 /* PNH: Wait. Do we ever execute this section, or is ARG always of
6058 struct type
*field_type
6059 = ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6061 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6063 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
6065 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6066 field_type_p
, byte_offset_p
,
6067 bit_offset_p
, bit_size_p
, index_p
))
6071 else if (index_p
!= NULL
)
6077 /* Number of user-visible fields in record type TYPE. */
6080 num_visible_fields (struct type
*type
)
6084 find_struct_field (NULL
, type
, 0, NULL
, NULL
, NULL
, NULL
, &n
);
6088 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6089 and search in it assuming it has (class) type TYPE.
6090 If found, return value, else return NULL.
6092 Searches recursively through wrapper fields (e.g., '_parent'). */
6094 static struct value
*
6095 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
6099 type
= ada_check_typedef (type
);
6101 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6103 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6105 if (t_field_name
== NULL
)
6108 else if (field_name_match (t_field_name
, name
))
6109 return ada_value_primitive_field (arg
, offset
, i
, type
);
6111 else if (ada_is_wrapper_field (type
, i
))
6113 struct value
*v
= /* Do not let indent join lines here. */
6114 ada_search_struct_field (name
, arg
,
6115 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6116 TYPE_FIELD_TYPE (type
, i
));
6121 else if (ada_is_variant_part (type
, i
))
6123 /* PNH: Do we ever get here? See find_struct_field. */
6125 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6126 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6128 for (j
= 0; j
< TYPE_NFIELDS (field_type
); j
+= 1)
6130 struct value
*v
= ada_search_struct_field
/* Force line break. */
6132 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6133 TYPE_FIELD_TYPE (field_type
, j
));
6142 static struct value
*ada_index_struct_field_1 (int *, struct value
*,
6143 int, struct type
*);
6146 /* Return field #INDEX in ARG, where the index is that returned by
6147 * find_struct_field through its INDEX_P argument. Adjust the address
6148 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
6149 * If found, return value, else return NULL. */
6151 static struct value
*
6152 ada_index_struct_field (int index
, struct value
*arg
, int offset
,
6155 return ada_index_struct_field_1 (&index
, arg
, offset
, type
);
6159 /* Auxiliary function for ada_index_struct_field. Like
6160 * ada_index_struct_field, but takes index from *INDEX_P and modifies
6163 static struct value
*
6164 ada_index_struct_field_1 (int *index_p
, struct value
*arg
, int offset
,
6168 type
= ada_check_typedef (type
);
6170 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6172 if (TYPE_FIELD_NAME (type
, i
) == NULL
)
6174 else if (ada_is_wrapper_field (type
, i
))
6176 struct value
*v
= /* Do not let indent join lines here. */
6177 ada_index_struct_field_1 (index_p
, arg
,
6178 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6179 TYPE_FIELD_TYPE (type
, i
));
6184 else if (ada_is_variant_part (type
, i
))
6186 /* PNH: Do we ever get here? See ada_search_struct_field,
6187 find_struct_field. */
6188 error (_("Cannot assign this kind of variant record"));
6190 else if (*index_p
== 0)
6191 return ada_value_primitive_field (arg
, offset
, i
, type
);
6198 /* Given ARG, a value of type (pointer or reference to a)*
6199 structure/union, extract the component named NAME from the ultimate
6200 target structure/union and return it as a value with its
6201 appropriate type. If ARG is a pointer or reference and the field
6202 is not packed, returns a reference to the field, otherwise the
6203 value of the field (an lvalue if ARG is an lvalue).
6205 The routine searches for NAME among all members of the structure itself
6206 and (recursively) among all members of any wrapper members
6209 If NO_ERR, then simply return NULL in case of error, rather than
6213 ada_value_struct_elt (struct value
*arg
, char *name
, int no_err
)
6215 struct type
*t
, *t1
;
6219 t1
= t
= ada_check_typedef (value_type (arg
));
6220 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6222 t1
= TYPE_TARGET_TYPE (t
);
6225 t1
= ada_check_typedef (t1
);
6226 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6228 arg
= coerce_ref (arg
);
6233 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6235 t1
= TYPE_TARGET_TYPE (t
);
6238 t1
= ada_check_typedef (t1
);
6239 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
6241 arg
= value_ind (arg
);
6248 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
6252 v
= ada_search_struct_field (name
, arg
, 0, t
);
6255 int bit_offset
, bit_size
, byte_offset
;
6256 struct type
*field_type
;
6259 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
6260 address
= value_as_address (arg
);
6262 address
= unpack_pointer (t
, value_contents (arg
));
6264 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
, 1);
6265 if (find_struct_field (name
, t1
, 0,
6266 &field_type
, &byte_offset
, &bit_offset
,
6271 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
6272 arg
= ada_coerce_ref (arg
);
6274 arg
= ada_value_ind (arg
);
6275 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
6276 bit_offset
, bit_size
,
6280 v
= value_from_pointer (lookup_reference_type (field_type
),
6281 address
+ byte_offset
);
6285 if (v
!= NULL
|| no_err
)
6288 error (_("There is no member named %s."), name
);
6294 error (_("Attempt to extract a component of a value that is not a record."));
6297 /* Given a type TYPE, look up the type of the component of type named NAME.
6298 If DISPP is non-null, add its byte displacement from the beginning of a
6299 structure (pointed to by a value) of type TYPE to *DISPP (does not
6300 work for packed fields).
6302 Matches any field whose name has NAME as a prefix, possibly
6305 TYPE can be either a struct or union. If REFOK, TYPE may also
6306 be a (pointer or reference)+ to a struct or union, and the
6307 ultimate target type will be searched.
6309 Looks recursively into variant clauses and parent types.
6311 If NOERR is nonzero, return NULL if NAME is not suitably defined or
6312 TYPE is not a type of the right kind. */
6314 static struct type
*
6315 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
6316 int noerr
, int *dispp
)
6323 if (refok
&& type
!= NULL
)
6326 type
= ada_check_typedef (type
);
6327 if (TYPE_CODE (type
) != TYPE_CODE_PTR
6328 && TYPE_CODE (type
) != TYPE_CODE_REF
)
6330 type
= TYPE_TARGET_TYPE (type
);
6334 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
6335 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
6341 target_terminal_ours ();
6342 gdb_flush (gdb_stdout
);
6344 error (_("Type (null) is not a structure or union type"));
6347 /* XXX: type_sprint */
6348 fprintf_unfiltered (gdb_stderr
, _("Type "));
6349 type_print (type
, "", gdb_stderr
, -1);
6350 error (_(" is not a structure or union type"));
6355 type
= to_static_fixed_type (type
);
6357 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6359 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6363 if (t_field_name
== NULL
)
6366 else if (field_name_match (t_field_name
, name
))
6369 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
6370 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6373 else if (ada_is_wrapper_field (type
, i
))
6376 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
6381 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6386 else if (ada_is_variant_part (type
, i
))
6389 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
6391 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
6393 /* FIXME pnh 2008/01/26: We check for a field that is
6394 NOT wrapped in a struct, since the compiler sometimes
6395 generates these for unchecked variant types. Revisit
6396 if the compiler changes this practice. */
6397 char *v_field_name
= TYPE_FIELD_NAME (field_type
, j
);
6399 if (v_field_name
!= NULL
6400 && field_name_match (v_field_name
, name
))
6401 t
= ada_check_typedef (TYPE_FIELD_TYPE (field_type
, j
));
6403 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
6409 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
6420 target_terminal_ours ();
6421 gdb_flush (gdb_stdout
);
6424 /* XXX: type_sprint */
6425 fprintf_unfiltered (gdb_stderr
, _("Type "));
6426 type_print (type
, "", gdb_stderr
, -1);
6427 error (_(" has no component named <null>"));
6431 /* XXX: type_sprint */
6432 fprintf_unfiltered (gdb_stderr
, _("Type "));
6433 type_print (type
, "", gdb_stderr
, -1);
6434 error (_(" has no component named %s"), name
);
6441 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6442 within a value of type OUTER_TYPE, return true iff VAR_TYPE
6443 represents an unchecked union (that is, the variant part of a
6444 record that is named in an Unchecked_Union pragma). */
6447 is_unchecked_variant (struct type
*var_type
, struct type
*outer_type
)
6449 char *discrim_name
= ada_variant_discrim_name (var_type
);
6450 return (ada_lookup_struct_elt_type (outer_type
, discrim_name
, 0, 1, NULL
)
6455 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
6456 within a value of type OUTER_TYPE that is stored in GDB at
6457 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
6458 numbering from 0) is applicable. Returns -1 if none are. */
6461 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
6462 const gdb_byte
*outer_valaddr
)
6466 char *discrim_name
= ada_variant_discrim_name (var_type
);
6467 struct value
*outer
;
6468 struct value
*discrim
;
6469 LONGEST discrim_val
;
6471 outer
= value_from_contents_and_address (outer_type
, outer_valaddr
, 0);
6472 discrim
= ada_value_struct_elt (outer
, discrim_name
, 1);
6473 if (discrim
== NULL
)
6475 discrim_val
= value_as_long (discrim
);
6478 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
6480 if (ada_is_others_clause (var_type
, i
))
6482 else if (ada_in_variant (discrim_val
, var_type
, i
))
6486 return others_clause
;
6491 /* Dynamic-Sized Records */
6493 /* Strategy: The type ostensibly attached to a value with dynamic size
6494 (i.e., a size that is not statically recorded in the debugging
6495 data) does not accurately reflect the size or layout of the value.
6496 Our strategy is to convert these values to values with accurate,
6497 conventional types that are constructed on the fly. */
6499 /* There is a subtle and tricky problem here. In general, we cannot
6500 determine the size of dynamic records without its data. However,
6501 the 'struct value' data structure, which GDB uses to represent
6502 quantities in the inferior process (the target), requires the size
6503 of the type at the time of its allocation in order to reserve space
6504 for GDB's internal copy of the data. That's why the
6505 'to_fixed_xxx_type' routines take (target) addresses as parameters,
6506 rather than struct value*s.
6508 However, GDB's internal history variables ($1, $2, etc.) are
6509 struct value*s containing internal copies of the data that are not, in
6510 general, the same as the data at their corresponding addresses in
6511 the target. Fortunately, the types we give to these values are all
6512 conventional, fixed-size types (as per the strategy described
6513 above), so that we don't usually have to perform the
6514 'to_fixed_xxx_type' conversions to look at their values.
6515 Unfortunately, there is one exception: if one of the internal
6516 history variables is an array whose elements are unconstrained
6517 records, then we will need to create distinct fixed types for each
6518 element selected. */
6520 /* The upshot of all of this is that many routines take a (type, host
6521 address, target address) triple as arguments to represent a value.
6522 The host address, if non-null, is supposed to contain an internal
6523 copy of the relevant data; otherwise, the program is to consult the
6524 target at the target address. */
6526 /* Assuming that VAL0 represents a pointer value, the result of
6527 dereferencing it. Differs from value_ind in its treatment of
6528 dynamic-sized types. */
6531 ada_value_ind (struct value
*val0
)
6533 struct value
*val
= unwrap_value (value_ind (val0
));
6534 return ada_to_fixed_value (val
);
6537 /* The value resulting from dereferencing any "reference to"
6538 qualifiers on VAL0. */
6540 static struct value
*
6541 ada_coerce_ref (struct value
*val0
)
6543 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
6545 struct value
*val
= val0
;
6546 val
= coerce_ref (val
);
6547 val
= unwrap_value (val
);
6548 return ada_to_fixed_value (val
);
6554 /* Return OFF rounded upward if necessary to a multiple of
6555 ALIGNMENT (a power of 2). */
6558 align_value (unsigned int off
, unsigned int alignment
)
6560 return (off
+ alignment
- 1) & ~(alignment
- 1);
6563 /* Return the bit alignment required for field #F of template type TYPE. */
6566 field_alignment (struct type
*type
, int f
)
6568 const char *name
= TYPE_FIELD_NAME (type
, f
);
6572 /* The field name should never be null, unless the debugging information
6573 is somehow malformed. In this case, we assume the field does not
6574 require any alignment. */
6578 len
= strlen (name
);
6580 if (!isdigit (name
[len
- 1]))
6583 if (isdigit (name
[len
- 2]))
6584 align_offset
= len
- 2;
6586 align_offset
= len
- 1;
6588 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
6589 return TARGET_CHAR_BIT
;
6591 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
6594 /* Find a symbol named NAME. Ignores ambiguity. */
6597 ada_find_any_symbol (const char *name
)
6601 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
6602 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
6605 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
6609 /* Find a type named NAME. Ignores ambiguity. */
6612 ada_find_any_type (const char *name
)
6614 struct symbol
*sym
= ada_find_any_symbol (name
);
6617 return SYMBOL_TYPE (sym
);
6622 /* Given NAME and an associated BLOCK, search all symbols for
6623 NAME suffixed with "___XR", which is the ``renaming'' symbol
6624 associated to NAME. Return this symbol if found, return
6628 ada_find_renaming_symbol (const char *name
, struct block
*block
)
6632 sym
= find_old_style_renaming_symbol (name
, block
);
6637 /* Not right yet. FIXME pnh 7/20/2007. */
6638 sym
= ada_find_any_symbol (name
);
6639 if (sym
!= NULL
&& strstr (SYMBOL_LINKAGE_NAME (sym
), "___XR") != NULL
)
6645 static struct symbol
*
6646 find_old_style_renaming_symbol (const char *name
, struct block
*block
)
6648 const struct symbol
*function_sym
= block_linkage_function (block
);
6651 if (function_sym
!= NULL
)
6653 /* If the symbol is defined inside a function, NAME is not fully
6654 qualified. This means we need to prepend the function name
6655 as well as adding the ``___XR'' suffix to build the name of
6656 the associated renaming symbol. */
6657 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
6658 /* Function names sometimes contain suffixes used
6659 for instance to qualify nested subprograms. When building
6660 the XR type name, we need to make sure that this suffix is
6661 not included. So do not include any suffix in the function
6662 name length below. */
6663 const int function_name_len
= ada_name_prefix_len (function_name
);
6664 const int rename_len
= function_name_len
+ 2 /* "__" */
6665 + strlen (name
) + 6 /* "___XR\0" */ ;
6667 /* Strip the suffix if necessary. */
6668 function_name
[function_name_len
] = '\0';
6670 /* Library-level functions are a special case, as GNAT adds
6671 a ``_ada_'' prefix to the function name to avoid namespace
6672 pollution. However, the renaming symbols themselves do not
6673 have this prefix, so we need to skip this prefix if present. */
6674 if (function_name_len
> 5 /* "_ada_" */
6675 && strstr (function_name
, "_ada_") == function_name
)
6676 function_name
= function_name
+ 5;
6678 rename
= (char *) alloca (rename_len
* sizeof (char));
6679 sprintf (rename
, "%s__%s___XR", function_name
, name
);
6683 const int rename_len
= strlen (name
) + 6;
6684 rename
= (char *) alloca (rename_len
* sizeof (char));
6685 sprintf (rename
, "%s___XR", name
);
6688 return ada_find_any_symbol (rename
);
6691 /* Because of GNAT encoding conventions, several GDB symbols may match a
6692 given type name. If the type denoted by TYPE0 is to be preferred to
6693 that of TYPE1 for purposes of type printing, return non-zero;
6694 otherwise return 0. */
6697 ada_prefer_type (struct type
*type0
, struct type
*type1
)
6701 else if (type0
== NULL
)
6703 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
6705 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
6707 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
6709 else if (ada_is_packed_array_type (type0
))
6711 else if (ada_is_array_descriptor_type (type0
)
6712 && !ada_is_array_descriptor_type (type1
))
6716 const char *type0_name
= type_name_no_tag (type0
);
6717 const char *type1_name
= type_name_no_tag (type1
);
6719 if (type0_name
!= NULL
&& strstr (type0_name
, "___XR") != NULL
6720 && (type1_name
== NULL
|| strstr (type1_name
, "___XR") == NULL
))
6726 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6727 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6730 ada_type_name (struct type
*type
)
6734 else if (TYPE_NAME (type
) != NULL
)
6735 return TYPE_NAME (type
);
6737 return TYPE_TAG_NAME (type
);
6740 /* Find a parallel type to TYPE whose name is formed by appending
6741 SUFFIX to the name of TYPE. */
6744 ada_find_parallel_type (struct type
*type
, const char *suffix
)
6747 static size_t name_len
= 0;
6749 char *typename
= ada_type_name (type
);
6751 if (typename
== NULL
)
6754 len
= strlen (typename
);
6756 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
6758 strcpy (name
, typename
);
6759 strcpy (name
+ len
, suffix
);
6761 return ada_find_any_type (name
);
6765 /* If TYPE is a variable-size record type, return the corresponding template
6766 type describing its fields. Otherwise, return NULL. */
6768 static struct type
*
6769 dynamic_template_type (struct type
*type
)
6771 type
= ada_check_typedef (type
);
6773 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
6774 || ada_type_name (type
) == NULL
)
6778 int len
= strlen (ada_type_name (type
));
6779 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
6782 return ada_find_parallel_type (type
, "___XVE");
6786 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6787 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6790 is_dynamic_field (struct type
*templ_type
, int field_num
)
6792 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
6794 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
6795 && strstr (name
, "___XVL") != NULL
;
6798 /* The index of the variant field of TYPE, or -1 if TYPE does not
6799 represent a variant record type. */
6802 variant_field_index (struct type
*type
)
6806 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6809 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6811 if (ada_is_variant_part (type
, f
))
6817 /* A record type with no fields. */
6819 static struct type
*
6820 empty_record (struct objfile
*objfile
)
6822 struct type
*type
= alloc_type (objfile
);
6823 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6824 TYPE_NFIELDS (type
) = 0;
6825 TYPE_FIELDS (type
) = NULL
;
6826 INIT_CPLUS_SPECIFIC (type
);
6827 TYPE_NAME (type
) = "<empty>";
6828 TYPE_TAG_NAME (type
) = NULL
;
6829 TYPE_LENGTH (type
) = 0;
6833 /* An ordinary record type (with fixed-length fields) that describes
6834 the value of type TYPE at VALADDR or ADDRESS (see comments at
6835 the beginning of this section) VAL according to GNAT conventions.
6836 DVAL0 should describe the (portion of a) record that contains any
6837 necessary discriminants. It should be NULL if value_type (VAL) is
6838 an outer-level type (i.e., as opposed to a branch of a variant.) A
6839 variant field (unless unchecked) is replaced by a particular branch
6842 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6843 length are not statically known are discarded. As a consequence,
6844 VALADDR, ADDRESS and DVAL0 are ignored.
6846 NOTE: Limitations: For now, we assume that dynamic fields and
6847 variants occupy whole numbers of bytes. However, they need not be
6851 ada_template_to_fixed_record_type_1 (struct type
*type
,
6852 const gdb_byte
*valaddr
,
6853 CORE_ADDR address
, struct value
*dval0
,
6854 int keep_dynamic_fields
)
6856 struct value
*mark
= value_mark ();
6859 int nfields
, bit_len
;
6862 int fld_bit_len
, bit_incr
;
6865 /* Compute the number of fields in this record type that are going
6866 to be processed: unless keep_dynamic_fields, this includes only
6867 fields whose position and length are static will be processed. */
6868 if (keep_dynamic_fields
)
6869 nfields
= TYPE_NFIELDS (type
);
6873 while (nfields
< TYPE_NFIELDS (type
)
6874 && !ada_is_variant_part (type
, nfields
)
6875 && !is_dynamic_field (type
, nfields
))
6879 rtype
= alloc_type (TYPE_OBJFILE (type
));
6880 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6881 INIT_CPLUS_SPECIFIC (rtype
);
6882 TYPE_NFIELDS (rtype
) = nfields
;
6883 TYPE_FIELDS (rtype
) = (struct field
*)
6884 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6885 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6886 TYPE_NAME (rtype
) = ada_type_name (type
);
6887 TYPE_TAG_NAME (rtype
) = NULL
;
6888 TYPE_FIXED_INSTANCE (rtype
) = 1;
6894 for (f
= 0; f
< nfields
; f
+= 1)
6896 off
= align_value (off
, field_alignment (type
, f
))
6897 + TYPE_FIELD_BITPOS (type
, f
);
6898 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6899 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6901 if (ada_is_variant_part (type
, f
))
6904 fld_bit_len
= bit_incr
= 0;
6906 else if (is_dynamic_field (type
, f
))
6909 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6913 /* Get the fixed type of the field. Note that, in this case, we
6914 do not want to get the real type out of the tag: if the current
6915 field is the parent part of a tagged record, we will get the
6916 tag of the object. Clearly wrong: the real type of the parent
6917 is not the real type of the child. We would end up in an infinite
6919 TYPE_FIELD_TYPE (rtype
, f
) =
6922 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6923 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6924 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
, 0);
6925 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6926 bit_incr
= fld_bit_len
=
6927 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6931 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6932 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6933 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6934 bit_incr
= fld_bit_len
=
6935 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6937 bit_incr
= fld_bit_len
=
6938 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6940 if (off
+ fld_bit_len
> bit_len
)
6941 bit_len
= off
+ fld_bit_len
;
6943 TYPE_LENGTH (rtype
) =
6944 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6947 /* We handle the variant part, if any, at the end because of certain
6948 odd cases in which it is re-ordered so as NOT to be the last field of
6949 the record. This can happen in the presence of representation
6951 if (variant_field
>= 0)
6953 struct type
*branch_type
;
6955 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6958 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6963 to_fixed_variant_branch_type
6964 (TYPE_FIELD_TYPE (type
, variant_field
),
6965 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6966 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6967 if (branch_type
== NULL
)
6969 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6970 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6971 TYPE_NFIELDS (rtype
) -= 1;
6975 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6976 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6978 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6980 if (off
+ fld_bit_len
> bit_len
)
6981 bit_len
= off
+ fld_bit_len
;
6982 TYPE_LENGTH (rtype
) =
6983 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6987 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6988 should contain the alignment of that record, which should be a strictly
6989 positive value. If null or negative, then something is wrong, most
6990 probably in the debug info. In that case, we don't round up the size
6991 of the resulting type. If this record is not part of another structure,
6992 the current RTYPE length might be good enough for our purposes. */
6993 if (TYPE_LENGTH (type
) <= 0)
6995 if (TYPE_NAME (rtype
))
6996 warning (_("Invalid type size for `%s' detected: %d."),
6997 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
6999 warning (_("Invalid type size for <unnamed> detected: %d."),
7000 TYPE_LENGTH (type
));
7004 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
7005 TYPE_LENGTH (type
));
7008 value_free_to_mark (mark
);
7009 if (TYPE_LENGTH (rtype
) > varsize_limit
)
7010 error (_("record type with dynamic size is larger than varsize-limit"));
7014 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7017 static struct type
*
7018 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
7019 CORE_ADDR address
, struct value
*dval0
)
7021 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
7025 /* An ordinary record type in which ___XVL-convention fields and
7026 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7027 static approximations, containing all possible fields. Uses
7028 no runtime values. Useless for use in values, but that's OK,
7029 since the results are used only for type determinations. Works on both
7030 structs and unions. Representation note: to save space, we memorize
7031 the result of this function in the TYPE_TARGET_TYPE of the
7034 static struct type
*
7035 template_to_static_fixed_type (struct type
*type0
)
7041 if (TYPE_TARGET_TYPE (type0
) != NULL
)
7042 return TYPE_TARGET_TYPE (type0
);
7044 nfields
= TYPE_NFIELDS (type0
);
7047 for (f
= 0; f
< nfields
; f
+= 1)
7049 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
7050 struct type
*new_type
;
7052 if (is_dynamic_field (type0
, f
))
7053 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
7055 new_type
= static_unwrap_type (field_type
);
7056 if (type
== type0
&& new_type
!= field_type
)
7058 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
7059 TYPE_CODE (type
) = TYPE_CODE (type0
);
7060 INIT_CPLUS_SPECIFIC (type
);
7061 TYPE_NFIELDS (type
) = nfields
;
7062 TYPE_FIELDS (type
) = (struct field
*)
7063 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
7064 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
7065 sizeof (struct field
) * nfields
);
7066 TYPE_NAME (type
) = ada_type_name (type0
);
7067 TYPE_TAG_NAME (type
) = NULL
;
7068 TYPE_FIXED_INSTANCE (type
) = 1;
7069 TYPE_LENGTH (type
) = 0;
7071 TYPE_FIELD_TYPE (type
, f
) = new_type
;
7072 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
7077 /* Given an object of type TYPE whose contents are at VALADDR and
7078 whose address in memory is ADDRESS, returns a revision of TYPE,
7079 which should be a non-dynamic-sized record, in which the variant
7080 part, if any, is replaced with the appropriate branch. Looks
7081 for discriminant values in DVAL0, which can be NULL if the record
7082 contains the necessary discriminant values. */
7084 static struct type
*
7085 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
7086 CORE_ADDR address
, struct value
*dval0
)
7088 struct value
*mark
= value_mark ();
7091 struct type
*branch_type
;
7092 int nfields
= TYPE_NFIELDS (type
);
7093 int variant_field
= variant_field_index (type
);
7095 if (variant_field
== -1)
7099 dval
= value_from_contents_and_address (type
, valaddr
, address
);
7103 rtype
= alloc_type (TYPE_OBJFILE (type
));
7104 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7105 INIT_CPLUS_SPECIFIC (rtype
);
7106 TYPE_NFIELDS (rtype
) = nfields
;
7107 TYPE_FIELDS (rtype
) =
7108 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7109 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
7110 sizeof (struct field
) * nfields
);
7111 TYPE_NAME (rtype
) = ada_type_name (type
);
7112 TYPE_TAG_NAME (rtype
) = NULL
;
7113 TYPE_FIXED_INSTANCE (rtype
) = 1;
7114 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
7116 branch_type
= to_fixed_variant_branch_type
7117 (TYPE_FIELD_TYPE (type
, variant_field
),
7118 cond_offset_host (valaddr
,
7119 TYPE_FIELD_BITPOS (type
, variant_field
)
7121 cond_offset_target (address
,
7122 TYPE_FIELD_BITPOS (type
, variant_field
)
7123 / TARGET_CHAR_BIT
), dval
);
7124 if (branch_type
== NULL
)
7127 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
7128 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7129 TYPE_NFIELDS (rtype
) -= 1;
7133 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7134 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7135 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
7136 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
7138 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
7140 value_free_to_mark (mark
);
7144 /* An ordinary record type (with fixed-length fields) that describes
7145 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7146 beginning of this section]. Any necessary discriminants' values
7147 should be in DVAL, a record value; it may be NULL if the object
7148 at ADDR itself contains any necessary discriminant values.
7149 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7150 values from the record are needed. Except in the case that DVAL,
7151 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7152 unchecked) is replaced by a particular branch of the variant.
7154 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7155 is questionable and may be removed. It can arise during the
7156 processing of an unconstrained-array-of-record type where all the
7157 variant branches have exactly the same size. This is because in
7158 such cases, the compiler does not bother to use the XVS convention
7159 when encoding the record. I am currently dubious of this
7160 shortcut and suspect the compiler should be altered. FIXME. */
7162 static struct type
*
7163 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
7164 CORE_ADDR address
, struct value
*dval
)
7166 struct type
*templ_type
;
7168 if (TYPE_FIXED_INSTANCE (type0
))
7171 templ_type
= dynamic_template_type (type0
);
7173 if (templ_type
!= NULL
)
7174 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
7175 else if (variant_field_index (type0
) >= 0)
7177 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
7179 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
7184 TYPE_FIXED_INSTANCE (type0
) = 1;
7190 /* An ordinary record type (with fixed-length fields) that describes
7191 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7192 union type. Any necessary discriminants' values should be in DVAL,
7193 a record value. That is, this routine selects the appropriate
7194 branch of the union at ADDR according to the discriminant value
7195 indicated in the union's type name. Returns VAR_TYPE0 itself if
7196 it represents a variant subject to a pragma Unchecked_Union. */
7198 static struct type
*
7199 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
7200 CORE_ADDR address
, struct value
*dval
)
7203 struct type
*templ_type
;
7204 struct type
*var_type
;
7206 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
7207 var_type
= TYPE_TARGET_TYPE (var_type0
);
7209 var_type
= var_type0
;
7211 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
7213 if (templ_type
!= NULL
)
7214 var_type
= templ_type
;
7216 if (is_unchecked_variant (var_type
, value_type (dval
)))
7219 ada_which_variant_applies (var_type
,
7220 value_type (dval
), value_contents (dval
));
7223 return empty_record (TYPE_OBJFILE (var_type
));
7224 else if (is_dynamic_field (var_type
, which
))
7225 return to_fixed_record_type
7226 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
7227 valaddr
, address
, dval
);
7228 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
7230 to_fixed_record_type
7231 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
7233 return TYPE_FIELD_TYPE (var_type
, which
);
7236 /* Assuming that TYPE0 is an array type describing the type of a value
7237 at ADDR, and that DVAL describes a record containing any
7238 discriminants used in TYPE0, returns a type for the value that
7239 contains no dynamic components (that is, no components whose sizes
7240 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7241 true, gives an error message if the resulting type's size is over
7244 static struct type
*
7245 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
7248 struct type
*index_type_desc
;
7249 struct type
*result
;
7251 if (ada_is_packed_array_type (type0
) /* revisit? */
7252 || TYPE_FIXED_INSTANCE (type0
))
7255 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
7256 if (index_type_desc
== NULL
)
7258 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
7259 /* NOTE: elt_type---the fixed version of elt_type0---should never
7260 depend on the contents of the array in properly constructed
7262 /* Create a fixed version of the array element type.
7263 We're not providing the address of an element here,
7264 and thus the actual object value cannot be inspected to do
7265 the conversion. This should not be a problem, since arrays of
7266 unconstrained objects are not allowed. In particular, all
7267 the elements of an array of a tagged type should all be of
7268 the same type specified in the debugging info. No need to
7269 consult the object tag. */
7270 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
, 1);
7272 if (elt_type0
== elt_type
)
7275 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7276 elt_type
, TYPE_INDEX_TYPE (type0
));
7281 struct type
*elt_type0
;
7284 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
7285 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
7287 /* NOTE: result---the fixed version of elt_type0---should never
7288 depend on the contents of the array in properly constructed
7290 /* Create a fixed version of the array element type.
7291 We're not providing the address of an element here,
7292 and thus the actual object value cannot be inspected to do
7293 the conversion. This should not be a problem, since arrays of
7294 unconstrained objects are not allowed. In particular, all
7295 the elements of an array of a tagged type should all be of
7296 the same type specified in the debugging info. No need to
7297 consult the object tag. */
7299 ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
, 1);
7300 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
7302 struct type
*range_type
=
7303 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
7304 dval
, TYPE_OBJFILE (type0
));
7305 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7306 result
, range_type
);
7308 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
7309 error (_("array type with dynamic size is larger than varsize-limit"));
7312 TYPE_FIXED_INSTANCE (result
) = 1;
7317 /* A standard type (containing no dynamically sized components)
7318 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
7319 DVAL describes a record containing any discriminants used in TYPE0,
7320 and may be NULL if there are none, or if the object of type TYPE at
7321 ADDRESS or in VALADDR contains these discriminants.
7323 If CHECK_TAG is not null, in the case of tagged types, this function
7324 attempts to locate the object's tag and use it to compute the actual
7325 type. However, when ADDRESS is null, we cannot use it to determine the
7326 location of the tag, and therefore compute the tagged type's actual type.
7327 So we return the tagged type without consulting the tag. */
7329 static struct type
*
7330 ada_to_fixed_type_1 (struct type
*type
, const gdb_byte
*valaddr
,
7331 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7333 type
= ada_check_typedef (type
);
7334 switch (TYPE_CODE (type
))
7338 case TYPE_CODE_STRUCT
:
7340 struct type
*static_type
= to_static_fixed_type (type
);
7341 struct type
*fixed_record_type
=
7342 to_fixed_record_type (type
, valaddr
, address
, NULL
);
7343 /* If STATIC_TYPE is a tagged type and we know the object's address,
7344 then we can determine its tag, and compute the object's actual
7345 type from there. Note that we have to use the fixed record
7346 type (the parent part of the record may have dynamic fields
7347 and the way the location of _tag is expressed may depend on
7350 if (check_tag
&& address
!= 0 && ada_is_tagged_type (static_type
, 0))
7352 struct type
*real_type
=
7353 type_from_tag (value_tag_from_contents_and_address
7357 if (real_type
!= NULL
)
7358 return to_fixed_record_type (real_type
, valaddr
, address
, NULL
);
7360 return fixed_record_type
;
7362 case TYPE_CODE_ARRAY
:
7363 return to_fixed_array_type (type
, dval
, 1);
7364 case TYPE_CODE_UNION
:
7368 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
7372 /* The same as ada_to_fixed_type_1, except that it preserves the type
7373 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
7374 ada_to_fixed_type_1 would return the type referenced by TYPE. */
7377 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
7378 CORE_ADDR address
, struct value
*dval
, int check_tag
)
7381 struct type
*fixed_type
=
7382 ada_to_fixed_type_1 (type
, valaddr
, address
, dval
, check_tag
);
7384 if (TYPE_CODE (type
) == TYPE_CODE_TYPEDEF
7385 && TYPE_TARGET_TYPE (type
) == fixed_type
)
7391 /* A standard (static-sized) type corresponding as well as possible to
7392 TYPE0, but based on no runtime data. */
7394 static struct type
*
7395 to_static_fixed_type (struct type
*type0
)
7402 if (TYPE_FIXED_INSTANCE (type0
))
7405 type0
= ada_check_typedef (type0
);
7407 switch (TYPE_CODE (type0
))
7411 case TYPE_CODE_STRUCT
:
7412 type
= dynamic_template_type (type0
);
7414 return template_to_static_fixed_type (type
);
7416 return template_to_static_fixed_type (type0
);
7417 case TYPE_CODE_UNION
:
7418 type
= ada_find_parallel_type (type0
, "___XVU");
7420 return template_to_static_fixed_type (type
);
7422 return template_to_static_fixed_type (type0
);
7426 /* A static approximation of TYPE with all type wrappers removed. */
7428 static struct type
*
7429 static_unwrap_type (struct type
*type
)
7431 if (ada_is_aligner_type (type
))
7433 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
7434 if (ada_type_name (type1
) == NULL
)
7435 TYPE_NAME (type1
) = ada_type_name (type
);
7437 return static_unwrap_type (type1
);
7441 struct type
*raw_real_type
= ada_get_base_type (type
);
7442 if (raw_real_type
== type
)
7445 return to_static_fixed_type (raw_real_type
);
7449 /* In some cases, incomplete and private types require
7450 cross-references that are not resolved as records (for example,
7452 type FooP is access Foo;
7454 type Foo is array ...;
7455 ). In these cases, since there is no mechanism for producing
7456 cross-references to such types, we instead substitute for FooP a
7457 stub enumeration type that is nowhere resolved, and whose tag is
7458 the name of the actual type. Call these types "non-record stubs". */
7460 /* A type equivalent to TYPE that is not a non-record stub, if one
7461 exists, otherwise TYPE. */
7464 ada_check_typedef (struct type
*type
)
7469 CHECK_TYPEDEF (type
);
7470 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
7471 || !TYPE_STUB (type
)
7472 || TYPE_TAG_NAME (type
) == NULL
)
7476 char *name
= TYPE_TAG_NAME (type
);
7477 struct type
*type1
= ada_find_any_type (name
);
7478 return (type1
== NULL
) ? type
: type1
;
7482 /* A value representing the data at VALADDR/ADDRESS as described by
7483 type TYPE0, but with a standard (static-sized) type that correctly
7484 describes it. If VAL0 is not NULL and TYPE0 already is a standard
7485 type, then return VAL0 [this feature is simply to avoid redundant
7486 creation of struct values]. */
7488 static struct value
*
7489 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
7492 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
, 1);
7493 if (type
== type0
&& val0
!= NULL
)
7496 return value_from_contents_and_address (type
, 0, address
);
7499 /* A value representing VAL, but with a standard (static-sized) type
7500 that correctly describes it. Does not necessarily create a new
7503 static struct value
*
7504 ada_to_fixed_value (struct value
*val
)
7506 return ada_to_fixed_value_create (value_type (val
),
7507 VALUE_ADDRESS (val
) + value_offset (val
),
7511 /* A value representing VAL, but with a standard (static-sized) type
7512 chosen to approximate the real type of VAL as well as possible, but
7513 without consulting any runtime values. For Ada dynamic-sized
7514 types, therefore, the type of the result is likely to be inaccurate. */
7517 ada_to_static_fixed_value (struct value
*val
)
7520 to_static_fixed_type (static_unwrap_type (value_type (val
)));
7521 if (type
== value_type (val
))
7524 return coerce_unspec_val_to_type (val
, type
);
7530 /* Table mapping attribute numbers to names.
7531 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
7533 static const char *attribute_names
[] = {
7551 ada_attribute_name (enum exp_opcode n
)
7553 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
7554 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
7556 return attribute_names
[0];
7559 /* Evaluate the 'POS attribute applied to ARG. */
7562 pos_atr (struct value
*arg
)
7564 struct value
*val
= coerce_ref (arg
);
7565 struct type
*type
= value_type (val
);
7567 if (!discrete_type_p (type
))
7568 error (_("'POS only defined on discrete types"));
7570 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7573 LONGEST v
= value_as_long (val
);
7575 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7577 if (v
== TYPE_FIELD_BITPOS (type
, i
))
7580 error (_("enumeration value is invalid: can't find 'POS"));
7583 return value_as_long (val
);
7586 static struct value
*
7587 value_pos_atr (struct type
*type
, struct value
*arg
)
7589 return value_from_longest (type
, pos_atr (arg
));
7592 /* Evaluate the TYPE'VAL attribute applied to ARG. */
7594 static struct value
*
7595 value_val_atr (struct type
*type
, struct value
*arg
)
7597 if (!discrete_type_p (type
))
7598 error (_("'VAL only defined on discrete types"));
7599 if (!integer_type_p (value_type (arg
)))
7600 error (_("'VAL requires integral argument"));
7602 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
7604 long pos
= value_as_long (arg
);
7605 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
7606 error (_("argument to 'VAL out of range"));
7607 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
7610 return value_from_longest (type
, value_as_long (arg
));
7616 /* True if TYPE appears to be an Ada character type.
7617 [At the moment, this is true only for Character and Wide_Character;
7618 It is a heuristic test that could stand improvement]. */
7621 ada_is_character_type (struct type
*type
)
7625 /* If the type code says it's a character, then assume it really is,
7626 and don't check any further. */
7627 if (TYPE_CODE (type
) == TYPE_CODE_CHAR
)
7630 /* Otherwise, assume it's a character type iff it is a discrete type
7631 with a known character type name. */
7632 name
= ada_type_name (type
);
7633 return (name
!= NULL
7634 && (TYPE_CODE (type
) == TYPE_CODE_INT
7635 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7636 && (strcmp (name
, "character") == 0
7637 || strcmp (name
, "wide_character") == 0
7638 || strcmp (name
, "wide_wide_character") == 0
7639 || strcmp (name
, "unsigned char") == 0));
7642 /* True if TYPE appears to be an Ada string type. */
7645 ada_is_string_type (struct type
*type
)
7647 type
= ada_check_typedef (type
);
7649 && TYPE_CODE (type
) != TYPE_CODE_PTR
7650 && (ada_is_simple_array_type (type
)
7651 || ada_is_array_descriptor_type (type
))
7652 && ada_array_arity (type
) == 1)
7654 struct type
*elttype
= ada_array_element_type (type
, 1);
7656 return ada_is_character_type (elttype
);
7663 /* True if TYPE is a struct type introduced by the compiler to force the
7664 alignment of a value. Such types have a single field with a
7665 distinctive name. */
7668 ada_is_aligner_type (struct type
*type
)
7670 type
= ada_check_typedef (type
);
7672 /* If we can find a parallel XVS type, then the XVS type should
7673 be used instead of this type. And hence, this is not an aligner
7675 if (ada_find_parallel_type (type
, "___XVS") != NULL
)
7678 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
7679 && TYPE_NFIELDS (type
) == 1
7680 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
7683 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7684 the parallel type. */
7687 ada_get_base_type (struct type
*raw_type
)
7689 struct type
*real_type_namer
;
7690 struct type
*raw_real_type
;
7692 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
7695 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
7696 if (real_type_namer
== NULL
7697 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
7698 || TYPE_NFIELDS (real_type_namer
) != 1)
7701 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
7702 if (raw_real_type
== NULL
)
7705 return raw_real_type
;
7708 /* The type of value designated by TYPE, with all aligners removed. */
7711 ada_aligned_type (struct type
*type
)
7713 if (ada_is_aligner_type (type
))
7714 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
7716 return ada_get_base_type (type
);
7720 /* The address of the aligned value in an object at address VALADDR
7721 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7724 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
7726 if (ada_is_aligner_type (type
))
7727 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
7729 TYPE_FIELD_BITPOS (type
,
7730 0) / TARGET_CHAR_BIT
);
7737 /* The printed representation of an enumeration literal with encoded
7738 name NAME. The value is good to the next call of ada_enum_name. */
7740 ada_enum_name (const char *name
)
7742 static char *result
;
7743 static size_t result_len
= 0;
7746 /* First, unqualify the enumeration name:
7747 1. Search for the last '.' character. If we find one, then skip
7748 all the preceeding characters, the unqualified name starts
7749 right after that dot.
7750 2. Otherwise, we may be debugging on a target where the compiler
7751 translates dots into "__". Search forward for double underscores,
7752 but stop searching when we hit an overloading suffix, which is
7753 of the form "__" followed by digits. */
7755 tmp
= strrchr (name
, '.');
7760 while ((tmp
= strstr (name
, "__")) != NULL
)
7762 if (isdigit (tmp
[2]))
7772 if (name
[1] == 'U' || name
[1] == 'W')
7774 if (sscanf (name
+ 2, "%x", &v
) != 1)
7780 GROW_VECT (result
, result_len
, 16);
7781 if (isascii (v
) && isprint (v
))
7782 sprintf (result
, "'%c'", v
);
7783 else if (name
[1] == 'U')
7784 sprintf (result
, "[\"%02x\"]", v
);
7786 sprintf (result
, "[\"%04x\"]", v
);
7792 tmp
= strstr (name
, "__");
7794 tmp
= strstr (name
, "$");
7797 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
7798 strncpy (result
, name
, tmp
- name
);
7799 result
[tmp
- name
] = '\0';
7807 static struct value
*
7808 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
7811 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7812 (expect_type
, exp
, pos
, noside
);
7815 /* Evaluate the subexpression of EXP starting at *POS as for
7816 evaluate_type, updating *POS to point just past the evaluated
7819 static struct value
*
7820 evaluate_subexp_type (struct expression
*exp
, int *pos
)
7822 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7823 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
7826 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7829 static struct value
*
7830 unwrap_value (struct value
*val
)
7832 struct type
*type
= ada_check_typedef (value_type (val
));
7833 if (ada_is_aligner_type (type
))
7835 struct value
*v
= ada_value_struct_elt (val
, "F", 0);
7836 struct type
*val_type
= ada_check_typedef (value_type (v
));
7837 if (ada_type_name (val_type
) == NULL
)
7838 TYPE_NAME (val_type
) = ada_type_name (type
);
7840 return unwrap_value (v
);
7844 struct type
*raw_real_type
=
7845 ada_check_typedef (ada_get_base_type (type
));
7847 if (type
== raw_real_type
)
7851 coerce_unspec_val_to_type
7852 (val
, ada_to_fixed_type (raw_real_type
, 0,
7853 VALUE_ADDRESS (val
) + value_offset (val
),
7858 static struct value
*
7859 cast_to_fixed (struct type
*type
, struct value
*arg
)
7863 if (type
== value_type (arg
))
7865 else if (ada_is_fixed_point_type (value_type (arg
)))
7866 val
= ada_float_to_fixed (type
,
7867 ada_fixed_to_float (value_type (arg
),
7868 value_as_long (arg
)));
7871 DOUBLEST argd
= value_as_double (arg
);
7872 val
= ada_float_to_fixed (type
, argd
);
7875 return value_from_longest (type
, val
);
7878 static struct value
*
7879 cast_from_fixed (struct type
*type
, struct value
*arg
)
7881 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
7882 value_as_long (arg
));
7883 return value_from_double (type
, val
);
7886 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7887 return the converted value. */
7889 static struct value
*
7890 coerce_for_assign (struct type
*type
, struct value
*val
)
7892 struct type
*type2
= value_type (val
);
7896 type2
= ada_check_typedef (type2
);
7897 type
= ada_check_typedef (type
);
7899 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
7900 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7902 val
= ada_value_ind (val
);
7903 type2
= value_type (val
);
7906 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
7907 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7909 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
7910 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
7911 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
7912 error (_("Incompatible types in assignment"));
7913 deprecated_set_value_type (val
, type
);
7918 static struct value
*
7919 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
7922 struct type
*type1
, *type2
;
7925 arg1
= coerce_ref (arg1
);
7926 arg2
= coerce_ref (arg2
);
7927 type1
= base_type (ada_check_typedef (value_type (arg1
)));
7928 type2
= base_type (ada_check_typedef (value_type (arg2
)));
7930 if (TYPE_CODE (type1
) != TYPE_CODE_INT
7931 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
7932 return value_binop (arg1
, arg2
, op
);
7941 return value_binop (arg1
, arg2
, op
);
7944 v2
= value_as_long (arg2
);
7946 error (_("second operand of %s must not be zero."), op_string (op
));
7948 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7949 return value_binop (arg1
, arg2
, op
);
7951 v1
= value_as_long (arg1
);
7956 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7957 v
+= v
> 0 ? -1 : 1;
7965 /* Should not reach this point. */
7969 val
= allocate_value (type1
);
7970 store_unsigned_integer (value_contents_raw (val
),
7971 TYPE_LENGTH (value_type (val
)), v
);
7976 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7978 if (ada_is_direct_array_type (value_type (arg1
))
7979 || ada_is_direct_array_type (value_type (arg2
)))
7981 /* Automatically dereference any array reference before
7982 we attempt to perform the comparison. */
7983 arg1
= ada_coerce_ref (arg1
);
7984 arg2
= ada_coerce_ref (arg2
);
7986 arg1
= ada_coerce_to_simple_array (arg1
);
7987 arg2
= ada_coerce_to_simple_array (arg2
);
7988 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
7989 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
7990 error (_("Attempt to compare array with non-array"));
7991 /* FIXME: The following works only for types whose
7992 representations use all bits (no padding or undefined bits)
7993 and do not have user-defined equality. */
7995 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
7996 && memcmp (value_contents (arg1
), value_contents (arg2
),
7997 TYPE_LENGTH (value_type (arg1
))) == 0;
7999 return value_equal (arg1
, arg2
);
8002 /* Total number of component associations in the aggregate starting at
8003 index PC in EXP. Assumes that index PC is the start of an
8007 num_component_specs (struct expression
*exp
, int pc
)
8010 m
= exp
->elts
[pc
+ 1].longconst
;
8013 for (i
= 0; i
< m
; i
+= 1)
8015 switch (exp
->elts
[pc
].opcode
)
8021 n
+= exp
->elts
[pc
+ 1].longconst
;
8024 ada_evaluate_subexp (NULL
, exp
, &pc
, EVAL_SKIP
);
8029 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
8030 component of LHS (a simple array or a record), updating *POS past
8031 the expression, assuming that LHS is contained in CONTAINER. Does
8032 not modify the inferior's memory, nor does it modify LHS (unless
8033 LHS == CONTAINER). */
8036 assign_component (struct value
*container
, struct value
*lhs
, LONGEST index
,
8037 struct expression
*exp
, int *pos
)
8039 struct value
*mark
= value_mark ();
8041 if (TYPE_CODE (value_type (lhs
)) == TYPE_CODE_ARRAY
)
8043 struct value
*index_val
= value_from_longest (builtin_type_int32
, index
);
8044 elt
= unwrap_value (ada_value_subscript (lhs
, 1, &index_val
));
8048 elt
= ada_index_struct_field (index
, lhs
, 0, value_type (lhs
));
8049 elt
= ada_to_fixed_value (unwrap_value (elt
));
8052 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8053 assign_aggregate (container
, elt
, exp
, pos
, EVAL_NORMAL
);
8055 value_assign_to_component (container
, elt
,
8056 ada_evaluate_subexp (NULL
, exp
, pos
,
8059 value_free_to_mark (mark
);
8062 /* Assuming that LHS represents an lvalue having a record or array
8063 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
8064 of that aggregate's value to LHS, advancing *POS past the
8065 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
8066 lvalue containing LHS (possibly LHS itself). Does not modify
8067 the inferior's memory, nor does it modify the contents of
8068 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
8070 static struct value
*
8071 assign_aggregate (struct value
*container
,
8072 struct value
*lhs
, struct expression
*exp
,
8073 int *pos
, enum noside noside
)
8075 struct type
*lhs_type
;
8076 int n
= exp
->elts
[*pos
+1].longconst
;
8077 LONGEST low_index
, high_index
;
8080 int max_indices
, num_indices
;
8081 int is_array_aggregate
;
8083 struct value
*mark
= value_mark ();
8086 if (noside
!= EVAL_NORMAL
)
8089 for (i
= 0; i
< n
; i
+= 1)
8090 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
8094 container
= ada_coerce_ref (container
);
8095 if (ada_is_direct_array_type (value_type (container
)))
8096 container
= ada_coerce_to_simple_array (container
);
8097 lhs
= ada_coerce_ref (lhs
);
8098 if (!deprecated_value_modifiable (lhs
))
8099 error (_("Left operand of assignment is not a modifiable lvalue."));
8101 lhs_type
= value_type (lhs
);
8102 if (ada_is_direct_array_type (lhs_type
))
8104 lhs
= ada_coerce_to_simple_array (lhs
);
8105 lhs_type
= value_type (lhs
);
8106 low_index
= TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type
);
8107 high_index
= TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type
);
8108 is_array_aggregate
= 1;
8110 else if (TYPE_CODE (lhs_type
) == TYPE_CODE_STRUCT
)
8113 high_index
= num_visible_fields (lhs_type
) - 1;
8114 is_array_aggregate
= 0;
8117 error (_("Left-hand side must be array or record."));
8119 num_specs
= num_component_specs (exp
, *pos
- 3);
8120 max_indices
= 4 * num_specs
+ 4;
8121 indices
= alloca (max_indices
* sizeof (indices
[0]));
8122 indices
[0] = indices
[1] = low_index
- 1;
8123 indices
[2] = indices
[3] = high_index
+ 1;
8126 for (i
= 0; i
< n
; i
+= 1)
8128 switch (exp
->elts
[*pos
].opcode
)
8131 aggregate_assign_from_choices (container
, lhs
, exp
, pos
, indices
,
8132 &num_indices
, max_indices
,
8133 low_index
, high_index
);
8136 aggregate_assign_positional (container
, lhs
, exp
, pos
, indices
,
8137 &num_indices
, max_indices
,
8138 low_index
, high_index
);
8142 error (_("Misplaced 'others' clause"));
8143 aggregate_assign_others (container
, lhs
, exp
, pos
, indices
,
8144 num_indices
, low_index
, high_index
);
8147 error (_("Internal error: bad aggregate clause"));
8154 /* Assign into the component of LHS indexed by the OP_POSITIONAL
8155 construct at *POS, updating *POS past the construct, given that
8156 the positions are relative to lower bound LOW, where HIGH is the
8157 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
8158 updating *NUM_INDICES as needed. CONTAINER is as for
8159 assign_aggregate. */
8161 aggregate_assign_positional (struct value
*container
,
8162 struct value
*lhs
, struct expression
*exp
,
8163 int *pos
, LONGEST
*indices
, int *num_indices
,
8164 int max_indices
, LONGEST low
, LONGEST high
)
8166 LONGEST ind
= longest_to_int (exp
->elts
[*pos
+ 1].longconst
) + low
;
8168 if (ind
- 1 == high
)
8169 warning (_("Extra components in aggregate ignored."));
8172 add_component_interval (ind
, ind
, indices
, num_indices
, max_indices
);
8174 assign_component (container
, lhs
, ind
, exp
, pos
);
8177 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8180 /* Assign into the components of LHS indexed by the OP_CHOICES
8181 construct at *POS, updating *POS past the construct, given that
8182 the allowable indices are LOW..HIGH. Record the indices assigned
8183 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
8184 needed. CONTAINER is as for assign_aggregate. */
8186 aggregate_assign_from_choices (struct value
*container
,
8187 struct value
*lhs
, struct expression
*exp
,
8188 int *pos
, LONGEST
*indices
, int *num_indices
,
8189 int max_indices
, LONGEST low
, LONGEST high
)
8192 int n_choices
= longest_to_int (exp
->elts
[*pos
+1].longconst
);
8193 int choice_pos
, expr_pc
;
8194 int is_array
= ada_is_direct_array_type (value_type (lhs
));
8196 choice_pos
= *pos
+= 3;
8198 for (j
= 0; j
< n_choices
; j
+= 1)
8199 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8201 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8203 for (j
= 0; j
< n_choices
; j
+= 1)
8205 LONGEST lower
, upper
;
8206 enum exp_opcode op
= exp
->elts
[choice_pos
].opcode
;
8207 if (op
== OP_DISCRETE_RANGE
)
8210 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8212 upper
= value_as_long (ada_evaluate_subexp (NULL
, exp
, pos
,
8217 lower
= value_as_long (ada_evaluate_subexp (NULL
, exp
, &choice_pos
,
8228 name
= &exp
->elts
[choice_pos
+ 2].string
;
8231 name
= SYMBOL_NATURAL_NAME (exp
->elts
[choice_pos
+ 2].symbol
);
8234 error (_("Invalid record component association."));
8236 ada_evaluate_subexp (NULL
, exp
, &choice_pos
, EVAL_SKIP
);
8238 if (! find_struct_field (name
, value_type (lhs
), 0,
8239 NULL
, NULL
, NULL
, NULL
, &ind
))
8240 error (_("Unknown component name: %s."), name
);
8241 lower
= upper
= ind
;
8244 if (lower
<= upper
&& (lower
< low
|| upper
> high
))
8245 error (_("Index in component association out of bounds."));
8247 add_component_interval (lower
, upper
, indices
, num_indices
,
8249 while (lower
<= upper
)
8253 assign_component (container
, lhs
, lower
, exp
, &pos1
);
8259 /* Assign the value of the expression in the OP_OTHERS construct in
8260 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
8261 have not been previously assigned. The index intervals already assigned
8262 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
8263 OP_OTHERS clause. CONTAINER is as for assign_aggregate*/
8265 aggregate_assign_others (struct value
*container
,
8266 struct value
*lhs
, struct expression
*exp
,
8267 int *pos
, LONGEST
*indices
, int num_indices
,
8268 LONGEST low
, LONGEST high
)
8271 int expr_pc
= *pos
+1;
8273 for (i
= 0; i
< num_indices
- 2; i
+= 2)
8276 for (ind
= indices
[i
+ 1] + 1; ind
< indices
[i
+ 2]; ind
+= 1)
8280 assign_component (container
, lhs
, ind
, exp
, &pos
);
8283 ada_evaluate_subexp (NULL
, exp
, pos
, EVAL_SKIP
);
8286 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
8287 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
8288 modifying *SIZE as needed. It is an error if *SIZE exceeds
8289 MAX_SIZE. The resulting intervals do not overlap. */
8291 add_component_interval (LONGEST low
, LONGEST high
,
8292 LONGEST
* indices
, int *size
, int max_size
)
8295 for (i
= 0; i
< *size
; i
+= 2) {
8296 if (high
>= indices
[i
] && low
<= indices
[i
+ 1])
8299 for (kh
= i
+ 2; kh
< *size
; kh
+= 2)
8300 if (high
< indices
[kh
])
8302 if (low
< indices
[i
])
8304 indices
[i
+ 1] = indices
[kh
- 1];
8305 if (high
> indices
[i
+ 1])
8306 indices
[i
+ 1] = high
;
8307 memcpy (indices
+ i
+ 2, indices
+ kh
, *size
- kh
);
8308 *size
-= kh
- i
- 2;
8311 else if (high
< indices
[i
])
8315 if (*size
== max_size
)
8316 error (_("Internal error: miscounted aggregate components."));
8318 for (j
= *size
-1; j
>= i
+2; j
-= 1)
8319 indices
[j
] = indices
[j
- 2];
8321 indices
[i
+ 1] = high
;
8324 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
8327 static struct value
*
8328 ada_value_cast (struct type
*type
, struct value
*arg2
, enum noside noside
)
8330 if (type
== ada_check_typedef (value_type (arg2
)))
8333 if (ada_is_fixed_point_type (type
))
8334 return (cast_to_fixed (type
, arg2
));
8336 if (ada_is_fixed_point_type (value_type (arg2
)))
8337 return cast_from_fixed (type
, arg2
);
8339 return value_cast (type
, arg2
);
8342 static struct value
*
8343 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
8344 int *pos
, enum noside noside
)
8347 int tem
, tem2
, tem3
;
8349 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
8352 struct value
**argvec
;
8356 op
= exp
->elts
[pc
].opcode
;
8362 arg1
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8363 arg1
= unwrap_value (arg1
);
8365 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
8366 then we need to perform the conversion manually, because
8367 evaluate_subexp_standard doesn't do it. This conversion is
8368 necessary in Ada because the different kinds of float/fixed
8369 types in Ada have different representations.
8371 Similarly, we need to perform the conversion from OP_LONG
8373 if ((op
== OP_DOUBLE
|| op
== OP_LONG
) && expect_type
!= NULL
)
8374 arg1
= ada_value_cast (expect_type
, arg1
, noside
);
8380 struct value
*result
;
8382 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8383 /* The result type will have code OP_STRING, bashed there from
8384 OP_ARRAY. Bash it back. */
8385 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
8386 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
8392 type
= exp
->elts
[pc
+ 1].type
;
8393 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
8394 if (noside
== EVAL_SKIP
)
8396 arg1
= ada_value_cast (type
, arg1
, noside
);
8401 type
= exp
->elts
[pc
+ 1].type
;
8402 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
8405 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8406 if (exp
->elts
[*pos
].opcode
== OP_AGGREGATE
)
8408 arg1
= assign_aggregate (arg1
, arg1
, exp
, pos
, noside
);
8409 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8411 return ada_value_assign (arg1
, arg1
);
8413 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
8414 except if the lhs of our assignment is a convenience variable.
8415 In the case of assigning to a convenience variable, the lhs
8416 should be exactly the result of the evaluation of the rhs. */
8417 type
= value_type (arg1
);
8418 if (VALUE_LVAL (arg1
) == lval_internalvar
)
8420 arg2
= evaluate_subexp (type
, exp
, pos
, noside
);
8421 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8423 if (ada_is_fixed_point_type (value_type (arg1
)))
8424 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
8425 else if (ada_is_fixed_point_type (value_type (arg2
)))
8427 (_("Fixed-point values must be assigned to fixed-point variables"));
8429 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
8430 return ada_value_assign (arg1
, arg2
);
8433 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8434 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8435 if (noside
== EVAL_SKIP
)
8437 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8438 return (value_from_longest
8440 value_as_long (arg1
) + value_as_long (arg2
)));
8441 if ((ada_is_fixed_point_type (value_type (arg1
))
8442 || ada_is_fixed_point_type (value_type (arg2
)))
8443 && value_type (arg1
) != value_type (arg2
))
8444 error (_("Operands of fixed-point addition must have the same type"));
8445 /* Do the addition, and cast the result to the type of the first
8446 argument. We cannot cast the result to a reference type, so if
8447 ARG1 is a reference type, find its underlying type. */
8448 type
= value_type (arg1
);
8449 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8450 type
= TYPE_TARGET_TYPE (type
);
8451 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8452 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_ADD
));
8455 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8456 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8457 if (noside
== EVAL_SKIP
)
8459 if (TYPE_CODE (value_type (arg1
)) == TYPE_CODE_PTR
)
8460 return (value_from_longest
8462 value_as_long (arg1
) - value_as_long (arg2
)));
8463 if ((ada_is_fixed_point_type (value_type (arg1
))
8464 || ada_is_fixed_point_type (value_type (arg2
)))
8465 && value_type (arg1
) != value_type (arg2
))
8466 error (_("Operands of fixed-point subtraction must have the same type"));
8467 /* Do the substraction, and cast the result to the type of the first
8468 argument. We cannot cast the result to a reference type, so if
8469 ARG1 is a reference type, find its underlying type. */
8470 type
= value_type (arg1
);
8471 while (TYPE_CODE (type
) == TYPE_CODE_REF
)
8472 type
= TYPE_TARGET_TYPE (type
);
8473 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8474 return value_cast (type
, value_binop (arg1
, arg2
, BINOP_SUB
));
8478 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8479 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8480 if (noside
== EVAL_SKIP
)
8482 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8483 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8484 return value_zero (value_type (arg1
), not_lval
);
8487 type
= builtin_type (exp
->gdbarch
)->builtin_double
;
8488 if (ada_is_fixed_point_type (value_type (arg1
)))
8489 arg1
= cast_from_fixed (type
, arg1
);
8490 if (ada_is_fixed_point_type (value_type (arg2
)))
8491 arg2
= cast_from_fixed (type
, arg2
);
8492 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8493 return ada_value_binop (arg1
, arg2
, op
);
8498 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8499 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8500 if (noside
== EVAL_SKIP
)
8502 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8503 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8504 return value_zero (value_type (arg1
), not_lval
);
8507 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8508 return ada_value_binop (arg1
, arg2
, op
);
8512 case BINOP_NOTEQUAL
:
8513 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8514 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
8515 if (noside
== EVAL_SKIP
)
8517 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8521 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8522 tem
= ada_value_equal (arg1
, arg2
);
8524 if (op
== BINOP_NOTEQUAL
)
8526 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8527 return value_from_longest (type
, (LONGEST
) tem
);
8530 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8531 if (noside
== EVAL_SKIP
)
8533 else if (ada_is_fixed_point_type (value_type (arg1
)))
8534 return value_cast (value_type (arg1
), value_neg (arg1
));
8537 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
8538 return value_neg (arg1
);
8541 case BINOP_LOGICAL_AND
:
8542 case BINOP_LOGICAL_OR
:
8543 case UNOP_LOGICAL_NOT
:
8548 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8549 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8550 return value_cast (type
, val
);
8553 case BINOP_BITWISE_AND
:
8554 case BINOP_BITWISE_IOR
:
8555 case BINOP_BITWISE_XOR
:
8559 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8561 val
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8563 return value_cast (value_type (arg1
), val
);
8569 if (noside
== EVAL_SKIP
)
8574 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
8575 /* Only encountered when an unresolved symbol occurs in a
8576 context other than a function call, in which case, it is
8578 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8579 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
8580 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8582 type
= static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
));
8583 if (ada_is_tagged_type (type
, 0))
8585 /* Tagged types are a little special in the fact that the real
8586 type is dynamic and can only be determined by inspecting the
8587 object's tag. This means that we need to get the object's
8588 value first (EVAL_NORMAL) and then extract the actual object
8591 Note that we cannot skip the final step where we extract
8592 the object type from its tag, because the EVAL_NORMAL phase
8593 results in dynamic components being resolved into fixed ones.
8594 This can cause problems when trying to print the type
8595 description of tagged types whose parent has a dynamic size:
8596 We use the type name of the "_parent" component in order
8597 to print the name of the ancestor type in the type description.
8598 If that component had a dynamic size, the resolution into
8599 a fixed type would result in the loss of that type name,
8600 thus preventing us from printing the name of the ancestor
8601 type in the type description. */
8602 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_NORMAL
);
8603 return value_zero (type_from_tag (ada_value_tag (arg1
)), not_lval
);
8608 (to_static_fixed_type
8609 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
8615 unwrap_value (evaluate_subexp_standard
8616 (expect_type
, exp
, pos
, noside
));
8617 return ada_to_fixed_value (arg1
);
8623 /* Allocate arg vector, including space for the function to be
8624 called in argvec[0] and a terminating NULL. */
8625 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8627 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
8629 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
8630 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
8631 error (_("Unexpected unresolved symbol, %s, during evaluation"),
8632 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
8635 for (tem
= 0; tem
<= nargs
; tem
+= 1)
8636 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8639 if (noside
== EVAL_SKIP
)
8643 if (ada_is_packed_array_type (desc_base_type (value_type (argvec
[0]))))
8644 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
8645 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
8646 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
8647 && VALUE_LVAL (argvec
[0]) == lval_memory
))
8648 argvec
[0] = value_addr (argvec
[0]);
8650 type
= ada_check_typedef (value_type (argvec
[0]));
8651 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
8653 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
8655 case TYPE_CODE_FUNC
:
8656 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8658 case TYPE_CODE_ARRAY
:
8660 case TYPE_CODE_STRUCT
:
8661 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
8662 argvec
[0] = ada_value_ind (argvec
[0]);
8663 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
8666 error (_("cannot subscript or call something of type `%s'"),
8667 ada_type_name (value_type (argvec
[0])));
8672 switch (TYPE_CODE (type
))
8674 case TYPE_CODE_FUNC
:
8675 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8676 return allocate_value (TYPE_TARGET_TYPE (type
));
8677 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
8678 case TYPE_CODE_STRUCT
:
8682 arity
= ada_array_arity (type
);
8683 type
= ada_array_element_type (type
, nargs
);
8685 error (_("cannot subscript or call a record"));
8687 error (_("wrong number of subscripts; expecting %d"), arity
);
8688 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8689 return value_zero (ada_aligned_type (type
), lval_memory
);
8691 unwrap_value (ada_value_subscript
8692 (argvec
[0], nargs
, argvec
+ 1));
8694 case TYPE_CODE_ARRAY
:
8695 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8697 type
= ada_array_element_type (type
, nargs
);
8699 error (_("element type of array unknown"));
8701 return value_zero (ada_aligned_type (type
), lval_memory
);
8704 unwrap_value (ada_value_subscript
8705 (ada_coerce_to_simple_array (argvec
[0]),
8706 nargs
, argvec
+ 1));
8707 case TYPE_CODE_PTR
: /* Pointer to array */
8708 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
8709 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8711 type
= ada_array_element_type (type
, nargs
);
8713 error (_("element type of array unknown"));
8715 return value_zero (ada_aligned_type (type
), lval_memory
);
8718 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
8719 nargs
, argvec
+ 1));
8722 error (_("Attempt to index or call something other than an "
8723 "array or function"));
8728 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8729 struct value
*low_bound_val
=
8730 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8731 struct value
*high_bound_val
=
8732 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8735 low_bound_val
= coerce_ref (low_bound_val
);
8736 high_bound_val
= coerce_ref (high_bound_val
);
8737 low_bound
= pos_atr (low_bound_val
);
8738 high_bound
= pos_atr (high_bound_val
);
8740 if (noside
== EVAL_SKIP
)
8743 /* If this is a reference to an aligner type, then remove all
8745 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8746 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
8747 TYPE_TARGET_TYPE (value_type (array
)) =
8748 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
8750 if (ada_is_packed_array_type (value_type (array
)))
8751 error (_("cannot slice a packed array"));
8753 /* If this is a reference to an array or an array lvalue,
8754 convert to a pointer. */
8755 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
8756 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
8757 && VALUE_LVAL (array
) == lval_memory
))
8758 array
= value_addr (array
);
8760 if (noside
== EVAL_AVOID_SIDE_EFFECTS
8761 && ada_is_array_descriptor_type (ada_check_typedef
8762 (value_type (array
))))
8763 return empty_array (ada_type_of_array (array
, 0), low_bound
);
8765 array
= ada_coerce_to_simple_array_ptr (array
);
8767 /* If we have more than one level of pointer indirection,
8768 dereference the value until we get only one level. */
8769 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
8770 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
8772 array
= value_ind (array
);
8774 /* Make sure we really do have an array type before going further,
8775 to avoid a SEGV when trying to get the index type or the target
8776 type later down the road if the debug info generated by
8777 the compiler is incorrect or incomplete. */
8778 if (!ada_is_simple_array_type (value_type (array
)))
8779 error (_("cannot take slice of non-array"));
8781 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
8783 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8784 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
8788 struct type
*arr_type0
=
8789 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
8791 return ada_value_slice_ptr (array
, arr_type0
,
8792 longest_to_int (low_bound
),
8793 longest_to_int (high_bound
));
8796 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8798 else if (high_bound
< low_bound
)
8799 return empty_array (value_type (array
), low_bound
);
8801 return ada_value_slice (array
, longest_to_int (low_bound
),
8802 longest_to_int (high_bound
));
8807 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8808 type
= exp
->elts
[pc
+ 1].type
;
8810 if (noside
== EVAL_SKIP
)
8813 switch (TYPE_CODE (type
))
8816 lim_warning (_("Membership test incompletely implemented; "
8817 "always returns true"));
8818 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8819 return value_from_longest (type
, (LONGEST
) 1);
8821 case TYPE_CODE_RANGE
:
8822 arg2
= value_from_longest (type
, TYPE_LOW_BOUND (type
));
8823 arg3
= value_from_longest (type
, TYPE_HIGH_BOUND (type
));
8824 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8825 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8826 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8828 value_from_longest (type
,
8829 (value_less (arg1
, arg3
)
8830 || value_equal (arg1
, arg3
))
8831 && (value_less (arg2
, arg1
)
8832 || value_equal (arg2
, arg1
)));
8835 case BINOP_IN_BOUNDS
:
8837 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8838 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8840 if (noside
== EVAL_SKIP
)
8843 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8845 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8846 return value_zero (type
, not_lval
);
8849 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8851 if (tem
< 1 || tem
> ada_array_arity (value_type (arg2
)))
8852 error (_("invalid dimension number to 'range"));
8854 arg3
= ada_array_bound (arg2
, tem
, 1);
8855 arg2
= ada_array_bound (arg2
, tem
, 0);
8857 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8858 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8859 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8861 value_from_longest (type
,
8862 (value_less (arg1
, arg3
)
8863 || value_equal (arg1
, arg3
))
8864 && (value_less (arg2
, arg1
)
8865 || value_equal (arg2
, arg1
)));
8867 case TERNOP_IN_RANGE
:
8868 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8869 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8870 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8872 if (noside
== EVAL_SKIP
)
8875 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
8876 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg3
);
8877 type
= language_bool_type (exp
->language_defn
, exp
->gdbarch
);
8879 value_from_longest (type
,
8880 (value_less (arg1
, arg3
)
8881 || value_equal (arg1
, arg3
))
8882 && (value_less (arg2
, arg1
)
8883 || value_equal (arg2
, arg1
)));
8889 struct type
*type_arg
;
8890 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8892 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
8894 type_arg
= exp
->elts
[pc
+ 2].type
;
8898 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8902 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
8903 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
8904 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
8907 if (noside
== EVAL_SKIP
)
8910 if (type_arg
== NULL
)
8912 arg1
= ada_coerce_ref (arg1
);
8914 if (ada_is_packed_array_type (value_type (arg1
)))
8915 arg1
= ada_coerce_to_simple_array (arg1
);
8917 if (tem
< 1 || tem
> ada_array_arity (value_type (arg1
)))
8918 error (_("invalid dimension number to '%s"),
8919 ada_attribute_name (op
));
8921 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8923 type
= ada_index_type (value_type (arg1
), tem
);
8926 (_("attempt to take bound of something that is not an array"));
8927 return allocate_value (type
);
8932 default: /* Should never happen. */
8933 error (_("unexpected attribute encountered"));
8935 return ada_array_bound (arg1
, tem
, 0);
8937 return ada_array_bound (arg1
, tem
, 1);
8939 return ada_array_length (arg1
, tem
);
8942 else if (discrete_type_p (type_arg
))
8944 struct type
*range_type
;
8945 char *name
= ada_type_name (type_arg
);
8947 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
8949 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
8950 if (range_type
== NULL
)
8951 range_type
= type_arg
;
8955 error (_("unexpected attribute encountered"));
8957 return value_from_longest
8958 (range_type
, discrete_type_low_bound (range_type
));
8960 return value_from_longest
8961 (range_type
, discrete_type_high_bound (range_type
));
8963 error (_("the 'length attribute applies only to array types"));
8966 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
8967 error (_("unimplemented type attribute"));
8972 if (ada_is_packed_array_type (type_arg
))
8973 type_arg
= decode_packed_array_type (type_arg
);
8975 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
8976 error (_("invalid dimension number to '%s"),
8977 ada_attribute_name (op
));
8979 type
= ada_index_type (type_arg
, tem
);
8982 (_("attempt to take bound of something that is not an array"));
8983 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8984 return allocate_value (type
);
8989 error (_("unexpected attribute encountered"));
8991 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
8992 return value_from_longest (type
, low
);
8994 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
8995 return value_from_longest (type
, high
);
8997 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
8998 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
8999 return value_from_longest (type
, high
- low
+ 1);
9005 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9006 if (noside
== EVAL_SKIP
)
9009 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9010 return value_zero (ada_tag_type (arg1
), not_lval
);
9012 return ada_value_tag (arg1
);
9016 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9017 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9018 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9019 if (noside
== EVAL_SKIP
)
9021 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9022 return value_zero (value_type (arg1
), not_lval
);
9025 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9026 return value_binop (arg1
, arg2
,
9027 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
9030 case OP_ATR_MODULUS
:
9032 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
9033 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9035 if (noside
== EVAL_SKIP
)
9038 if (!ada_is_modular_type (type_arg
))
9039 error (_("'modulus must be applied to modular type"));
9041 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
9042 ada_modulus (type_arg
));
9047 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9048 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9049 if (noside
== EVAL_SKIP
)
9051 type
= builtin_type (exp
->gdbarch
)->builtin_int
;
9052 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9053 return value_zero (type
, not_lval
);
9055 return value_pos_atr (type
, arg1
);
9058 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9059 type
= value_type (arg1
);
9061 /* If the argument is a reference, then dereference its type, since
9062 the user is really asking for the size of the actual object,
9063 not the size of the pointer. */
9064 if (TYPE_CODE (type
) == TYPE_CODE_REF
)
9065 type
= TYPE_TARGET_TYPE (type
);
9067 if (noside
== EVAL_SKIP
)
9069 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9070 return value_zero (builtin_type_int32
, not_lval
);
9072 return value_from_longest (builtin_type_int32
,
9073 TARGET_CHAR_BIT
* TYPE_LENGTH (type
));
9076 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9077 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9078 type
= exp
->elts
[pc
+ 2].type
;
9079 if (noside
== EVAL_SKIP
)
9081 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9082 return value_zero (type
, not_lval
);
9084 return value_val_atr (type
, arg1
);
9087 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9088 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9089 if (noside
== EVAL_SKIP
)
9091 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9092 return value_zero (value_type (arg1
), not_lval
);
9095 /* For integer exponentiation operations,
9096 only promote the first argument. */
9097 if (is_integral_type (value_type (arg2
)))
9098 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9100 binop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
, &arg2
);
9102 return value_binop (arg1
, arg2
, op
);
9106 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9107 if (noside
== EVAL_SKIP
)
9113 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9114 if (noside
== EVAL_SKIP
)
9116 unop_promote (exp
->language_defn
, exp
->gdbarch
, &arg1
);
9117 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
9118 return value_neg (arg1
);
9123 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9124 if (noside
== EVAL_SKIP
)
9126 type
= ada_check_typedef (value_type (arg1
));
9127 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9129 if (ada_is_array_descriptor_type (type
))
9130 /* GDB allows dereferencing GNAT array descriptors. */
9132 struct type
*arrType
= ada_type_of_array (arg1
, 0);
9133 if (arrType
== NULL
)
9134 error (_("Attempt to dereference null array pointer."));
9135 return value_at_lazy (arrType
, 0);
9137 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
9138 || TYPE_CODE (type
) == TYPE_CODE_REF
9139 /* In C you can dereference an array to get the 1st elt. */
9140 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9142 type
= to_static_fixed_type
9144 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
9146 return value_zero (type
, lval_memory
);
9148 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9150 /* GDB allows dereferencing an int. */
9151 if (expect_type
== NULL
)
9152 return value_zero (builtin_type (exp
->gdbarch
)->builtin_int
,
9157 to_static_fixed_type (ada_aligned_type (expect_type
));
9158 return value_zero (expect_type
, lval_memory
);
9162 error (_("Attempt to take contents of a non-pointer value."));
9164 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
9165 type
= ada_check_typedef (value_type (arg1
));
9167 if (TYPE_CODE (type
) == TYPE_CODE_INT
&& expect_type
!= NULL
)
9168 /* GDB allows dereferencing an int. We give it the expected
9169 type (which will be set in the case of a coercion or
9171 return ada_value_ind (value_cast (lookup_pointer_type (expect_type
),
9174 if (ada_is_array_descriptor_type (type
))
9175 /* GDB allows dereferencing GNAT array descriptors. */
9176 return ada_coerce_to_simple_array (arg1
);
9178 return ada_value_ind (arg1
);
9180 case STRUCTOP_STRUCT
:
9181 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9182 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
9183 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9184 if (noside
== EVAL_SKIP
)
9186 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9188 struct type
*type1
= value_type (arg1
);
9189 if (ada_is_tagged_type (type1
, 1))
9191 type
= ada_lookup_struct_elt_type (type1
,
9192 &exp
->elts
[pc
+ 2].string
,
9195 /* In this case, we assume that the field COULD exist
9196 in some extension of the type. Return an object of
9197 "type" void, which will match any formal
9198 (see ada_type_match). */
9199 return value_zero (builtin_type_void
, lval_memory
);
9203 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
9206 return value_zero (ada_aligned_type (type
), lval_memory
);
9210 ada_to_fixed_value (unwrap_value
9211 (ada_value_struct_elt
9212 (arg1
, &exp
->elts
[pc
+ 2].string
, 0)));
9214 /* The value is not supposed to be used. This is here to make it
9215 easier to accommodate expressions that contain types. */
9217 if (noside
== EVAL_SKIP
)
9219 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9220 return allocate_value (exp
->elts
[pc
+ 1].type
);
9222 error (_("Attempt to use a type name as an expression"));
9227 case OP_DISCRETE_RANGE
:
9230 if (noside
== EVAL_NORMAL
)
9234 error (_("Undefined name, ambiguous name, or renaming used in "
9235 "component association: %s."), &exp
->elts
[pc
+2].string
);
9237 error (_("Aggregates only allowed on the right of an assignment"));
9239 internal_error (__FILE__
, __LINE__
, _("aggregate apparently mangled"));
9242 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
9244 for (tem
= 0; tem
< nargs
; tem
+= 1)
9245 ada_evaluate_subexp (NULL
, exp
, pos
, noside
);
9250 return value_from_longest (builtin_type_int8
, (LONGEST
) 1);
9256 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9257 type name that encodes the 'small and 'delta information.
9258 Otherwise, return NULL. */
9261 fixed_type_info (struct type
*type
)
9263 const char *name
= ada_type_name (type
);
9264 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
9266 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
9268 const char *tail
= strstr (name
, "___XF_");
9274 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
9275 return fixed_type_info (TYPE_TARGET_TYPE (type
));
9280 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9283 ada_is_fixed_point_type (struct type
*type
)
9285 return fixed_type_info (type
) != NULL
;
9288 /* Return non-zero iff TYPE represents a System.Address type. */
9291 ada_is_system_address_type (struct type
*type
)
9293 return (TYPE_NAME (type
)
9294 && strcmp (TYPE_NAME (type
), "system__address") == 0);
9297 /* Assuming that TYPE is the representation of an Ada fixed-point
9298 type, return its delta, or -1 if the type is malformed and the
9299 delta cannot be determined. */
9302 ada_delta (struct type
*type
)
9304 const char *encoding
= fixed_type_info (type
);
9307 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
9310 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
9313 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9314 factor ('SMALL value) associated with the type. */
9317 scaling_factor (struct type
*type
)
9319 const char *encoding
= fixed_type_info (type
);
9320 unsigned long num0
, den0
, num1
, den1
;
9323 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
9328 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
9330 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
9334 /* Assuming that X is the representation of a value of fixed-point
9335 type TYPE, return its floating-point equivalent. */
9338 ada_fixed_to_float (struct type
*type
, LONGEST x
)
9340 return (DOUBLEST
) x
*scaling_factor (type
);
9343 /* The representation of a fixed-point value of type TYPE
9344 corresponding to the value X. */
9347 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
9349 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
9353 /* VAX floating formats */
9355 /* Non-zero iff TYPE represents one of the special VAX floating-point
9359 ada_is_vax_floating_type (struct type
*type
)
9362 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
9365 && (TYPE_CODE (type
) == TYPE_CODE_INT
9366 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
9367 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
9370 /* The type of special VAX floating-point type this is, assuming
9371 ada_is_vax_floating_point. */
9374 ada_vax_float_type_suffix (struct type
*type
)
9376 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
9379 /* A value representing the special debugging function that outputs
9380 VAX floating-point values of the type represented by TYPE. Assumes
9381 ada_is_vax_floating_type (TYPE). */
9384 ada_vax_float_print_function (struct type
*type
)
9386 switch (ada_vax_float_type_suffix (type
))
9389 return get_var_value ("DEBUG_STRING_F", 0);
9391 return get_var_value ("DEBUG_STRING_D", 0);
9393 return get_var_value ("DEBUG_STRING_G", 0);
9395 error (_("invalid VAX floating-point type"));
9402 /* Scan STR beginning at position K for a discriminant name, and
9403 return the value of that discriminant field of DVAL in *PX. If
9404 PNEW_K is not null, put the position of the character beyond the
9405 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9406 not alter *PX and *PNEW_K if unsuccessful. */
9409 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
9412 static char *bound_buffer
= NULL
;
9413 static size_t bound_buffer_len
= 0;
9416 struct value
*bound_val
;
9418 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9421 pend
= strstr (str
+ k
, "__");
9425 k
+= strlen (bound
);
9429 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9430 bound
= bound_buffer
;
9431 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9432 bound
[pend
- (str
+ k
)] = '\0';
9436 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
9437 if (bound_val
== NULL
)
9440 *px
= value_as_long (bound_val
);
9446 /* Value of variable named NAME in the current environment. If
9447 no such variable found, then if ERR_MSG is null, returns 0, and
9448 otherwise causes an error with message ERR_MSG. */
9450 static struct value
*
9451 get_var_value (char *name
, char *err_msg
)
9453 struct ada_symbol_info
*syms
;
9456 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9461 if (err_msg
== NULL
)
9464 error (("%s"), err_msg
);
9467 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9470 /* Value of integer variable named NAME in the current environment. If
9471 no such variable found, returns 0, and sets *FLAG to 0. If
9472 successful, sets *FLAG to 1. */
9475 get_int_var_value (char *name
, int *flag
)
9477 struct value
*var_val
= get_var_value (name
, 0);
9489 return value_as_long (var_val
);
9494 /* Return a range type whose base type is that of the range type named
9495 NAME in the current environment, and whose bounds are calculated
9496 from NAME according to the GNAT range encoding conventions.
9497 Extract discriminant values, if needed, from DVAL. If a new type
9498 must be created, allocate in OBJFILE's space. The bounds
9499 information, in general, is encoded in NAME, the base type given in
9500 the named range type. */
9502 static struct type
*
9503 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
9505 struct type
*raw_type
= ada_find_any_type (name
);
9506 struct type
*base_type
;
9509 if (raw_type
== NULL
)
9510 base_type
= builtin_type_int32
;
9511 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9512 base_type
= TYPE_TARGET_TYPE (raw_type
);
9514 base_type
= raw_type
;
9516 subtype_info
= strstr (name
, "___XD");
9517 if (subtype_info
== NULL
)
9519 LONGEST L
= discrete_type_low_bound (raw_type
);
9520 LONGEST U
= discrete_type_high_bound (raw_type
);
9521 if (L
< INT_MIN
|| U
> INT_MAX
)
9524 return create_range_type (alloc_type (objfile
), raw_type
,
9525 discrete_type_low_bound (raw_type
),
9526 discrete_type_high_bound (raw_type
));
9530 static char *name_buf
= NULL
;
9531 static size_t name_len
= 0;
9532 int prefix_len
= subtype_info
- name
;
9538 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
9539 strncpy (name_buf
, name
, prefix_len
);
9540 name_buf
[prefix_len
] = '\0';
9543 bounds_str
= strchr (subtype_info
, '_');
9546 if (*subtype_info
== 'L')
9548 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
9549 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
9551 if (bounds_str
[n
] == '_')
9553 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
9560 strcpy (name_buf
+ prefix_len
, "___L");
9561 L
= get_int_var_value (name_buf
, &ok
);
9564 lim_warning (_("Unknown lower bound, using 1."));
9569 if (*subtype_info
== 'U')
9571 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
9572 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
9578 strcpy (name_buf
+ prefix_len
, "___U");
9579 U
= get_int_var_value (name_buf
, &ok
);
9582 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
9587 if (objfile
== NULL
)
9588 objfile
= TYPE_OBJFILE (base_type
);
9589 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
9590 TYPE_NAME (type
) = name
;
9595 /* True iff NAME is the name of a range type. */
9598 ada_is_range_type_name (const char *name
)
9600 return (name
!= NULL
&& strstr (name
, "___XD"));
9606 /* True iff TYPE is an Ada modular type. */
9609 ada_is_modular_type (struct type
*type
)
9611 struct type
*subranged_type
= base_type (type
);
9613 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
9614 && TYPE_CODE (subranged_type
) == TYPE_CODE_INT
9615 && TYPE_UNSIGNED (subranged_type
));
9618 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9621 ada_modulus (struct type
* type
)
9623 return (ULONGEST
) (unsigned int) TYPE_HIGH_BOUND (type
) + 1;
9627 /* Ada exception catchpoint support:
9628 ---------------------------------
9630 We support 3 kinds of exception catchpoints:
9631 . catchpoints on Ada exceptions
9632 . catchpoints on unhandled Ada exceptions
9633 . catchpoints on failed assertions
9635 Exceptions raised during failed assertions, or unhandled exceptions
9636 could perfectly be caught with the general catchpoint on Ada exceptions.
9637 However, we can easily differentiate these two special cases, and having
9638 the option to distinguish these two cases from the rest can be useful
9639 to zero-in on certain situations.
9641 Exception catchpoints are a specialized form of breakpoint,
9642 since they rely on inserting breakpoints inside known routines
9643 of the GNAT runtime. The implementation therefore uses a standard
9644 breakpoint structure of the BP_BREAKPOINT type, but with its own set
9647 Support in the runtime for exception catchpoints have been changed
9648 a few times already, and these changes affect the implementation
9649 of these catchpoints. In order to be able to support several
9650 variants of the runtime, we use a sniffer that will determine
9651 the runtime variant used by the program being debugged.
9653 At this time, we do not support the use of conditions on Ada exception
9654 catchpoints. The COND and COND_STRING fields are therefore set
9655 to NULL (most of the time, see below).
9657 Conditions where EXP_STRING, COND, and COND_STRING are used:
9659 When a user specifies the name of a specific exception in the case
9660 of catchpoints on Ada exceptions, we store the name of that exception
9661 in the EXP_STRING. We then translate this request into an actual
9662 condition stored in COND_STRING, and then parse it into an expression
9665 /* The different types of catchpoints that we introduced for catching
9668 enum exception_catchpoint_kind
9671 ex_catch_exception_unhandled
,
9675 /* Ada's standard exceptions. */
9677 static char *standard_exc
[] = {
9684 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype
) (void);
9686 /* A structure that describes how to support exception catchpoints
9687 for a given executable. */
9689 struct exception_support_info
9691 /* The name of the symbol to break on in order to insert
9692 a catchpoint on exceptions. */
9693 const char *catch_exception_sym
;
9695 /* The name of the symbol to break on in order to insert
9696 a catchpoint on unhandled exceptions. */
9697 const char *catch_exception_unhandled_sym
;
9699 /* The name of the symbol to break on in order to insert
9700 a catchpoint on failed assertions. */
9701 const char *catch_assert_sym
;
9703 /* Assuming that the inferior just triggered an unhandled exception
9704 catchpoint, this function is responsible for returning the address
9705 in inferior memory where the name of that exception is stored.
9706 Return zero if the address could not be computed. */
9707 ada_unhandled_exception_name_addr_ftype
*unhandled_exception_name_addr
;
9710 static CORE_ADDR
ada_unhandled_exception_name_addr (void);
9711 static CORE_ADDR
ada_unhandled_exception_name_addr_from_raise (void);
9713 /* The following exception support info structure describes how to
9714 implement exception catchpoints with the latest version of the
9715 Ada runtime (as of 2007-03-06). */
9717 static const struct exception_support_info default_exception_support_info
=
9719 "__gnat_debug_raise_exception", /* catch_exception_sym */
9720 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9721 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
9722 ada_unhandled_exception_name_addr
9725 /* The following exception support info structure describes how to
9726 implement exception catchpoints with a slightly older version
9727 of the Ada runtime. */
9729 static const struct exception_support_info exception_support_info_fallback
=
9731 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
9732 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
9733 "system__assertions__raise_assert_failure", /* catch_assert_sym */
9734 ada_unhandled_exception_name_addr_from_raise
9737 /* For each executable, we sniff which exception info structure to use
9738 and cache it in the following global variable. */
9740 static const struct exception_support_info
*exception_info
= NULL
;
9742 /* Inspect the Ada runtime and determine which exception info structure
9743 should be used to provide support for exception catchpoints.
9745 This function will always set exception_info, or raise an error. */
9748 ada_exception_support_info_sniffer (void)
9752 /* If the exception info is already known, then no need to recompute it. */
9753 if (exception_info
!= NULL
)
9756 /* Check the latest (default) exception support info. */
9757 sym
= standard_lookup (default_exception_support_info
.catch_exception_sym
,
9761 exception_info
= &default_exception_support_info
;
9765 /* Try our fallback exception suport info. */
9766 sym
= standard_lookup (exception_support_info_fallback
.catch_exception_sym
,
9770 exception_info
= &exception_support_info_fallback
;
9774 /* Sometimes, it is normal for us to not be able to find the routine
9775 we are looking for. This happens when the program is linked with
9776 the shared version of the GNAT runtime, and the program has not been
9777 started yet. Inform the user of these two possible causes if
9780 if (ada_update_initial_language (language_unknown
, NULL
) != language_ada
)
9781 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
9783 /* If the symbol does not exist, then check that the program is
9784 already started, to make sure that shared libraries have been
9785 loaded. If it is not started, this may mean that the symbol is
9786 in a shared library. */
9788 if (ptid_get_pid (inferior_ptid
) == 0)
9789 error (_("Unable to insert catchpoint. Try to start the program first."));
9791 /* At this point, we know that we are debugging an Ada program and
9792 that the inferior has been started, but we still are not able to
9793 find the run-time symbols. That can mean that we are in
9794 configurable run time mode, or that a-except as been optimized
9795 out by the linker... In any case, at this point it is not worth
9796 supporting this feature. */
9798 error (_("Cannot insert catchpoints in this configuration."));
9801 /* An observer of "executable_changed" events.
9802 Its role is to clear certain cached values that need to be recomputed
9803 each time a new executable is loaded by GDB. */
9806 ada_executable_changed_observer (void)
9808 /* If the executable changed, then it is possible that the Ada runtime
9809 is different. So we need to invalidate the exception support info
9811 exception_info
= NULL
;
9814 /* Return the name of the function at PC, NULL if could not find it.
9815 This function only checks the debugging information, not the symbol
9819 function_name_from_pc (CORE_ADDR pc
)
9823 if (!find_pc_partial_function (pc
, &func_name
, NULL
, NULL
))
9829 /* True iff FRAME is very likely to be that of a function that is
9830 part of the runtime system. This is all very heuristic, but is
9831 intended to be used as advice as to what frames are uninteresting
9835 is_known_support_routine (struct frame_info
*frame
)
9837 struct symtab_and_line sal
;
9841 /* If this code does not have any debugging information (no symtab),
9842 This cannot be any user code. */
9844 find_frame_sal (frame
, &sal
);
9845 if (sal
.symtab
== NULL
)
9848 /* If there is a symtab, but the associated source file cannot be
9849 located, then assume this is not user code: Selecting a frame
9850 for which we cannot display the code would not be very helpful
9851 for the user. This should also take care of case such as VxWorks
9852 where the kernel has some debugging info provided for a few units. */
9854 if (symtab_to_fullname (sal
.symtab
) == NULL
)
9857 /* Check the unit filename againt the Ada runtime file naming.
9858 We also check the name of the objfile against the name of some
9859 known system libraries that sometimes come with debugging info
9862 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
9864 re_comp (known_runtime_file_name_patterns
[i
]);
9865 if (re_exec (sal
.symtab
->filename
))
9867 if (sal
.symtab
->objfile
!= NULL
9868 && re_exec (sal
.symtab
->objfile
->name
))
9872 /* Check whether the function is a GNAT-generated entity. */
9874 func_name
= function_name_from_pc (get_frame_address_in_block (frame
));
9875 if (func_name
== NULL
)
9878 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
9880 re_comp (known_auxiliary_function_name_patterns
[i
]);
9881 if (re_exec (func_name
))
9888 /* Find the first frame that contains debugging information and that is not
9889 part of the Ada run-time, starting from FI and moving upward. */
9892 ada_find_printable_frame (struct frame_info
*fi
)
9894 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
9896 if (!is_known_support_routine (fi
))
9905 /* Assuming that the inferior just triggered an unhandled exception
9906 catchpoint, return the address in inferior memory where the name
9907 of the exception is stored.
9909 Return zero if the address could not be computed. */
9912 ada_unhandled_exception_name_addr (void)
9914 return parse_and_eval_address ("e.full_name");
9917 /* Same as ada_unhandled_exception_name_addr, except that this function
9918 should be used when the inferior uses an older version of the runtime,
9919 where the exception name needs to be extracted from a specific frame
9920 several frames up in the callstack. */
9923 ada_unhandled_exception_name_addr_from_raise (void)
9926 struct frame_info
*fi
;
9928 /* To determine the name of this exception, we need to select
9929 the frame corresponding to RAISE_SYM_NAME. This frame is
9930 at least 3 levels up, so we simply skip the first 3 frames
9931 without checking the name of their associated function. */
9932 fi
= get_current_frame ();
9933 for (frame_level
= 0; frame_level
< 3; frame_level
+= 1)
9935 fi
= get_prev_frame (fi
);
9939 const char *func_name
=
9940 function_name_from_pc (get_frame_address_in_block (fi
));
9941 if (func_name
!= NULL
9942 && strcmp (func_name
, exception_info
->catch_exception_sym
) == 0)
9943 break; /* We found the frame we were looking for... */
9944 fi
= get_prev_frame (fi
);
9951 return parse_and_eval_address ("id.full_name");
9954 /* Assuming the inferior just triggered an Ada exception catchpoint
9955 (of any type), return the address in inferior memory where the name
9956 of the exception is stored, if applicable.
9958 Return zero if the address could not be computed, or if not relevant. */
9961 ada_exception_name_addr_1 (enum exception_catchpoint_kind ex
,
9962 struct breakpoint
*b
)
9966 case ex_catch_exception
:
9967 return (parse_and_eval_address ("e.full_name"));
9970 case ex_catch_exception_unhandled
:
9971 return exception_info
->unhandled_exception_name_addr ();
9974 case ex_catch_assert
:
9975 return 0; /* Exception name is not relevant in this case. */
9979 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
9983 return 0; /* Should never be reached. */
9986 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
9987 any error that ada_exception_name_addr_1 might cause to be thrown.
9988 When an error is intercepted, a warning with the error message is printed,
9989 and zero is returned. */
9992 ada_exception_name_addr (enum exception_catchpoint_kind ex
,
9993 struct breakpoint
*b
)
9995 struct gdb_exception e
;
9996 CORE_ADDR result
= 0;
9998 TRY_CATCH (e
, RETURN_MASK_ERROR
)
10000 result
= ada_exception_name_addr_1 (ex
, b
);
10005 warning (_("failed to get exception name: %s"), e
.message
);
10012 /* Implement the PRINT_IT method in the breakpoint_ops structure
10013 for all exception catchpoint kinds. */
10015 static enum print_stop_action
10016 print_it_exception (enum exception_catchpoint_kind ex
, struct breakpoint
*b
)
10018 const CORE_ADDR addr
= ada_exception_name_addr (ex
, b
);
10019 char exception_name
[256];
10023 read_memory (addr
, exception_name
, sizeof (exception_name
) - 1);
10024 exception_name
[sizeof (exception_name
) - 1] = '\0';
10027 ada_find_printable_frame (get_current_frame ());
10029 annotate_catchpoint (b
->number
);
10032 case ex_catch_exception
:
10034 printf_filtered (_("\nCatchpoint %d, %s at "),
10035 b
->number
, exception_name
);
10037 printf_filtered (_("\nCatchpoint %d, exception at "), b
->number
);
10039 case ex_catch_exception_unhandled
:
10041 printf_filtered (_("\nCatchpoint %d, unhandled %s at "),
10042 b
->number
, exception_name
);
10044 printf_filtered (_("\nCatchpoint %d, unhandled exception at "),
10047 case ex_catch_assert
:
10048 printf_filtered (_("\nCatchpoint %d, failed assertion at "),
10053 return PRINT_SRC_AND_LOC
;
10056 /* Implement the PRINT_ONE method in the breakpoint_ops structure
10057 for all exception catchpoint kinds. */
10060 print_one_exception (enum exception_catchpoint_kind ex
,
10061 struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10065 annotate_field (4);
10066 ui_out_field_core_addr (uiout
, "addr", b
->loc
->address
);
10069 annotate_field (5);
10070 *last_addr
= b
->loc
->address
;
10073 case ex_catch_exception
:
10074 if (b
->exp_string
!= NULL
)
10076 char *msg
= xstrprintf (_("`%s' Ada exception"), b
->exp_string
);
10078 ui_out_field_string (uiout
, "what", msg
);
10082 ui_out_field_string (uiout
, "what", "all Ada exceptions");
10086 case ex_catch_exception_unhandled
:
10087 ui_out_field_string (uiout
, "what", "unhandled Ada exceptions");
10090 case ex_catch_assert
:
10091 ui_out_field_string (uiout
, "what", "failed Ada assertions");
10095 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10100 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
10101 for all exception catchpoint kinds. */
10104 print_mention_exception (enum exception_catchpoint_kind ex
,
10105 struct breakpoint
*b
)
10109 case ex_catch_exception
:
10110 if (b
->exp_string
!= NULL
)
10111 printf_filtered (_("Catchpoint %d: `%s' Ada exception"),
10112 b
->number
, b
->exp_string
);
10114 printf_filtered (_("Catchpoint %d: all Ada exceptions"), b
->number
);
10118 case ex_catch_exception_unhandled
:
10119 printf_filtered (_("Catchpoint %d: unhandled Ada exceptions"),
10123 case ex_catch_assert
:
10124 printf_filtered (_("Catchpoint %d: failed Ada assertions"), b
->number
);
10128 internal_error (__FILE__
, __LINE__
, _("unexpected catchpoint type"));
10133 /* Virtual table for "catch exception" breakpoints. */
10135 static enum print_stop_action
10136 print_it_catch_exception (struct breakpoint
*b
)
10138 return print_it_exception (ex_catch_exception
, b
);
10142 print_one_catch_exception (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10144 print_one_exception (ex_catch_exception
, b
, last_addr
);
10148 print_mention_catch_exception (struct breakpoint
*b
)
10150 print_mention_exception (ex_catch_exception
, b
);
10153 static struct breakpoint_ops catch_exception_breakpoint_ops
=
10157 NULL
, /* breakpoint_hit */
10158 print_it_catch_exception
,
10159 print_one_catch_exception
,
10160 print_mention_catch_exception
10163 /* Virtual table for "catch exception unhandled" breakpoints. */
10165 static enum print_stop_action
10166 print_it_catch_exception_unhandled (struct breakpoint
*b
)
10168 return print_it_exception (ex_catch_exception_unhandled
, b
);
10172 print_one_catch_exception_unhandled (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10174 print_one_exception (ex_catch_exception_unhandled
, b
, last_addr
);
10178 print_mention_catch_exception_unhandled (struct breakpoint
*b
)
10180 print_mention_exception (ex_catch_exception_unhandled
, b
);
10183 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
= {
10186 NULL
, /* breakpoint_hit */
10187 print_it_catch_exception_unhandled
,
10188 print_one_catch_exception_unhandled
,
10189 print_mention_catch_exception_unhandled
10192 /* Virtual table for "catch assert" breakpoints. */
10194 static enum print_stop_action
10195 print_it_catch_assert (struct breakpoint
*b
)
10197 return print_it_exception (ex_catch_assert
, b
);
10201 print_one_catch_assert (struct breakpoint
*b
, CORE_ADDR
*last_addr
)
10203 print_one_exception (ex_catch_assert
, b
, last_addr
);
10207 print_mention_catch_assert (struct breakpoint
*b
)
10209 print_mention_exception (ex_catch_assert
, b
);
10212 static struct breakpoint_ops catch_assert_breakpoint_ops
= {
10215 NULL
, /* breakpoint_hit */
10216 print_it_catch_assert
,
10217 print_one_catch_assert
,
10218 print_mention_catch_assert
10221 /* Return non-zero if B is an Ada exception catchpoint. */
10224 ada_exception_catchpoint_p (struct breakpoint
*b
)
10226 return (b
->ops
== &catch_exception_breakpoint_ops
10227 || b
->ops
== &catch_exception_unhandled_breakpoint_ops
10228 || b
->ops
== &catch_assert_breakpoint_ops
);
10231 /* Return a newly allocated copy of the first space-separated token
10232 in ARGSP, and then adjust ARGSP to point immediately after that
10235 Return NULL if ARGPS does not contain any more tokens. */
10238 ada_get_next_arg (char **argsp
)
10240 char *args
= *argsp
;
10244 /* Skip any leading white space. */
10246 while (isspace (*args
))
10249 if (args
[0] == '\0')
10250 return NULL
; /* No more arguments. */
10252 /* Find the end of the current argument. */
10255 while (*end
!= '\0' && !isspace (*end
))
10258 /* Adjust ARGSP to point to the start of the next argument. */
10262 /* Make a copy of the current argument and return it. */
10264 result
= xmalloc (end
- args
+ 1);
10265 strncpy (result
, args
, end
- args
);
10266 result
[end
- args
] = '\0';
10271 /* Split the arguments specified in a "catch exception" command.
10272 Set EX to the appropriate catchpoint type.
10273 Set EXP_STRING to the name of the specific exception if
10274 specified by the user. */
10277 catch_ada_exception_command_split (char *args
,
10278 enum exception_catchpoint_kind
*ex
,
10281 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
10282 char *exception_name
;
10284 exception_name
= ada_get_next_arg (&args
);
10285 make_cleanup (xfree
, exception_name
);
10287 /* Check that we do not have any more arguments. Anything else
10290 while (isspace (*args
))
10293 if (args
[0] != '\0')
10294 error (_("Junk at end of expression"));
10296 discard_cleanups (old_chain
);
10298 if (exception_name
== NULL
)
10300 /* Catch all exceptions. */
10301 *ex
= ex_catch_exception
;
10302 *exp_string
= NULL
;
10304 else if (strcmp (exception_name
, "unhandled") == 0)
10306 /* Catch unhandled exceptions. */
10307 *ex
= ex_catch_exception_unhandled
;
10308 *exp_string
= NULL
;
10312 /* Catch a specific exception. */
10313 *ex
= ex_catch_exception
;
10314 *exp_string
= exception_name
;
10318 /* Return the name of the symbol on which we should break in order to
10319 implement a catchpoint of the EX kind. */
10321 static const char *
10322 ada_exception_sym_name (enum exception_catchpoint_kind ex
)
10324 gdb_assert (exception_info
!= NULL
);
10328 case ex_catch_exception
:
10329 return (exception_info
->catch_exception_sym
);
10331 case ex_catch_exception_unhandled
:
10332 return (exception_info
->catch_exception_unhandled_sym
);
10334 case ex_catch_assert
:
10335 return (exception_info
->catch_assert_sym
);
10338 internal_error (__FILE__
, __LINE__
,
10339 _("unexpected catchpoint kind (%d)"), ex
);
10343 /* Return the breakpoint ops "virtual table" used for catchpoints
10346 static struct breakpoint_ops
*
10347 ada_exception_breakpoint_ops (enum exception_catchpoint_kind ex
)
10351 case ex_catch_exception
:
10352 return (&catch_exception_breakpoint_ops
);
10354 case ex_catch_exception_unhandled
:
10355 return (&catch_exception_unhandled_breakpoint_ops
);
10357 case ex_catch_assert
:
10358 return (&catch_assert_breakpoint_ops
);
10361 internal_error (__FILE__
, __LINE__
,
10362 _("unexpected catchpoint kind (%d)"), ex
);
10366 /* Return the condition that will be used to match the current exception
10367 being raised with the exception that the user wants to catch. This
10368 assumes that this condition is used when the inferior just triggered
10369 an exception catchpoint.
10371 The string returned is a newly allocated string that needs to be
10372 deallocated later. */
10375 ada_exception_catchpoint_cond_string (const char *exp_string
)
10379 /* The standard exceptions are a special case. They are defined in
10380 runtime units that have been compiled without debugging info; if
10381 EXP_STRING is the not-fully-qualified name of a standard
10382 exception (e.g. "constraint_error") then, during the evaluation
10383 of the condition expression, the symbol lookup on this name would
10384 *not* return this standard exception. The catchpoint condition
10385 may then be set only on user-defined exceptions which have the
10386 same not-fully-qualified name (e.g. my_package.constraint_error).
10388 To avoid this unexcepted behavior, these standard exceptions are
10389 systematically prefixed by "standard". This means that "catch
10390 exception constraint_error" is rewritten into "catch exception
10391 standard.constraint_error".
10393 If an exception named contraint_error is defined in another package of
10394 the inferior program, then the only way to specify this exception as a
10395 breakpoint condition is to use its fully-qualified named:
10396 e.g. my_package.constraint_error. */
10398 for (i
= 0; i
< sizeof (standard_exc
) / sizeof (char *); i
++)
10400 if (strcmp (standard_exc
[i
], exp_string
) == 0)
10402 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
10406 return xstrprintf ("long_integer (e) = long_integer (&%s)", exp_string
);
10409 /* Return the expression corresponding to COND_STRING evaluated at SAL. */
10411 static struct expression
*
10412 ada_parse_catchpoint_condition (char *cond_string
,
10413 struct symtab_and_line sal
)
10415 return (parse_exp_1 (&cond_string
, block_for_pc (sal
.pc
), 0));
10418 /* Return the symtab_and_line that should be used to insert an exception
10419 catchpoint of the TYPE kind.
10421 EX_STRING should contain the name of a specific exception
10422 that the catchpoint should catch, or NULL otherwise.
10424 The idea behind all the remaining parameters is that their names match
10425 the name of certain fields in the breakpoint structure that are used to
10426 handle exception catchpoints. This function returns the value to which
10427 these fields should be set, depending on the type of catchpoint we need
10430 If COND and COND_STRING are both non-NULL, any value they might
10431 hold will be free'ed, and then replaced by newly allocated ones.
10432 These parameters are left untouched otherwise. */
10434 static struct symtab_and_line
10435 ada_exception_sal (enum exception_catchpoint_kind ex
, char *exp_string
,
10436 char **addr_string
, char **cond_string
,
10437 struct expression
**cond
, struct breakpoint_ops
**ops
)
10439 const char *sym_name
;
10440 struct symbol
*sym
;
10441 struct symtab_and_line sal
;
10443 /* First, find out which exception support info to use. */
10444 ada_exception_support_info_sniffer ();
10446 /* Then lookup the function on which we will break in order to catch
10447 the Ada exceptions requested by the user. */
10449 sym_name
= ada_exception_sym_name (ex
);
10450 sym
= standard_lookup (sym_name
, NULL
, VAR_DOMAIN
);
10452 /* The symbol we're looking up is provided by a unit in the GNAT runtime
10453 that should be compiled with debugging information. As a result, we
10454 expect to find that symbol in the symtabs. If we don't find it, then
10455 the target most likely does not support Ada exceptions, or we cannot
10456 insert exception breakpoints yet, because the GNAT runtime hasn't been
10459 /* brobecker/2006-12-26: It is conceivable that the runtime was compiled
10460 in such a way that no debugging information is produced for the symbol
10461 we are looking for. In this case, we could search the minimal symbols
10462 as a fall-back mechanism. This would still be operating in degraded
10463 mode, however, as we would still be missing the debugging information
10464 that is needed in order to extract the name of the exception being
10465 raised (this name is printed in the catchpoint message, and is also
10466 used when trying to catch a specific exception). We do not handle
10467 this case for now. */
10470 error (_("Unable to break on '%s' in this configuration."), sym_name
);
10472 /* Make sure that the symbol we found corresponds to a function. */
10473 if (SYMBOL_CLASS (sym
) != LOC_BLOCK
)
10474 error (_("Symbol \"%s\" is not a function (class = %d)"),
10475 sym_name
, SYMBOL_CLASS (sym
));
10477 sal
= find_function_start_sal (sym
, 1);
10479 /* Set ADDR_STRING. */
10481 *addr_string
= xstrdup (sym_name
);
10483 /* Set the COND and COND_STRING (if not NULL). */
10485 if (cond_string
!= NULL
&& cond
!= NULL
)
10487 if (*cond_string
!= NULL
)
10489 xfree (*cond_string
);
10490 *cond_string
= NULL
;
10497 if (exp_string
!= NULL
)
10499 *cond_string
= ada_exception_catchpoint_cond_string (exp_string
);
10500 *cond
= ada_parse_catchpoint_condition (*cond_string
, sal
);
10505 *ops
= ada_exception_breakpoint_ops (ex
);
10510 /* Parse the arguments (ARGS) of the "catch exception" command.
10512 Set TYPE to the appropriate exception catchpoint type.
10513 If the user asked the catchpoint to catch only a specific
10514 exception, then save the exception name in ADDR_STRING.
10516 See ada_exception_sal for a description of all the remaining
10517 function arguments of this function. */
10519 struct symtab_and_line
10520 ada_decode_exception_location (char *args
, char **addr_string
,
10521 char **exp_string
, char **cond_string
,
10522 struct expression
**cond
,
10523 struct breakpoint_ops
**ops
)
10525 enum exception_catchpoint_kind ex
;
10527 catch_ada_exception_command_split (args
, &ex
, exp_string
);
10528 return ada_exception_sal (ex
, *exp_string
, addr_string
, cond_string
,
10532 struct symtab_and_line
10533 ada_decode_assert_location (char *args
, char **addr_string
,
10534 struct breakpoint_ops
**ops
)
10536 /* Check that no argument where provided at the end of the command. */
10540 while (isspace (*args
))
10543 error (_("Junk at end of arguments."));
10546 return ada_exception_sal (ex_catch_assert
, NULL
, addr_string
, NULL
, NULL
,
10551 /* Information about operators given special treatment in functions
10553 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
10555 #define ADA_OPERATORS \
10556 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
10557 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
10558 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
10559 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
10560 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
10561 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
10562 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
10563 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
10564 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
10565 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
10566 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
10567 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
10568 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
10569 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
10570 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
10571 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
10572 OP_DEFN (OP_OTHERS, 1, 1, 0) \
10573 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
10574 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
10577 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
10579 switch (exp
->elts
[pc
- 1].opcode
)
10582 operator_length_standard (exp
, pc
, oplenp
, argsp
);
10585 #define OP_DEFN(op, len, args, binop) \
10586 case op: *oplenp = len; *argsp = args; break;
10592 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
);
10597 *argsp
= longest_to_int (exp
->elts
[pc
- 2].longconst
) + 1;
10603 ada_op_name (enum exp_opcode opcode
)
10608 return op_name_standard (opcode
);
10610 #define OP_DEFN(op, len, args, binop) case op: return #op;
10615 return "OP_AGGREGATE";
10617 return "OP_CHOICES";
10623 /* As for operator_length, but assumes PC is pointing at the first
10624 element of the operator, and gives meaningful results only for the
10625 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
10628 ada_forward_operator_length (struct expression
*exp
, int pc
,
10629 int *oplenp
, int *argsp
)
10631 switch (exp
->elts
[pc
].opcode
)
10634 *oplenp
= *argsp
= 0;
10637 #define OP_DEFN(op, len, args, binop) \
10638 case op: *oplenp = len; *argsp = args; break;
10644 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10649 *argsp
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
10655 int len
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
10656 *oplenp
= 4 + BYTES_TO_EXP_ELEM (len
+ 1);
10664 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
10666 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
10671 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
10675 /* Ada attributes ('Foo). */
10678 case OP_ATR_LENGTH
:
10682 case OP_ATR_MODULUS
:
10689 case UNOP_IN_RANGE
:
10691 /* XXX: gdb_sprint_host_address, type_sprint */
10692 fprintf_filtered (stream
, _("Type @"));
10693 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
10694 fprintf_filtered (stream
, " (");
10695 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
10696 fprintf_filtered (stream
, ")");
10698 case BINOP_IN_BOUNDS
:
10699 fprintf_filtered (stream
, " (%d)",
10700 longest_to_int (exp
->elts
[pc
+ 2].longconst
));
10702 case TERNOP_IN_RANGE
:
10707 case OP_DISCRETE_RANGE
:
10708 case OP_POSITIONAL
:
10715 char *name
= &exp
->elts
[elt
+ 2].string
;
10716 int len
= longest_to_int (exp
->elts
[elt
+ 1].longconst
);
10717 fprintf_filtered (stream
, "Text: `%.*s'", len
, name
);
10722 return dump_subexp_body_standard (exp
, stream
, elt
);
10726 for (i
= 0; i
< nargs
; i
+= 1)
10727 elt
= dump_subexp (exp
, stream
, elt
);
10732 /* The Ada extension of print_subexp (q.v.). */
10735 ada_print_subexp (struct expression
*exp
, int *pos
,
10736 struct ui_file
*stream
, enum precedence prec
)
10738 int oplen
, nargs
, i
;
10740 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
10742 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
10749 print_subexp_standard (exp
, pos
, stream
, prec
);
10753 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
10756 case BINOP_IN_BOUNDS
:
10757 /* XXX: sprint_subexp */
10758 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10759 fputs_filtered (" in ", stream
);
10760 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10761 fputs_filtered ("'range", stream
);
10762 if (exp
->elts
[pc
+ 1].longconst
> 1)
10763 fprintf_filtered (stream
, "(%ld)",
10764 (long) exp
->elts
[pc
+ 1].longconst
);
10767 case TERNOP_IN_RANGE
:
10768 if (prec
>= PREC_EQUAL
)
10769 fputs_filtered ("(", stream
);
10770 /* XXX: sprint_subexp */
10771 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10772 fputs_filtered (" in ", stream
);
10773 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10774 fputs_filtered (" .. ", stream
);
10775 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
10776 if (prec
>= PREC_EQUAL
)
10777 fputs_filtered (")", stream
);
10782 case OP_ATR_LENGTH
:
10786 case OP_ATR_MODULUS
:
10791 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10793 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
10794 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
10798 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10799 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
10803 for (tem
= 1; tem
< nargs
; tem
+= 1)
10805 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
10806 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
10808 fputs_filtered (")", stream
);
10813 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
10814 fputs_filtered ("'(", stream
);
10815 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
10816 fputs_filtered (")", stream
);
10819 case UNOP_IN_RANGE
:
10820 /* XXX: sprint_subexp */
10821 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10822 fputs_filtered (" in ", stream
);
10823 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
10826 case OP_DISCRETE_RANGE
:
10827 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10828 fputs_filtered ("..", stream
);
10829 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10833 fputs_filtered ("others => ", stream
);
10834 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10838 for (i
= 0; i
< nargs
-1; i
+= 1)
10841 fputs_filtered ("|", stream
);
10842 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10844 fputs_filtered (" => ", stream
);
10845 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10848 case OP_POSITIONAL
:
10849 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10853 fputs_filtered ("(", stream
);
10854 for (i
= 0; i
< nargs
; i
+= 1)
10857 fputs_filtered (", ", stream
);
10858 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10860 fputs_filtered (")", stream
);
10865 /* Table mapping opcodes into strings for printing operators
10866 and precedences of the operators. */
10868 static const struct op_print ada_op_print_tab
[] = {
10869 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
10870 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
10871 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
10872 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
10873 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
10874 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
10875 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
10876 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
10877 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
10878 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
10879 {">", BINOP_GTR
, PREC_ORDER
, 0},
10880 {"<", BINOP_LESS
, PREC_ORDER
, 0},
10881 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
10882 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
10883 {"+", BINOP_ADD
, PREC_ADD
, 0},
10884 {"-", BINOP_SUB
, PREC_ADD
, 0},
10885 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
10886 {"*", BINOP_MUL
, PREC_MUL
, 0},
10887 {"/", BINOP_DIV
, PREC_MUL
, 0},
10888 {"rem", BINOP_REM
, PREC_MUL
, 0},
10889 {"mod", BINOP_MOD
, PREC_MUL
, 0},
10890 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
10891 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
10892 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
10893 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
10894 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
10895 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
10896 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
10897 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
10898 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
10899 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
10903 enum ada_primitive_types
{
10904 ada_primitive_type_int
,
10905 ada_primitive_type_long
,
10906 ada_primitive_type_short
,
10907 ada_primitive_type_char
,
10908 ada_primitive_type_float
,
10909 ada_primitive_type_double
,
10910 ada_primitive_type_void
,
10911 ada_primitive_type_long_long
,
10912 ada_primitive_type_long_double
,
10913 ada_primitive_type_natural
,
10914 ada_primitive_type_positive
,
10915 ada_primitive_type_system_address
,
10916 nr_ada_primitive_types
10920 ada_language_arch_info (struct gdbarch
*gdbarch
,
10921 struct language_arch_info
*lai
)
10923 const struct builtin_type
*builtin
= builtin_type (gdbarch
);
10924 lai
->primitive_type_vector
10925 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_ada_primitive_types
+ 1,
10927 lai
->primitive_type_vector
[ada_primitive_type_int
] =
10928 init_type (TYPE_CODE_INT
,
10929 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10930 0, "integer", (struct objfile
*) NULL
);
10931 lai
->primitive_type_vector
[ada_primitive_type_long
] =
10932 init_type (TYPE_CODE_INT
,
10933 gdbarch_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10934 0, "long_integer", (struct objfile
*) NULL
);
10935 lai
->primitive_type_vector
[ada_primitive_type_short
] =
10936 init_type (TYPE_CODE_INT
,
10937 gdbarch_short_bit (gdbarch
) / TARGET_CHAR_BIT
,
10938 0, "short_integer", (struct objfile
*) NULL
);
10939 lai
->string_char_type
=
10940 lai
->primitive_type_vector
[ada_primitive_type_char
] =
10941 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10942 0, "character", (struct objfile
*) NULL
);
10943 lai
->primitive_type_vector
[ada_primitive_type_float
] =
10944 init_type (TYPE_CODE_FLT
,
10945 gdbarch_float_bit (gdbarch
)/ TARGET_CHAR_BIT
,
10946 0, "float", (struct objfile
*) NULL
);
10947 lai
->primitive_type_vector
[ada_primitive_type_double
] =
10948 init_type (TYPE_CODE_FLT
,
10949 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10950 0, "long_float", (struct objfile
*) NULL
);
10951 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
10952 init_type (TYPE_CODE_INT
,
10953 gdbarch_long_long_bit (gdbarch
) / TARGET_CHAR_BIT
,
10954 0, "long_long_integer", (struct objfile
*) NULL
);
10955 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
10956 init_type (TYPE_CODE_FLT
,
10957 gdbarch_double_bit (gdbarch
) / TARGET_CHAR_BIT
,
10958 0, "long_long_float", (struct objfile
*) NULL
);
10959 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
10960 init_type (TYPE_CODE_INT
,
10961 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10962 0, "natural", (struct objfile
*) NULL
);
10963 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
10964 init_type (TYPE_CODE_INT
,
10965 gdbarch_int_bit (gdbarch
) / TARGET_CHAR_BIT
,
10966 0, "positive", (struct objfile
*) NULL
);
10967 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
10969 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
10970 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
10971 (struct objfile
*) NULL
));
10972 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
10973 = "system__address";
10975 lai
->bool_type_symbol
= "boolean";
10976 lai
->bool_type_default
= builtin
->builtin_bool
;
10979 /* Language vector */
10981 /* Not really used, but needed in the ada_language_defn. */
10984 emit_char (int c
, struct ui_file
*stream
, int quoter
)
10986 ada_emit_char (c
, stream
, quoter
, 1);
10992 warnings_issued
= 0;
10993 return ada_parse ();
10996 static const struct exp_descriptor ada_exp_descriptor
= {
10998 ada_operator_length
,
11000 ada_dump_subexp_body
,
11001 ada_evaluate_subexp
11004 const struct language_defn ada_language_defn
= {
11005 "ada", /* Language name */
11009 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
11010 that's not quite what this means. */
11012 macro_expansion_no
,
11013 &ada_exp_descriptor
,
11017 ada_printchar
, /* Print a character constant */
11018 ada_printstr
, /* Function to print string constant */
11019 emit_char
, /* Function to print single char (not used) */
11020 ada_print_type
, /* Print a type using appropriate syntax */
11021 default_print_typedef
, /* Print a typedef using appropriate syntax */
11022 ada_val_print
, /* Print a value using appropriate syntax */
11023 ada_value_print
, /* Print a top-level value */
11024 NULL
, /* Language specific skip_trampoline */
11025 NULL
, /* name_of_this */
11026 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
11027 basic_lookup_transparent_type
, /* lookup_transparent_type */
11028 ada_la_decode
, /* Language specific symbol demangler */
11029 NULL
, /* Language specific class_name_from_physname */
11030 ada_op_print_tab
, /* expression operators for printing */
11031 0, /* c-style arrays */
11032 1, /* String lower bound */
11033 ada_get_gdb_completer_word_break_characters
,
11034 ada_make_symbol_completion_list
,
11035 ada_language_arch_info
,
11036 ada_print_array_index
,
11037 default_pass_by_reference
,
11042 _initialize_ada_language (void)
11044 add_language (&ada_language_defn
);
11046 varsize_limit
= 65536;
11048 obstack_init (&symbol_list_obstack
);
11050 decoded_names_store
= htab_create_alloc
11051 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
11052 NULL
, xcalloc
, xfree
);
11054 observer_attach_executable_changed (ada_executable_changed_observer
);